fortran-vars 0.3.1 → 0.4.0

raw patch · 29 files changed

+1244/−597 lines, 29 filesdep +mtldep ~fortran-srcdep ~fortran-src-extrasPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

Dependency ranges changed: fortran-src, fortran-src-extras

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• fortran-vars.cabal +103/−11
• src/Language/Fortran/Vars/Assignments.hs +25/−6
• src/Language/Fortran/Vars/BozConstant.hs +1/−1
• src/Language/Fortran/Vars/CPValue.hs +1/−1
• src/Language/Fortran/Vars/ConstantPropagation.hs +52/−38
• src/Language/Fortran/Vars/Eval.hs +21/−51
• src/Language/Fortran/Vars/Eval/Deprecated.hs +80/−0
• src/Language/Fortran/Vars/Eval/Deprecated/Operation.hs +258/−0
• src/Language/Fortran/Vars/Eval/FortranSrc.hs +68/−0
• src/Language/Fortran/Vars/Eval/FortranSrc/Translate.hs +81/−0
• src/Language/Fortran/Vars/Memory.hs +15/−12
• src/Language/Fortran/Vars/MemoryLocation.hs +26/−14
• src/Language/Fortran/Vars/Operation.hs +0/−258
• src/Language/Fortran/Vars/Orphans.hs +12/−1
• src/Language/Fortran/Vars/Rep.hs +45/−0
• src/Language/Fortran/Vars/SymbolTable.hs +63/−29
• src/Language/Fortran/Vars/SymbolTable/Arrays.hs +133/−0
• src/Language/Fortran/Vars/TypeCheck.hs +7/−3
• src/Language/Fortran/Vars/Types.hs +27/−68
• src/Language/Fortran/Vars/Types/SymbolTable.hs +37/−0
• src/Language/Fortran/Vars/Utils.hs +13/−5
• test/ConstantPropagationSpec.hs +1/−1
• test/EvalSpec.hs +21/−19
• test/StorageTableSpec.hs +5/−4
• test/StructureTableSpec.hs +6/−5
• test/SymbolTableSpec.hs +94/−57
• test/TypeCheckSpec.hs +17/−13
• test/Util.hs +19/−0

@@ -1,3 +1,16 @@+## 0.4.0 (22 Jun 2023)+  * Replace expression evaluator with fortran-src one+    * Interface changes are mostly non-breaking. Some behaviour may be slightly+      different due to INTEGER etc. constants using different types.+    * Old evaluator remains available at+      `Language.Fortran.Vars.Eval.Deprecated` (and still gets used by constant+      propagation code).+    * Short-circuiting evaluator uses the old evaluator. (This is feasible for+      the fortran-src evaluator, and is pending work.)+  * Use more precise array dimensions encoding+    * Breaking change.+  * Update to fortran-src 0.15+ ## 0.3.1 (22 Aug 2022)   * Update to fortran-src 0.10.2   * Do some type checking for logical operators used with non LOGICAL arguments

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           fortran-vars-version:        0.3.1+version:        0.4.0 synopsis:       Fortran memory model and other static analysis tools. description:    Various Fortran static analysis tools focusing on a memory model for Fortran types. Uses fortran-src for the syntax representation. category:       Language@@ -36,18 +36,24 @@       Language.Fortran.Vars.Equivalence       Language.Fortran.Vars.Errors       Language.Fortran.Vars.Eval+      Language.Fortran.Vars.Eval.Deprecated+      Language.Fortran.Vars.Eval.Deprecated.Operation+      Language.Fortran.Vars.Eval.FortranSrc+      Language.Fortran.Vars.Eval.FortranSrc.Translate       Language.Fortran.Vars.Kind       Language.Fortran.Vars.Memory       Language.Fortran.Vars.MemoryLocation-      Language.Fortran.Vars.Operation       Language.Fortran.Vars.Orphans       Language.Fortran.Vars.PureExpression       Language.Fortran.Vars.Range+      Language.Fortran.Vars.Rep       Language.Fortran.Vars.StorageClass       Language.Fortran.Vars.StructureTable       Language.Fortran.Vars.SymbolTable+      Language.Fortran.Vars.SymbolTable.Arrays       Language.Fortran.Vars.TypeCheck       Language.Fortran.Vars.Types+      Language.Fortran.Vars.Types.SymbolTable       Language.Fortran.Vars.Union       Language.Fortran.Vars.Utils   other-modules:@@ -55,8 +61,36 @@   hs-source-dirs:       src   default-extensions:+      EmptyCase       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators+  ghc-options: -Wall   build-depends:       aeson >=1.5.0.0     , base >=4.7 && <5@@ -64,8 +98,9 @@     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.10.2 && <0.11-    , fortran-src-extras >=0.3.1 && <0.4+    , fortran-src >=0.15.0 && <0.16+    , fortran-src-extras >=0.5.0 && <0.6+    , mtl     , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010@@ -77,9 +112,36 @@   hs-source-dirs:       app   default-extensions:+      EmptyCase       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications-  ghc-options: -threaded -rtsopts+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators+  ghc-options: -Wall -threaded -rtsopts   build-depends:       aeson >=1.5.0.0     , base >=4.7 && <5@@ -87,9 +149,10 @@     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.10.2 && <0.11-    , fortran-src-extras >=0.3.1 && <0.4+    , fortran-src >=0.15.0 && <0.16+    , fortran-src-extras >=0.5.0 && <0.6     , fortran-vars+    , mtl     , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010@@ -107,13 +170,41 @@       StructureTableSpec       SymbolTableSpec       TypeCheckSpec+      Util       Paths_fortran_vars   hs-source-dirs:       test   default-extensions:+      EmptyCase       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications-  ghc-options: -threaded -rtsopts+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators+  ghc-options: -Wall -threaded -rtsopts   build-tool-depends:       hspec-discover:hspec-discover   build-depends:@@ -124,10 +215,11 @@     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.10.2 && <0.11-    , fortran-src-extras >=0.3.1 && <0.4+    , fortran-src >=0.15.0 && <0.16+    , fortran-src-extras >=0.5.0 && <0.6     , fortran-vars     , hspec+    , mtl     , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010

@@ -32,7 +32,9 @@ import           Language.Fortran.Vars.Types    ( SymbolTable                                                 , StructureTable                                                 , SymbolTableEntry(..)-                                                , Dimensions+                                                , Dims(..)+                                                , dimsTraverse+                                                , Dim(..)                                                 , Type                                                 , SemType(..)                                                 , TypeError(..)@@ -102,7 +104,9 @@     pure $ (, e) <$> typeOf strt symt v   f d@(Declarator _ _ (ExpValue _ s (ValVariable v)) ArrayDecl{} _ (Just (ExpInitialisation _ _ vals)))     = case M.lookup v symt of-      Just (SVariable (TArray ty (Just dims)) _) ->+      Just (SVariable (TArray ty dims') _) ->+       case dimsTraverse dims' of -- only static arrays+       Just (DimsExplicitShape dims) ->         let tys   = expandDimensions dims ty             vals' = aStrip vals         in  if length tys /= length vals'@@ -116,6 +120,19 @@                   , pprint77l d                   ]               else fmap Right $ zip (expandDimensions dims ty) $ aStrip vals+       -- only static explicit-shape arrays permitted+       Just{} ->+        pure+          .  Left+          .  typeError s+          $  "Unexpected lhs in array declaration at: "+          <> pprint77l d+       Nothing ->+        pure+          .  Left+          .  typeError s+          $  "Unexpected lhs in array declaration at: "+          <> pprint77l d       _ ->         pure           .  Left@@ -132,8 +149,10 @@   -> [Either TypeError Type] expandArrays strt symt e = case e of   ExpValue _ _ (ValVariable var) -> case M.lookup var symt of-    Just (SVariable (TArray ty (Just dims)) _) ->-      expandDimensions dims (Right ty)+    Just (SVariable (TArray sty dims') _) ->+     case dimsTraverse dims' of+      Just (DimsExplicitShape dims) -> expandDimensions dims (Right sty)+      _ -> [Right sty]     Just (SVariable ty _) -> [Right ty]     _ ->       pure@@ -145,6 +164,6 @@  -- | Function to expand dimensions into appropriate number of types for use in -- other expand functions-expandDimensions :: Dimensions -> a -> [a]+expandDimensions :: Foldable t => t (Dim Int) -> a -> [a] expandDimensions dims =-  replicate (foldl' (\acc (x, y) -> abs (y - x + 1) * acc) 1 dims)+  replicate (foldl' (\acc (Dim lb ub) -> abs (ub - lb + 1) * acc) 1 dims)

@@ -26,7 +26,7 @@ -- -- Currently, it only resolves BOZ Constants in context of INTEGER. resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal-resolveBozConstant symTable assignSymbol (Boz boz) = go boz+resolveBozConstant symTable assignSymbol (Boz b) = go b   where     go boz = case entry of       Just (SVariable (TInteger kind) _) ->

@@ -15,7 +15,7 @@  import           Language.Fortran.Vars.Types                                                 ( ExpVal(..) )-import           Language.Fortran.Vars.Operation+import           Language.Fortran.Vars.Eval.Deprecated.Operation                                                 ( unaryOp                                                 , binaryOp                                                 )

@@ -16,7 +16,7 @@                                                 , overlap                                                 , anyOverlap                                                 )-import           Language.Fortran.Vars.Operation+import           Language.Fortran.Vars.Eval.Deprecated.Operation                                                 ( valueToExpVal ) import           Language.Fortran.Vars.MemoryLocation                                                 ( generateLinearizedIndexRange )@@ -111,13 +111,12 @@   -> Maybe (Expression (Analysis a))   -> CPValue substringCPValue symTable memTables e is mb me =-  let errStr         = "Array sections are not allowed in FORTRAN 77"-      name           = srcName e+  let name           = srcName e       isArraySection = case fromJust $ M.lookup name symTable of-        (SVariable (TArray _ dims) _) -> length is < length dims+        (SVariable (TArray _ dims) _) -> length is < dimsLength dims         _                             -> False   in  if isArraySection-        then error errStr+        then errArraySection         else case lookupArray symTable memTables name is of           Top -> Top           Bot -> Bot@@ -126,7 +125,9 @@               Just (b', e') ->                 Const . Str $ take (e' - b' + 1) $ drop (b' - 1) s               Nothing -> Bot-          _ -> error errStr+          _ -> errArraySection+  where+    errArraySection = error "Array sections are not allowed in FORTRAN 77"  -- | Given 'SymbolTable', 'MemoryTables' and an 'Expression', determine the 'CPValue' -- of the 'Expression'@@ -157,8 +158,10 @@   -- Array pointer passed to subroutine/function (thus treated as 'ValVariable')   Just (SVariable (TArray ty dims) (memBlockName, offset)) -> do     kind  <- getTypeKind ty-    dims' <- dims-    Just (memBlockName, (offset, offset + sizeOfArray kind dims' - 1))+    case dimsTraverse dims of+      Just (DimsExplicitShape ds) ->+        Just (memBlockName, (offset, offset + sizeOfArray kind ds - 1))+      _ -> Nothing   Just (SVariable ty (memBlockName, offset)) -> do     kind <- getTypeKind ty     Just (memBlockName, (offset, offset + kind - 1))@@ -198,33 +201,44 @@   -> [Index (Analysis a)]   -> Maybe ArrayMemory getArrayMemory symTable memTables name indices =-  let Just entry  = M.lookup name symTable-      idxCPValues = cpValueOfIndices symTable memTables indices-  in  case entry of-        SVariable (TArray ty dims) (memBlockName, start)-          | any isBot idxCPValues-          -> UnknownIndices . (memBlockName, ) <$> arrayRange-          | any isTop idxCPValues-          -> UnknownIndices . (memBlockName, ) <$> arrayRange-          | not (all isConstInt idxCPValues)-          -> UnknownIndices . (memBlockName, ) <$> arrayRange-          | otherwise-          -> do-            let is = map unsafeStripIndexCP idxCPValues-            range <- generateLinearizedIndexRange is start <$> dims <*> kind-            Just $ ConstantIndices (memBlockName, range)-         where-          kind       = getTypeKind ty-          size       = sizeOfArray <$> kind <*> dims-          arrayRange = (\x -> (start, start + x - 1)) <$> size-        SVariable ty (memBlockName, start)-          | null indices -> ConstantIndices . (memBlockName, ) <$> range-          | otherwise    -> UnknownIndices . (memBlockName, ) <$> range-         where-          kind  = getTypeKind ty-          range = (\x -> (start, start + x - 1)) <$> kind-        _ -> Nothing+    case M.lookup name symTable of+      Nothing -> error $ "variable not in symbol table: "<>name+      Just entry ->+        case entry of+          SVariable ty (memBlockName, start) ->+            case ty of+              TArray _ dims' ->+                case dimsTraverse dims' of -- only handle static+                  Just (DimsExplicitShape dims)+                    | any isBot idxCPValues+                    -> UnknownIndices . (memBlockName, ) <$> arrayRange+                    | any isTop idxCPValues+                    -> UnknownIndices . (memBlockName, ) <$> arrayRange+                    | not (all isConstInt idxCPValues)+                    -> UnknownIndices . (memBlockName, ) <$> arrayRange+                    | otherwise+                    -> do+                      let is = map unsafeStripIndexCP idxCPValues+                      range <- generateLinearizedIndexRange is start <$> pure dims <*> kind+                      Just $ ConstantIndices (memBlockName, range)+                   where+                    kind       = getTypeKind ty+                    size       = sizeOfArray <$> kind <*> pure dims+                    arrayRange = (\x -> (start, start + x - 1)) <$> size +                  -- only handle explicit-shape arrays+                  Just{} -> Nothing+                  Nothing -> Nothing+              _+                | null indices -> ConstantIndices . (memBlockName, ) <$> range+                | otherwise    -> UnknownIndices . (memBlockName, ) <$> range+               where+                kind  = getTypeKind ty+                range = (\x -> (start, start + x - 1)) <$> kind+          _ -> Nothing+  where+    idxCPValues = cpValueOfIndices symTable memTables indices+ -- | Internal function to find 'CPValue' of a symbol lookupName :: SymbolTable -> MemoryTables -> Name -> CPValue lookupName symTable memTables name = case M.lookup name symTable of@@ -558,7 +572,7 @@ label = insLabel . getAnnotation  -- | Given kind and dimensions, calculate the size of an array-sizeOfArray :: Int -> [(Int, Int)] -> Int-sizeOfArray kind dimension =-  let arraySize = foldl (\acc (l, h) -> acc * (h - l + 1)) 1 dimension-  in  kind * arraySize+sizeOfArray :: Foldable t => Int -> t (Dim Int) -> Int+sizeOfArray kind dims = kind * arraySize+  where+    arraySize = foldl' (\acc (Dim l h) -> acc * (h - l + 1)) 1 dims

@@ -1,3 +1,5 @@+{-# LANGUAGE DerivingVia #-}+ module Language.Fortran.Vars.Eval   ( eval   , eval'@@ -6,7 +8,6 @@ where  import           Prelude                 hiding ( fail )-import qualified Data.Map                      as M import           Language.Fortran.AST           ( BinaryOp(..)                                                 , Expression(..)                                                 , Value(..)@@ -15,48 +16,32 @@                                                 ) import           Language.Fortran.Util.Position ( getSpan ) -import           Language.Fortran.Vars.Operation-                                                ( binaryOp'-                                                , binaryTransformEither-                                                , nonLogicalToLogical-                                                , transformEither-                                                , transformEitherList-                                                , unaryOp'-                                                , valueToExpVal'-                                                , intrinsicFunctionCall-                                                ) import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , ExpVal(..)                                                 , SymbolTable                                                 ) --- | Given a 'SymbolTable' and some 'Expression', evaluate that expression--- into a basic type and return it as an 'ExpVal' or a 'String' describing--- the issue that prevented the evaluation+import qualified Language.Fortran.Vars.Eval.FortranSrc as ViaFS+import qualified Language.Fortran.Repr as FS+import qualified Language.Fortran.Repr.Eval.Common as FS.Eval+import qualified Language.Fortran.Repr.Eval.Value as FS.Eval++import Control.Monad.Reader+import Control.Monad.Except++import qualified Data.Map as Map++-- | Given a 'SymbolTable' and some 'Expression', attempt to evaluate that+--   expression into a value in fortran-src's representation, translate it into+--   an 'ExpVal', and return. eval' :: SymbolTable -> Expression a -> Either String ExpVal-eval' symTable expr = case expr of-  ExpValue _ _ (ValVariable name) -> case M.lookup name symTable of-    Just (SParameter _ expVal) -> Right expVal-    Just _ -> Left $ "Cannot be evaluated: " ++ name ++ " is not a parameter."-    Nothing -> Left $ "Cannot find parameter : " ++ name-  ExpValue _ s val  -> valueToExpVal' s val-  ExpUnary _ _ op e -> transformEither (unaryOp' op) $ eval' symTable e-  ExpBinary _ _ op e1 e2 ->-    binaryTransformEither (binaryOp' op) (eval' symTable e1) (eval' symTable e2)-  ExpFunctionCall _ _ (ExpValue _ _ function) (AList _ _ args) ->-    transformEitherList intrinsicFunctionCall'-      $   eval' symTable-      .   argExtractExpr-      <$> args-   where-    intrinsicFunctionCall' = intrinsicFunctionCall $ functionName function-    functionName (ValVariable  name) = name-    functionName (ValIntrinsic name) = name-    functionName _                   = ""-  _ -> Left $ "Unsupported expression at: " ++ show (getSpan expr)+eval' symt expr =+    case ViaFS.runEval symt (FS.Eval.evalExpr expr) of+      Left err -> Left $ show err+      Right a -> ViaFS.translateFValue a  -- | Given a 'SymbolTable' and some 'Expression', evaluate that expression--- into a basic type and return it as an 'ExpVal'+-- into a basic type and return it as an 'ExpVal'. eval :: SymbolTable -> Expression a -> ExpVal eval symTable expr = case eval' symTable expr of   Left  err -> error (err ++ show (getSpan expr))@@ -78,19 +63,4 @@ --       .TRUE. -- @ evalWithShortcircuit :: SymbolTable -> Expression a -> Either String ExpVal-evalWithShortcircuit symTable expr = case expr of-  ExpUnary _ _ op e ->-    transformEither (unaryOp' op) $ evalWithShortcircuit symTable e-  ExpBinary _ _ op e1 e2 ->-    let e1' = evalWithShortcircuit symTable e1-        e2' = evalWithShortcircuit symTable e2-        t   = transformEither nonLogicalToLogical-    in  case (op, t e1', t e2') of-          (And, Right r    , Right l    ) -> Right . Logical $ r && l-          (And, Right False, _          ) -> Right $ Logical False-          (And, _          , Right False) -> Right $ Logical False-          (Or , Right r    , Right l    ) -> Right . Logical $ r || l-          (Or , Right True , _          ) -> Right $ Logical True-          (Or , _          , Right True ) -> Right $ Logical True-          _ -> binaryTransformEither (binaryOp' op) e1' e2'-  _ -> eval' symTable expr+evalWithShortcircuit = error "TODO unimplemented in fortran-src evaluator"

@@ -0,0 +1,80 @@+{- | TODO -}++module Language.Fortran.Vars.Eval.Deprecated where++import Language.Fortran.Vars.Eval.Deprecated.Operation++import Language.Fortran.Vars.Rep+import Language.Fortran.Vars.Types.SymbolTable++import Language.Fortran.AST+import Language.Fortran.Util.Position ( getSpan )++import qualified Data.Map as Map++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal' or a 'String' describing+-- the issue that prevented the evaluation+eval' :: SymbolTable -> Expression a -> Either String ExpVal+eval' symTable = \case+  ExpValue _ _ (ValVariable name) -> case Map.lookup name symTable of+    Just (SParameter _ expVal) -> Right expVal+    Just _ -> Left $ "Cannot be evaluated: " ++ name ++ " is not a parameter."+    Nothing -> Left $ "Cannot find parameter : " ++ name++  ExpValue _ s val  -> valueToExpVal' s val++  ExpUnary _ _ op e -> transformEither (unaryOp' op) $ eval' symTable e+  ExpBinary _ _ op e1 e2 ->+    binaryTransformEither (binaryOp' op) (eval' symTable e1) (eval' symTable e2)+  ExpFunctionCall _ _ (ExpValue _ _ function) (AList _ _ args) ->+    transformEitherList intrinsicFunctionCall'+      $   eval' symTable+      .   argExtractExpr+      <$> args+   where+    intrinsicFunctionCall' = intrinsicFunctionCall $ functionName function+    functionName (ValVariable  name) = name+    functionName (ValIntrinsic name) = name+    functionName _                   = ""+  e -> Left $ "Unsupported expression at: " ++ show (getSpan e)++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal'+eval :: SymbolTable -> Expression a -> ExpVal+eval symTable expr = case eval' symTable expr of+  Left  err -> error (err ++ show (getSpan expr))+  Right r   -> r++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal' or a 'String' describing+-- the issue that prevented the evaluation. In the case of expressions like+--+-- @+--       foobar .AND. .FALSE.+--       .TRUE. .OR. .foobar+-- @+--+-- the expressions will be shortcircuited to produce+--+-- @+--       .FALSE.+--       .TRUE.+-- @+evalWithShortcircuit :: SymbolTable -> Expression a -> Either String ExpVal+evalWithShortcircuit symTable expr = case expr of+  ExpUnary _ _ op e ->+    transformEither (unaryOp' op) $ evalWithShortcircuit symTable e+  ExpBinary _ _ op e1 e2 ->+    let e1' = evalWithShortcircuit symTable e1+        e2' = evalWithShortcircuit symTable e2+        t   = transformEither nonLogicalToLogical+    in  case (op, t e1', t e2') of+          (And, Right r    , Right l    ) -> Right . Logical $ r && l+          (And, Right False, _          ) -> Right $ Logical False+          (And, _          , Right False) -> Right $ Logical False+          (Or , Right r    , Right l    ) -> Right . Logical $ r || l+          (Or , Right True , _          ) -> Right $ Logical True+          (Or , _          , Right True ) -> Right $ Logical True+          _ -> binaryTransformEither (binaryOp' op) e1' e2'+  _ -> eval' symTable expr

@@ -0,0 +1,258 @@+module Language.Fortran.Vars.Eval.Deprecated.Operation+  ( valueToExpVal'+  , valueToExpVal+  , transformEither+  , transformEitherList+  , binaryTransformEither+  , unaryOp'+  , unaryOp+  , binaryOp'+  , binaryOp+  , intrinsicFunctionCall+  , nonLogicalToLogical+  )+where++import           Prelude                 hiding ( GT+                                                , EQ+                                                , LT+                                                )+import           Data.Char                      ( chr )++import           Language.Fortran.AST           ( BinaryOp(..)+                                                , UnaryOp(..)+                                                , Value(..)+                                                )+import           Language.Fortran.AST.Literal.Real ( readRealLit )+import           Language.Fortran.Util.Position ( SrcSpan )+++import           Language.Fortran.Vars.BozConstant+                                                ( bozToInt8+                                                , bozToInt+                                                )+import           Language.Fortran.Vars.Errors   ( invalidArg' )+import           Language.Fortran.Vars.Types    ( ExpVal(..) )++import           Data.Bits                      ( (.|.)+                                                , complement+                                                )++-- | Given a function that returns an 'Either' and an 'Either' with+-- the 'Right' case as the same type input to the function, return+-- an either by possibly applying the function to the 'Right' value or+-- propagating the 'Left' case+transformEither :: (a -> Either String b) -> Either String a -> Either String b+transformEither = either Left+{-# INLINABLE transformEither #-}++-- | Given a function that takes two arguments of the same type and returns an+-- 'Either' as well as two 'Either's whose 'Right' cases hold the inputs to the+-- function, apply the function if possible. Otherwise propagate the 'Left' cases+binaryTransformEither+  :: (a -> a -> Either String b)+  -> Either String a+  -> Either String a+  -> Either String b+binaryTransformEither _ (Left e)   _          = Left e+binaryTransformEither _ _          (Left  e ) = Left e+binaryTransformEither t (Right v1) (Right v2) = t v1 v2++-- | Given a function that takes a list of arguments of the same type and returns an+-- 'Either' as well as a list of 'Either's whose 'Right' cases hold the inputs to the+-- function, apply the function if possible. Otherwise propagate the 'Left' cases+transformEitherList+  :: ([a] -> Either String b) -> [Either String a] -> Either String b+transformEitherList t el = case eitherListToList el of+  Left  l  -> Left l+  Right rs -> t rs+ where+  eitherListToList :: [Either String a] -> Either String [a]+  eitherListToList []             = Right []+  eitherListToList (Left  l : _ ) = Left l+  eitherListToList (Right r : rs) = case eitherListToList rs of+    Left  l   -> Left l+    Right rs' -> Right (r : rs')++-- | Given a 'SrcSpan' and the 'Value' in that span either+-- return a 'String' describing the issue or the 'ExpVal' held+-- by that 'Value'.+valueToExpVal' :: SrcSpan -> Value a -> Either String ExpVal+valueToExpVal' s val = case val of+  ValInteger i _  -> Right $ Int $ read i+  ValReal    r _  -> Right $ Real $ readRealLit r+  ValLogical l _  -> Right $ Logical l+  ValString    s' -> Right $ Str s'+  ValHollerith h  -> Right $ Str h+  ValBoz       b  -> Right $ Boz b+  _               -> Left ("toExpVal: unsupported value at " ++ show s)++-- | Given a 'SrcSpan' and the 'Value' returnthe 'ExpVal' held+-- by that 'Value' or throw an error.+valueToExpVal :: SrcSpan -> Value a -> ExpVal+valueToExpVal s val = case valueToExpVal' s val of+  Left  err  -> error err+  Right expr -> expr++-- | Given a non-logical 'ExpVal', convert that value to a logical+-- one or return a 'String' describing why this was impossible.+nonLogicalToLogical :: ExpVal -> Either String Bool+nonLogicalToLogical (Int  i) = Right $ i /= 0+nonLogicalToLogical (Real r) = Right $ r /= 0.0+nonLogicalToLogical (Str _) =+  Left "Cannot transform a string value to a logical value"+nonLogicalToLogical (Logical l) = Right l+nonLogicalToLogical (Boz     b) = nonLogicalToLogical $ bozToInt8 b++-- | Given a string representing a function call and a list of ExpVal+-- values holding inputs to the function, evaluate the function call+-- and return the result in a Right, or propagate the Left case if any+-- of the list elements are 'Lefts'.+intrinsicFunctionCall :: String -> [ExpVal] -> Either String ExpVal+intrinsicFunctionCall function es = case function of+  "ior"  -> ior' es+  "max"  -> max' es+  "char" -> char' es+  "not"  -> not' es+  "int"  -> int' es+  "int2" -> int' es+  _      -> invalidArg' ("intrinsicFunctionCall " ++ show function) es++ior' :: [ExpVal] -> Either String ExpVal+ior' [val1, val2] = case (val1, val2) of+  (Int a, Int b) -> Right $ Int $ (.|.) a b+  _              -> invalidArg' "ior" [val1, val2]+ior' vs = invalidArg' "ior" vs++max' :: [ExpVal] -> Either String ExpVal+max' [val1] = case val1 of+  Real a -> Right $ Real a+  Int  a -> Right $ Int a+  _      -> invalidArg' "max" [val1]+max' (v : vs) =+  let maxVs = max' vs+  in  case (v, maxVs) of+        (_      , Left l        ) -> Left l+        (Real r', Right (Int r) ) -> Right $ Real $ max r' (fromIntegral r)+        (Int  r', Right (Real r)) -> Right $ Real $ max (fromIntegral r') r+        (Real r', Right (Real r)) -> Right $ Real $ max r' r+        (Int  r', Right (Int r) ) -> Right $ Int $ max r' r+        _                         -> invalidArg' "max" (v : vs)+max' vs = invalidArg' "max" vs++char' :: [ExpVal] -> Either String ExpVal+char' [Int i] = Right $ Str [chr i]+char' vs      = invalidArg' "char" vs++-- https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc8/index.html+not' :: [ExpVal] -> Either String ExpVal+not' [Int i] = Right $ Int (complement i)+not' vs      = invalidArg' "not" vs++int' :: [ExpVal] -> Either String ExpVal+int' [Int  i] = Right $ Int i+int' [Real r] = Right $ Int (truncate r)+int' v@[(Boz boz), Int k] =+  if k `elem` [2, 4, 8] then Right $ bozToInt k boz else invalidArg' "int" v+int' vs = invalidArg' "int" vs++-- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting+-- 'ExpVal' after applying the operation or a 'String' describing+-- why this couldn't be done+unaryOp' :: UnaryOp -> ExpVal -> Either String ExpVal+unaryOp' op v = case (op, v) of+  (Plus , Int a ) -> Right $ Int a+  (Plus , Real a) -> Right $ Real a+  (Minus, Int a ) -> Right $ Int (negate a)+  (Minus, Real a) -> Right $ Real (negate a)+  (Not, a) -> transformEither (Right . Logical . not) $ nonLogicalToLogical a+  _               -> invalidArg' (show op) [v]++-- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting+-- 'ExpVal' after applying the operation or throw an error+unaryOp :: UnaryOp -> ExpVal -> ExpVal+unaryOp op v = case unaryOp' op v of+  Left  err  -> error err+  Right expr -> expr++-- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting+-- 'ExpVal' after applying the operation or a 'String' describing+-- why this couldn't be done+binaryOp' :: BinaryOp -> ExpVal -> ExpVal -> Either String ExpVal+binaryOp' op val1 val2 = case (op, val1, val2) of+  (Addition, Int a, Int b) -> Right $ Int (a + b)+  (Addition, Real a, Real b) -> Right $ Real (a + b)+  (Addition, Int a, Real b) -> Right $ Real (fromIntegral a + b)+  (Addition, Real a, Int b) -> Right $ Real (a + fromIntegral b)++  (Subtraction, Int a, Int b) -> Right $ Int (a - b)+  (Subtraction, Real a, Real b) -> Right $ Real (a - b)+  (Subtraction, Int a, Real b) -> Right $ Real (fromIntegral a - b)+  (Subtraction, Real a, Int b) -> Right $ Real (a - fromIntegral b)++  (Multiplication, Int a, Int b) -> Right $ Int (a * b)+  (Multiplication, Real a, Real b) -> Right $ Real (a * b)+  (Multiplication, Int a, Real b) -> Right $ Real (fromIntegral a * b)+  (Multiplication, Real a, Int b) -> Right $ Real (a * fromIntegral b)++  (Division, Int a, Int b) -> Right $ Int (div a b)+  (Division, Real a, Real b) -> Right $ Real (a / b)+  (Division, Int a, Real b) -> Right $ Real (fromIntegral a / b)+  (Division, Real a, Int b) -> Right $ Real (a / fromIntegral b)++  (Exponentiation, Int a, Int b) -> Right $ Int (a ^ b)+  (Exponentiation, Real a, Real b) -> Right $ Real (a ** b)+  (Exponentiation, Int a, Real b) -> Right $ Real (fromIntegral a ** b)+  (Exponentiation, Real a, Int b) -> Right $ Real (a ** fromIntegral b)++  (Concatenation, Str a, Str b) -> Right $ Str (a ++ b)++  (LT, Int a, Int b) -> Right $ Logical (a < b)+  (LT, Real a, Real b) -> Right $ Logical (a < b)+  (LT, Int a, Real b) -> Right $ Logical (fromIntegral a < b)+  (LT, Real a, Int b) -> Right $ Logical (a < fromIntegral b)+  (LT, Boz boz, b) -> binaryOp' LT (bozToInt8 boz) b+  (LT, a, Boz boz) -> binaryOp' LT a (bozToInt8 boz)++  (EQ, Int a, Real b) -> Right $ Logical (fromIntegral a == b)+  (EQ, Real a, Int b) -> Right $ Logical (a == fromIntegral b)+  (EQ, Boz boz, b) -> binaryOp' EQ (bozToInt8 boz) b+  (EQ, a, Boz boz) -> binaryOp' EQ a (bozToInt8 boz)+  (EQ, Logical True, Int b) -> Right $ Logical (1 == b)+  (EQ, Logical False, Int b) -> Right $ Logical (0 == b)+  (EQ, Int a, Logical True) -> Right $ Logical (a == 1)+  (EQ, Int a, Logical False) -> Right $ Logical (a == 0)+  (EQ, Logical True, Real b) -> Right $ Logical (1.0 == b)+  (EQ, Logical False, Real b) -> Right $ Logical (0.0 == b)+  (EQ, Real a, Logical True) -> Right $ Logical (a == 1.0)+  (EQ, Real a, Logical False) -> Right $ Logical (a == 0.0)+  (EQ, v1, v2) -> Right $ Logical (v1 == v2)+++  (GT, v1, v2) -> binaryOp' LT v2 v1+  (GTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' LT v2 v1+  (LTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' GT v2 v1++  (NE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' EQ v1 v2++  (And, v1, v2) ->+    binaryTransformEither (\x -> Right . Logical . (x &&))+                          (nonLogicalToLogical v1)+      $ nonLogicalToLogical v2++  (Or, v1, v2) ->+    binaryTransformEither (\x -> Right . Logical . (x ||))+                          (nonLogicalToLogical v1)+      $ nonLogicalToLogical v2++  (XOr, Logical a, Logical b) -> Right $ Logical (a /= b)+  (Equivalent, Logical a, Logical b) -> Right $ Logical (a == b)+  (NotEquivalent, Logical a, Logical b) -> Right $ Logical (a /= b)+  _ -> invalidArg' (show op) [val1, val2]++-- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting+-- 'ExpVal' after applying the operation or throw an error+binaryOp :: BinaryOp -> ExpVal -> ExpVal -> ExpVal+binaryOp op val1 val2 = case binaryOp' op val1 val2 of+  Left  err  -> error err+  Right expr -> expr

@@ -0,0 +1,68 @@+{- | fortran-vars-style expression evaluation which piggybacks off the evaluator+     in fortran-src.+-}++{-# LANGUAGE DerivingVia #-}++module Language.Fortran.Vars.Eval.FortranSrc+  ( module Language.Fortran.Vars.Eval.FortranSrc+  , module Language.Fortran.Vars.Eval.FortranSrc.Translate+  ) where++import Language.Fortran.Vars.Eval.FortranSrc.Translate++import Language.Fortran.Vars.Types.SymbolTable++import qualified Language.Fortran.Repr as FS.Rep+import qualified Language.Fortran.Repr.Eval.Common as FS.Eval+import qualified Language.Fortran.Repr.Eval.Value as FS.Eval++import Control.Monad.Reader+import Control.Monad.Except++import qualified Data.Map as Map++-- | Fortran expression evaluation monad, using 'SymbolTable' and reporting+--   fortran-src evaluator errors.+--+-- We use a newtype wrapper on this at 'Eval'. The type synonym assists some+-- boilerplate.+type Eval' = ExceptT FS.Eval.Error (Reader SymbolTable)++-- | Fortran expression evaluation monad, using 'SymbolTable' and reporting+--   fortran-src evaluator errors.+newtype Eval a = Eval { unEval :: Eval' a }+    deriving (Functor, Applicative, Monad) via Eval'+    deriving (MonadReader SymbolTable) via Eval'+    deriving (MonadError FS.Eval.Error) via Eval'++-- | Execute a program in the Fortran expression evaluation monad 'Eval'.+runEval :: SymbolTable -> Eval a -> Either FS.Eval.Error a+runEval symt = flip runReader symt . runExceptT . unEval++-- | Evaluate Fortran expressions to 'FS.FValue's.+--+-- We look up variables from a plain 'SymbolTable', but evaluate using+-- fortran-src's machinery. We must therefore translate 'SymbolTable' 'ExpVal's+-- to 'FS.FValue'. If we want to return fortran-vars-style types, we must+-- translate the other way after executing a program in this monad.+instance FS.Eval.MonadFEval Eval where+    type EvalTo Eval = FS.Rep.FValue++    lookupFVar name = do+        symt <- ask+        case Map.lookup name symt of+          Nothing -> return Nothing+          Just entry ->+            case entry of+              SParameter _ val ->+                return $ Just $ FS.Rep.MkFScalarValue $ translateExpVal val+              _ -> do+                FS.Eval.warn $+                    "found variable in SymbolTable, but wasn't an SParameter: "+                    <>name+                return Nothing++    -- | Ignore warnings. fortran-vars doesn't have a method to report warnings+    --   during evaluation.+    warn _ = pure ()

@@ -0,0 +1,81 @@+{- | Translate fortran-vars Fortran types and values to fortran-src+     (Language.Fortran.Repr).++TODO++  * BYTE is apparently LOGICAL(1). Or INTEGER(1) (same thing?). Could make a+    special check for that.+-}++module Language.Fortran.Vars.Eval.FortranSrc.Translate where++import qualified Language.Fortran.Vars.Rep as FV+import qualified Language.Fortran.AST.Literal.Boz as AST++import Language.Fortran.Repr+import Language.Fortran.Repr.Type.Array++import GHC.Float ( float2Double )+import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NonEmpty++translateFType :: FType -> FV.SemType+translateFType = \case+  MkFScalarType fsty -> translateFScalarType fsty+  MkFArrayType  fat  -> translateFArrayType  fat++translateFScalarType :: FScalarType -> FV.SemType+translateFScalarType = \case+  FSTInt     ftint  -> kinded FV.TInteger ftint+  FSTReal    ftreal -> kinded FV.TReal    ftreal+  FSTComplex ftreal -> kinded FV.TComplex (FTComplexWrapper ftreal)+  FSTLogical ftint  -> kinded FV.TInteger ftint+  --FSTLogical ftint  -> kinded FV.TLogical ftint+  FSTString  n      -> FV.TCharacter (FV.CharLenInt (fromIntegral n)) 1+  FSTCustom  ty     -> FV.TCustom ty+  where kinded f = f . translateFKind . printFKind++translateFArrayType :: FArrayType -> FV.SemType+translateFArrayType (FArrayType fsty shape) =+    FV.TArray (translateFScalarType fsty) (translateShape shape)++translateFKind :: FKindLit -> FV.Kind+translateFKind = fromIntegral++-- | Note that Fortran defaults to 1-indexed arrays.+translateShape :: Shape -> FV.Dimensions+translateShape =+      FV.DimsExplicitShape+    . NonEmpty.fromList+    . map (\ub -> FV.Dim (Just 1) (Just (fromIntegral ub)))+    . getShape++--------------------------------------------------------------------------------++translateFValue :: FValue -> Either String FV.ExpVal+translateFValue = \case+  MkFScalarValue fsv  -> translateFScalarValue fsv++translateFScalarValue :: FScalarValue -> Either String FV.ExpVal+translateFScalarValue = \case+  FSVInt     fint      -> Right $ FV.Int  $ fIntUOp fromIntegral fint+  FSVReal    freal     -> Right $ FV.Real $ fRealUOp' float2Double id freal+  FSVComplex _fcomplex -> Left "ExpVal doesn't support complex values"+  FSVLogical fint -> Right $ FV.Logical $ fLogicalToBool fint+  FSVString  t -> Right $ FV.Str $ Text.unpack t++--------------------------------------------------------------------------------++translateExpVal :: FV.ExpVal -> FScalarValue+translateExpVal = \case+  FV.Int     i   -> FSVInt     $ FInt4 $ fromIntegral i++  -- TODO getting some precisions errors, fortran-src over-precise? unsure where+  -- coming from, but need to compare using an epsilon+  FV.Real    r   -> FSVReal    $ FReal8 r++  FV.Str     s   -> FSVString  $ Text.pack s+  FV.Logical b   -> FSVLogical $ FInt4 $ fLogicalNumericFromBool b++  -- TODO fortran-vars always converts BOZs at INTEGER(2)+  FV.Boz     boz -> FSVInt     $ FInt2 $ AST.bozAsTwosComp boz

@@ -39,6 +39,8 @@                                                 ) import           Language.Fortran.Vars.Kind     ( getTypeKind ) import           Language.Fortran.Vars.Union    ( union )+import           Language.Fortran.Analysis.SemanticTypes+                                                ( dimensionsToTuples )  -- | Given a 'SymbolTable' and an 'Expression', return the size of -- the variable represented by the expression@@ -55,14 +57,17 @@         _              -> error (symbol ++ " is not a VariableEntry.")  getTypeSize :: Type -> Int-getTypeSize = \case-  TArray ty dims ->-    fromMaybe (error "Can't calculate size of dynamic array")-      $   sizeOfStaticArray-      <$> getTypeKind ty-      <*> dims-  ty -> fromMaybe (error "Can't get size of dynamic variable") $ getTypeKind ty+getTypeSize =+    fromMaybe (error "Can't get size of dynamic variable") . getTypeSize' +getTypeSize' :: Type -> Maybe Int+getTypeSize' = \case+  TArray ty dims -> do+    dims' <- dimensionsToTuples dims+    kind <- getTypeKind ty+    pure $ sizeOfStaticArray kind dims'+  ty -> getTypeKind ty+ -- | Given a static array's 'kind' and 'dimension', calculate its size sizeOfStaticArray :: Int -> [(Int, Int)] -> Int sizeOfStaticArray kind' dimension' =@@ -78,12 +83,10 @@   f :: StorageTable -> Name -> SymbolTableEntry -> StorageTable   f storageTable symbol entry = case entry of     SVariable ty _ ->-      let size = case ty of-            TArray ty' dims -> sizeOfStaticArray <$> getTypeKind ty' <*> dims-            _               -> getTypeKind ty+      let mSize = getTypeSize' ty           block = MemoryBlock-            { blockSize    = size-            , storageClass = case size of+            { blockSize    = mSize+            , storageClass = case mSize of                                Nothing -> Automatic                                _       -> Unspecified             , variables    = [symbol]

@@ -5,6 +5,7 @@   ) where +import qualified Data.Foldable                 as Foldable import           Data.Data                      ( Data ) import           Data.List                      ( foldl' ) import qualified Data.Map                      as M@@ -28,9 +29,10 @@                                                 , Location                                                 , Offset                                                 , SymbolTable+                                                , Dim(..), Dimensions+                                                , dimensionsToTuples                                                 ) - isIxSingle :: Index a -> Bool isIxSingle IxSingle{} = True isIxSingle IxRange{}  = False@@ -56,10 +58,15 @@  -- | Given only single indices return the 'Range' in memory that -- these indices point to.-generateLinearizedIndexRange :: [Int] -> Int -> [(Int, Int)] -> Int -> Range+generateLinearizedIndexRange+    :: (Functor t, Foldable t) => [Int] -> Int -> t (Dim Int) -> Int -> Range generateLinearizedIndexRange intIndices start dims kind =-  let offset = linearizedIndex intIndices dims * kind+  let offset = linearizedIndex intIndices dims' * kind   in  (start + offset, start + offset + kind - 1)+  where+    -- TODO Ideally, we stay in our foldable for as long as possible. Shift this+    -- into 'linearizedIndex' and try.+    dims' = Foldable.toList $ fmap (\(Dim lb ub) -> (lb, ub)) dims  findBlockOffset :: SymbolTable -> Name -> Offset -> Location findBlockOffset symTable symbol offset = case M.lookup symbol symTable of@@ -79,20 +86,25 @@   let Just entry = M.lookup symbol symTable   in     case entry of-      SVariable (TArray ty (Just dims)) _ ->-        let-          ixSingles    = takeWhile isIxSingle indices-          Just kind    = getTypeKind ty-          arrayIndices = either (const Nothing) Just-            $ traverse toIndices ixSingles-           where-            toIndices (IxSingle _ _ _ expr) = toInt <$> eval' symTable expr-            toIndices _ = error "toIndices: unexpected input"-        in-          (\x -> linearizedIndex x dims * kind) <$> arrayIndices+      SVariable (TArray ty dims) _ ->+        case dimensionsToTuples dims of+          Nothing -> error "expected a static array, got dynamic"+          Just dims' ->+            let+              ixSingles    = takeWhile isIxSingle indices+              Just kind    = getTypeKind ty+              arrayIndices = either (const Nothing) Just+                $ traverse toIndices ixSingles+               where+                toIndices (IxSingle _ _ _ expr) = toInt <$> eval' symTable expr+                toIndices _ = error "toIndices: unexpected input"+            in+              (\x -> linearizedIndex x dims' * kind) <$> arrayIndices       _ -> error "Only array-typed VariableEntries are expected at this point"+ -- substring c(:5) calculateOffset _ _ (IxRange _ _ Nothing _ _ : _) = Just 0+ -- substring c(5:) calculateOffset symTable _ (IxRange _ _ (Just lowerIndex) _ _ : _) =   let val = eval' symTable lowerIndex

@@ -1,258 +0,0 @@-module Language.Fortran.Vars.Operation-  ( valueToExpVal'-  , valueToExpVal-  , transformEither-  , transformEitherList-  , binaryTransformEither-  , unaryOp'-  , unaryOp-  , binaryOp'-  , binaryOp-  , intrinsicFunctionCall-  , nonLogicalToLogical-  )-where--import           Prelude                 hiding ( GT-                                                , EQ-                                                , LT-                                                )-import           Data.Char                      ( chr )--import           Language.Fortran.AST           ( BinaryOp(..)-                                                , UnaryOp(..)-                                                , Value(..)-                                                )-import           Language.Fortran.AST.Literal.Real ( readRealLit )-import           Language.Fortran.Util.Position ( SrcSpan )---import           Language.Fortran.Vars.BozConstant-                                                ( bozToInt8-                                                , bozToInt-                                                )-import           Language.Fortran.Vars.Errors   ( invalidArg' )-import           Language.Fortran.Vars.Types    ( ExpVal(..) )--import           Data.Bits                      ( (.|.)-                                                , complement-                                                )---- | Given a function that returns an 'Either' and an 'Either' with--- the 'Right' case as the same type input to the function, return--- an either by possibly applying the function to the 'Right' value or--- propagating the 'Left' case-transformEither :: (a -> Either String b) -> Either String a -> Either String b-transformEither = either Left-{-# INLINABLE transformEither #-}---- | Given a function that takes two arguments of the same type and returns an--- 'Either' as well as two 'Either's whose 'Right' cases hold the inputs to the--- function, apply the function if possible. Otherwise propagate the 'Left' cases-binaryTransformEither-  :: (a -> a -> Either String b)-  -> Either String a-  -> Either String a-  -> Either String b-binaryTransformEither _ (Left e)   _          = Left e-binaryTransformEither _ _          (Left  e ) = Left e-binaryTransformEither t (Right v1) (Right v2) = t v1 v2---- | Given a function that takes a list of arguments of the same type and returns an--- 'Either' as well as a list of 'Either's whose 'Right' cases hold the inputs to the--- function, apply the function if possible. Otherwise propagate the 'Left' cases-transformEitherList-  :: ([a] -> Either String b) -> [Either String a] -> Either String b-transformEitherList t el = case eitherListToList el of-  Left  l  -> Left l-  Right rs -> t rs- where-  eitherListToList :: [Either String a] -> Either String [a]-  eitherListToList []             = Right []-  eitherListToList (Left  l : _ ) = Left l-  eitherListToList (Right r : rs) = case eitherListToList rs of-    Left  l   -> Left l-    Right rs' -> Right (r : rs')---- | Given a 'SrcSpan' and the 'Value' in that span either--- return a 'String' describing the issue or the 'ExpVal' held--- by that 'Value'.-valueToExpVal' :: SrcSpan -> Value a -> Either String ExpVal-valueToExpVal' s val = case val of-  ValInteger i _  -> Right $ Int $ read i-  ValReal    r _  -> Right $ Real $ readRealLit r-  ValLogical l _  -> Right $ Logical l-  ValString    s' -> Right $ Str s'-  ValHollerith h  -> Right $ Str h-  ValBoz       b  -> Right $ Boz b-  _               -> Left ("toExpVal: unsupported value at " ++ show s)---- | Given a 'SrcSpan' and the 'Value' returnthe 'ExpVal' held--- by that 'Value' or throw an error.-valueToExpVal :: SrcSpan -> Value a -> ExpVal-valueToExpVal s val = case valueToExpVal' s val of-  Left  err  -> error err-  Right expr -> expr---- | Given a non-logical 'ExpVal', convert that value to a logical--- one or return a 'String' describing why this was impossible.-nonLogicalToLogical :: ExpVal -> Either String Bool-nonLogicalToLogical (Int  i) = Right $ i /= 0-nonLogicalToLogical (Real r) = Right $ r /= 0.0-nonLogicalToLogical (Str _) =-  Left "Cannot transform a string value to a logical value"-nonLogicalToLogical (Logical l) = Right l-nonLogicalToLogical (Boz     b) = nonLogicalToLogical $ bozToInt8 b---- | Given a string representing a function call and a list of ExpVal--- values holding inputs to the function, evaluate the function call--- and return the result in a Right, or propagate the Left case if any--- of the list elements are 'Lefts'.-intrinsicFunctionCall :: String -> [ExpVal] -> Either String ExpVal-intrinsicFunctionCall function es = case function of-  "ior"  -> ior' es-  "max"  -> max' es-  "char" -> char' es-  "not"  -> not' es-  "int"  -> int' es-  "int2" -> int' es-  _      -> invalidArg' ("intrinsicFunctionCall " ++ show function) es--ior' :: [ExpVal] -> Either String ExpVal-ior' [val1, val2] = case (val1, val2) of-  (Int a, Int b) -> Right $ Int $ (.|.) a b-  _              -> invalidArg' "ior" [val1, val2]-ior' vs = invalidArg' "ior" vs--max' :: [ExpVal] -> Either String ExpVal-max' [val1] = case val1 of-  Real a -> Right $ Real a-  Int  a -> Right $ Int a-  _      -> invalidArg' "max" [val1]-max' (v : vs) =-  let maxVs = max' vs-  in  case (v, maxVs) of-        (_      , Left l        ) -> Left l-        (Real r', Right (Int r) ) -> Right $ Real $ max r' (fromIntegral r)-        (Int  r', Right (Real r)) -> Right $ Real $ max (fromIntegral r') r-        (Real r', Right (Real r)) -> Right $ Real $ max r' r-        (Int  r', Right (Int r) ) -> Right $ Int $ max r' r-        _                         -> invalidArg' "max" (v : vs)-max' vs = invalidArg' "max" vs--char' :: [ExpVal] -> Either String ExpVal-char' [Int i] = Right $ Str [chr i]-char' vs      = invalidArg' "char" vs---- https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc8/index.html-not' :: [ExpVal] -> Either String ExpVal-not' [Int i] = Right $ Int (complement i)-not' vs      = invalidArg' "not" vs--int' :: [ExpVal] -> Either String ExpVal-int' [Int  i] = Right $ Int i-int' [Real r] = Right $ Int (truncate r)-int' v@[(Boz boz), Int k] =-  if k `elem` [2, 4, 8] then Right $ bozToInt k boz else invalidArg' "int" v-int' vs = invalidArg' "int" vs---- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting--- 'ExpVal' after applying the operation or a 'String' describing--- why this couldn't be done-unaryOp' :: UnaryOp -> ExpVal -> Either String ExpVal-unaryOp' op v = case (op, v) of-  (Plus , Int a ) -> Right $ Int a-  (Plus , Real a) -> Right $ Real a-  (Minus, Int a ) -> Right $ Int (negate a)-  (Minus, Real a) -> Right $ Real (negate a)-  (Not, a) -> transformEither (Right . Logical . not) $ nonLogicalToLogical a-  _               -> invalidArg' (show op) [v]---- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting--- 'ExpVal' after applying the operation or throw an error-unaryOp :: UnaryOp -> ExpVal -> ExpVal-unaryOp op v = case unaryOp' op v of-  Left  err  -> error err-  Right expr -> expr---- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting--- 'ExpVal' after applying the operation or a 'String' describing--- why this couldn't be done-binaryOp' :: BinaryOp -> ExpVal -> ExpVal -> Either String ExpVal-binaryOp' op val1 val2 = case (op, val1, val2) of-  (Addition, Int a, Int b) -> Right $ Int (a + b)-  (Addition, Real a, Real b) -> Right $ Real (a + b)-  (Addition, Int a, Real b) -> Right $ Real (fromIntegral a + b)-  (Addition, Real a, Int b) -> Right $ Real (a + fromIntegral b)--  (Subtraction, Int a, Int b) -> Right $ Int (a - b)-  (Subtraction, Real a, Real b) -> Right $ Real (a - b)-  (Subtraction, Int a, Real b) -> Right $ Real (fromIntegral a - b)-  (Subtraction, Real a, Int b) -> Right $ Real (a - fromIntegral b)--  (Multiplication, Int a, Int b) -> Right $ Int (a * b)-  (Multiplication, Real a, Real b) -> Right $ Real (a * b)-  (Multiplication, Int a, Real b) -> Right $ Real (fromIntegral a * b)-  (Multiplication, Real a, Int b) -> Right $ Real (a * fromIntegral b)--  (Division, Int a, Int b) -> Right $ Int (div a b)-  (Division, Real a, Real b) -> Right $ Real (a / b)-  (Division, Int a, Real b) -> Right $ Real (fromIntegral a / b)-  (Division, Real a, Int b) -> Right $ Real (a / fromIntegral b)--  (Exponentiation, Int a, Int b) -> Right $ Int (a ^ b)-  (Exponentiation, Real a, Real b) -> Right $ Real (a ** b)-  (Exponentiation, Int a, Real b) -> Right $ Real (fromIntegral a ** b)-  (Exponentiation, Real a, Int b) -> Right $ Real (a ** fromIntegral b)--  (Concatenation, Str a, Str b) -> Right $ Str (a ++ b)--  (LT, Int a, Int b) -> Right $ Logical (a < b)-  (LT, Real a, Real b) -> Right $ Logical (a < b)-  (LT, Int a, Real b) -> Right $ Logical (fromIntegral a < b)-  (LT, Real a, Int b) -> Right $ Logical (a < fromIntegral b)-  (LT, Boz boz, b) -> binaryOp' LT (bozToInt8 boz) b-  (LT, a, Boz boz) -> binaryOp' LT a (bozToInt8 boz)--  (EQ, Int a, Real b) -> Right $ Logical (fromIntegral a == b)-  (EQ, Real a, Int b) -> Right $ Logical (a == fromIntegral b)-  (EQ, Boz boz, b) -> binaryOp' EQ (bozToInt8 boz) b-  (EQ, a, Boz boz) -> binaryOp' EQ a (bozToInt8 boz)-  (EQ, Logical True, Int b) -> Right $ Logical (1 == b)-  (EQ, Logical False, Int b) -> Right $ Logical (0 == b)-  (EQ, Int a, Logical True) -> Right $ Logical (a == 1)-  (EQ, Int a, Logical False) -> Right $ Logical (a == 0)-  (EQ, Logical True, Real b) -> Right $ Logical (1.0 == b)-  (EQ, Logical False, Real b) -> Right $ Logical (0.0 == b)-  (EQ, Real a, Logical True) -> Right $ Logical (a == 1.0)-  (EQ, Real a, Logical False) -> Right $ Logical (a == 0.0)-  (EQ, v1, v2) -> Right $ Logical (v1 == v2)---  (GT, v1, v2) -> binaryOp' LT v2 v1-  (GTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' LT v2 v1-  (LTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' GT v2 v1--  (NE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' EQ v1 v2--  (And, v1, v2) ->-    binaryTransformEither (\x -> Right . Logical . (x &&))-                          (nonLogicalToLogical v1)-      $ nonLogicalToLogical v2--  (Or, v1, v2) ->-    binaryTransformEither (\x -> Right . Logical . (x ||))-                          (nonLogicalToLogical v1)-      $ nonLogicalToLogical v2--  (XOr, Logical a, Logical b) -> Right $ Logical (a /= b)-  (Equivalent, Logical a, Logical b) -> Right $ Logical (a == b)-  (NotEquivalent, Logical a, Logical b) -> Right $ Logical (a /= b)-  _ -> invalidArg' (show op) [val1, val2]---- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting--- 'ExpVal' after applying the operation or throw an error-binaryOp :: BinaryOp -> ExpVal -> ExpVal -> ExpVal-binaryOp op val1 val2 = case binaryOp' op val1 val2 of-  Left  err  -> error err-  Right expr -> expr

@@ -1,14 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Language.Fortran.Vars.Orphans where  import Language.Fortran.AST import qualified Language.Fortran.AST.Literal.Boz as Boz import Language.Fortran.Util.Position import Language.Fortran.Analysis.SemanticTypes+import Language.Fortran.Extras.JSON.Analysis() -import Data.Aeson ( ToJSON, FromJSON )+import Data.Aeson ( ToJSON, FromJSON, ToJSONKey, FromJSONKey )  -- TODO temporary solution instance   ToJSON SemType+instance FromJSON (Dim (Maybe Int))+instance FromJSON Dimensions instance FromJSON SemType instance   ToJSON CharacterLen instance FromJSON CharacterLen@@ -19,3 +24,9 @@ instance FromJSON Boz.Boz instance FromJSON Boz.BozPrefix instance FromJSON Boz.Conforming++-- TODO move these to common+instance ToJSON ProgramUnitName+instance ToJSONKey ProgramUnitName+instance FromJSON ProgramUnitName+instance FromJSONKey ProgramUnitName

@@ -0,0 +1,45 @@+-- | Definitions for representing Fortran values and types.++module Language.Fortran.Vars.Rep+  (+  -- * Types+    F.SemType(..)+  , F.Kind+  , F.CharacterLen(..)+  , F.Dimensions, F.Dim(..), F.Dims(..)++  -- ** Compatibility+  , F.dimensionsToTuples+  , Type++  -- * Values+  , ExpVal(..)+  ) where++import qualified Language.Fortran.Analysis.SemanticTypes as F+import qualified Language.Fortran.AST.Literal.Boz as F+import Language.Fortran.Extras.JSON.Literals()++import Language.Fortran.Vars.Orphans()++import Data.Aeson ( ToJSON, FromJSON )+import Control.DeepSeq ( NFData )+import GHC.Generics ( Generic )+import Data.Data ( Data )++-- TODO raehik 2023-05-15: consider deprecating. GHC is very gradually changing+-- the kind of concrete types from @*@ to @Type@. Language extension+-- @NoStarIsType@ makes that change, and will eventually become default. @type+-- Type@ will probably break with that on (due to the way kind/type/term+-- namespaces are searched).+type Type = F.SemType++-- | The evaluated value of a FORTRAN expression.+data ExpVal+  = Int     Int+  | Real    Double+  | Str     String+  | Logical Bool+  | Boz     F.Boz+    deriving stock (Eq, Ord, Show, Data, Generic)+    deriving anyclass (NFData, ToJSON, FromJSON)

@@ -10,7 +10,7 @@                                                 ) import           Data.List                      ( foldl' ) import qualified Data.Map                      as M-import           Data.Maybe                     ( mapMaybe )+import           Data.Maybe                     ( mapMaybe, fromMaybe )  import           Language.Fortran.Analysis      ( Analysis                                                 , srcName@@ -32,17 +32,21 @@                                                 , Value(..)                                                 ) +import           Language.Fortran.Vars.SymbolTable.Arrays ( resolveDims ) import           Language.Fortran.Vars.Eval     ( eval                                                 , eval'                                                 ) import           Language.Fortran.Vars.BozConstant-                                                ( resolveBozConstant )+                                                ( resolveBozConstant+                                                , bozToInt+                                                ) import           Language.Fortran.Vars.Types    ( ExpVal(..)                                                 , SymbolTableEntry(..)                                                 , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 , SymbolTable+                                                , Dim(..), Dims(..), Dimensions                                                 ) import           Language.Fortran.Vars.Utils    ( typeSpecToScalarType                                                 , typeSpecToArrayType@@ -56,6 +60,8 @@                                                 , isStr                                                 ) +{- TODO 2023-05-02 raehik: no longer used?+ -- | Given a 'SymbolTable' and a 'DimensionDeclarator', return a pair of -- resolved 'DynamicDimensionElement's representing lower- and upper- bound resolveDimensionDimensionDeclarator@@ -76,6 +82,8 @@     _             -> Nothing   valueOf Nothing = Just 1 +-}+ -- Parameter declarations -- A parameter may or may not have a type declaration. If it does have one, -- the declaration statement can go before or after the parameter statement.@@ -83,6 +91,28 @@   :: Data a => SymbolTable -> AList Declarator (Analysis a) -> SymbolTable handleParameter symTable alist = foldl' f symTable (aStrip alist)  where+  -- special case: immediate BOZ constant+  -- The fortran-src evaluator doesn't look at binder when evaluating, so can't+  -- see the kind. The deprecated fortran-vars evaluator did. So tests of this+  -- form used to work, but now fail:+  --+  --    INTEGER*2 i2+  --    PARAMETER(i2 = '8000'x)+  --+  -- This special case catches only these (and only for INTEGERs).+  --+  -- raehik thinks the proper way to do this is the @INT(boz, kind)@ intrinsic.+  f symt (Declarator _ _ varExp ScalarDecl _ (Just (ExpValue _ _ (ValBoz boz)))) =+      let symbol = srcName varExp+       in case M.lookup symbol symt of+            Nothing -> symt+            Just (SVariable ty _) -> case ty of+              TInteger kind ->+                let val = bozToInt kind boz+                 in M.insert symbol (SParameter ty val) symt+              _ -> symt -- unhandled BOZ coercion+            Just _ -> symt -- unhandled BOZ usage+   f symt (Declarator _ _ varExp ScalarDecl _ (Just valExp)) =     let symbol = srcName varExp         val'   = case eval symt valExp of@@ -188,15 +218,15 @@       symbol = srcName varExp       entry  = case charLength of         Just (ExpValue _ _ ValStar) ->-          SVariable (TArray (TCharacter CharLenStar 1) Nothing) (symbol, 0)+          let ty = TArray (TCharacter CharLenStar 1) (DimsAssumedSize Nothing (Just 1))+          in  SVariable ty (symbol, 0)         _ ->-          let-            kd   = getKind symt typespec charLength-            dims = traverse (resolveDimensionDimensionDeclarator symt)-                            (aStrip dimDecls)-            ty = setTypeKind (baseToType bt) kd-          in-            SVariable (TArray ty dims) (symbol, 0)+          case resolveDims symt (aStrip dimDecls) of+            Nothing -> error "unsupported dimension declarators: probably skip instead of erroring"+            Just dims ->+              let kd = getKind symt typespec charLength+                  ty = setTypeKind (baseToType bt) kd+              in  SVariable (TArray ty dims) (symbol, 0)     in       M.insert symbol entry symt @@ -218,20 +248,22 @@   -> [DimensionDeclarator (Analysis a)]   -> SymbolTable handleArrayDecl symTable varExp dimDecls =-  let symbol = srcName varExp-      dims   = traverse (resolveDimensionDimensionDeclarator symTable) dimDecls-  in  case M.lookup symbol symTable of-        Just (SVariable TArray{} _) ->-          error "invalid declarator: duplicate array declarations"-        Just (SVariable ty loc) ->-          let ste = SVariable (TArray ty dims) loc-          in  M.insert symbol ste symTable-        Just var -> error $ "Invalid declarator: " <> show var-        Nothing -> -- add array info, use a placeholder for scalar type-          let ste =-                  SVariable (TArray placeholderIntrinsicType dims) (symbol, 0)-          in  M.insert symbol ste symTable-  where placeholderIntrinsicType = TInteger 4+  case resolveDims symTable dimDecls of+    Nothing -> error "unsupported dimension declarators: probably skip instead of erroring"+    Just dims ->+      let symbol = srcName varExp+      in  case M.lookup symbol symTable of+            Just (SVariable TArray{} _) ->+              error "invalid declarator: duplicate array declarations"+            Just (SVariable ty loc) ->+              let ste = SVariable (TArray ty dims) loc+              in  M.insert symbol ste symTable+            Just var -> error $ "Invalid declarator: " <> show var+            Nothing -> -- add array info, use a placeholder for scalar type+              let ste =+                      SVariable (TArray placeholderIntrinsicType dims) (symbol, 0)+              in  M.insert symbol ste symTable+      where placeholderIntrinsicType = TInteger 4  -- | Given a 'SymbolTable' and a 'Statement' found in a 'ProgramUnit', return a new 'SymbolTable' -- with any newly defined symbols@@ -258,7 +290,8 @@     Declarator _ _ v (ArrayDecl d) _ _ -> Just (v, aStrip d)     Declarator _ _ _ ScalarDecl    _ _ -> Nothing --- | Try to upgrade an existing scalar variable to an array variable.+-- | Upgrade an existing scalar variable to an array variable with the given+--   dimension information and return the updated 'SymbolTable'. -- -- Returns the unchanged 'SymbolTable' if the variable didn't exist. If the -- variable was already an array type, runtime error.@@ -282,10 +315,11 @@         <> " is array-typed variable."         <> " Invalid fortran syntax (Duplicate DIMENSION attribute)"     Just (SVariable ty loc) ->-      let mdims = traverse (resolveDimensionDimensionDeclarator symTable)-                           (aStrip dimDecls)-          entry = SVariable (TArray ty mdims) loc-      in  M.insert symbol entry symTable+      case resolveDims symTable (aStrip dimDecls) of+        Nothing -> error "TODO invalid DIMENSION attribute while upgrading a scalar to array"+        Just dims ->+          let entry = SVariable (TArray ty dims) loc+          in  M.insert symbol entry symTable     _ -> symTable  -- | Given a 'Bool', 'SymbolTable' and a 'ProgramUnit', return an updated

@@ -0,0 +1,133 @@+module Language.Fortran.Vars.SymbolTable.Arrays where++import Language.Fortran.AST++import Language.Fortran.Vars.Eval ( eval' )+import Language.Fortran.Vars.Types ( ExpVal(..), SymbolTable, Dim(..), Dims(..), Dimensions )++import Control.Monad.Except+--import Data.List.NonEmpty ( NonEmpty( (:|) ) )++resolveDims+    :: SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions+resolveDims symt dds+  -- We assume array type from a quick look at the dimension declarators.+  | any dimDeclLooksLikeAssumedSize  dds =+      case resolveDimsAssumedSize symt dds of+        Left _err -> Nothing -- discard errors/warnings :(+        Right (Nothing, x) -> Just $ DimsAssumedSize Nothing x+        -- resolveDimsAssumedSize can't return an empty list. Clumsy code means+        -- we don't prove this in types.+        Right (Just (a:as), x) -> Just $ DimsAssumedSize (Just (a :| as)) x+        Right (Just [], _x) -> error "impossible"+  | any dimDeclLooksLikeAssumedShape dds =+      case resolveDimsAssumedShape symt dds of+        Left _err -> Nothing -- discard errors/warnings :(+        Right [] -> error "empty DimensionDeclarator list (should not be parseable)"+        Right (a:as) -> Just $ DimsAssumedShape $ a :| as+  | otherwise =+      case resolveDimsExplicitShape symt dds of+        Left _err -> Nothing -- discard errors/warnings :(+        Right [] -> error "empty DimensionDeclarator list (should not be parseable)"+        Right (a:as) -> Just $ DimsExplicitShape $ a :| as++-- | Assumed-size arrays have the special 'ValStar' upper bound (whereas+--   explicit-shape and assumed-shape arrays never do).+dimDeclLooksLikeAssumedSize :: DimensionDeclarator a -> Bool+dimDeclLooksLikeAssumedSize = \case+  DimensionDeclarator _ _ _ (Just (ExpValue _ _ ValStar)) -> True+  _ -> False++-- | Assumed-shape arrays have no upper bounds (whereas explicit-shape and+--   assumed-size arrays always do).+dimDeclLooksLikeAssumedShape :: DimensionDeclarator a -> Bool+dimDeclLooksLikeAssumedShape = \case+  DimensionDeclarator _ _ _ Nothing -> True+  _ -> False++evalStaticDimBoundExpr :: SymbolTable -> Expression a -> Either String Int+evalStaticDimBoundExpr symt expr =+    case eval' symt expr of+      Right (Int val) -> pure val+      Right{} -> throwError $ "wrong type for array dimension bound"+      Left err -> throwError $ "error evaluating array dimension bound expression: "<>err++-- | Returns @'Right' 'Nothing'@ for dynamic bounds (e.g. which use dummy vars).+evalDynamicDimBoundExpr :: SymbolTable -> Expression a -> Either String (Maybe Int)+evalDynamicDimBoundExpr symt expr =+    case eval' symt expr of+      Right (Int val) -> pure $ Just val+      Right{} -> throwError $ "wrong type for array dimension bound"+      Left{} -> pure Nothing++resolveDimsExplicitShape+    :: SymbolTable -> [DimensionDeclarator a] -> Either String [Dim (Maybe Int)]+resolveDimsExplicitShape symt = traverse (resolveDimExplicitShape symt)++resolveDimExplicitShape+    :: SymbolTable -> DimensionDeclarator a -> Either String (Dim (Maybe Int))+resolveDimExplicitShape symt (DimensionDeclarator _ _ mlb mub) =+    case mub of+      Nothing -> throwError "explicit-shape array must have an upper bound for every dimension"+      Just ubExpr -> do+        lb <- case mlb of+                Nothing -> pure $ Just 1+                Just lbExpr -> evalDynamicDimBoundExpr symt lbExpr+        ub <- evalDynamicDimBoundExpr symt ubExpr+        pure $ Dim lb ub++resolveDimsAssumedShape+    :: SymbolTable -> [DimensionDeclarator a] -> Either String [Maybe Int]+resolveDimsAssumedShape symt = traverse go+  where+    go (DimensionDeclarator _ _ mlb mub) =+        case mub of+          Just{} ->+            throwError "assumed-shape array can't have a dimension with an upper bound"+          Nothing ->+            case mlb of+              Nothing -> pure $ Just 1+              Just lbExpr -> evalDynamicDimBoundExpr symt lbExpr++resolveDimsAssumedSize+    :: SymbolTable -> [DimensionDeclarator a]+    -> Either String (Maybe [Dim (Maybe Int)], Maybe Int)+resolveDimsAssumedSize symt = \case+  []   -> throwError "resolveDimsAssumedSize: array can't have zero dimensions"+  d:[] ->+    case resolveDimStar symt d of+      Left err -> Left err+      Right a -> Right (Nothing, a)+  ds   ->+    case go [] ds of+      Left err -> Left err+      Right (l, r) -> Right (Just l, r)+  where+    go+        :: [Dim (Maybe Int)] -> [DimensionDeclarator a]+        -> Either String ([Dim (Maybe Int)], Maybe Int)+    go ds = \case+      []     -> Right (reverse ds, Nothing)+      dd:[]  ->+        case resolveDimStar symt dd of+          Left  err -> Left err+          Right d   -> Right (ds, d)+      dd:dds ->+        case resolveDimExplicitShape symt dd of+          Left  err -> Left err+          Right d   -> go (d:ds) dds++resolveDimStar+    :: SymbolTable -> DimensionDeclarator a -> Either String (Maybe Int)+resolveDimStar symt (DimensionDeclarator _ _ mlb mub) = do+    lb <- case mlb of+            Nothing -> pure $ Just 1+            Just lbExpr -> evalDynamicDimBoundExpr symt lbExpr+    () <- resolveDimBoundStar mub+    pure lb++resolveDimBoundStar :: Maybe (Expression a) -> Either String ()+resolveDimBoundStar = \case+  Just (ExpValue _ _ ValStar) -> pure ()+  Just{}  -> throwError "resolveDimBoundStar: expression wasn't a ValStar"+  Nothing -> throwError "resolveDimBoundStar: upper bound must be present"

@@ -12,6 +12,7 @@                                                 , EQ                                                 , LT                                                 )+import           Data.List.NonEmpty             ( NonEmpty( (:|) ) ) import qualified Data.Map                      as M import           Data.Data                      ( toConstr ) import           Data.Maybe                     ( fromJust )@@ -19,7 +20,6 @@                                                 , Value(..)                                                 , AList(..)                                                 , aStrip-                                                , aStrip'                                                 , Argument(..)                                                 , argExprNormalize                                                 , DoSpecification(..)@@ -58,6 +58,8 @@                                                 , TypeError(..)                                                 , TypeOf                                                 , typeError+                                                , Dim(..)+                                                , Dims(..)                                                 ) import           Language.Fortran.Vars.Kind     ( getTypeKind                                                 , setTypeKind@@ -103,9 +105,11 @@     dim <- specToDim symTable doSpec     ty  <- typeOf strTable symTable . head $ aStrip es     pure $ case ty of-      TArray ty' (Just [(1, dim')]) -> TArray ty' (Just [(1, dim * dim')])+      TArray ty' (DimsExplicitShape (Dim (Just 1) (Just dim') :| [])) ->+        TArray ty' $ DimsExplicitShape $ Dim (Just 1) (Just (dim * dim')) :| []       TArray _ _ -> error "Unexpected array type in implied do"-      _ -> TArray ty (Just [(1, dim)])+      _ ->+        TArray ty  $ DimsExplicitShape $ Dim (Just 1) (Just dim) :| []    ExpDataRef _ _ es (ExpValue _ _ (ValVariable name)) -> do     ty <- typeOf strTable symTable es

@@ -1,69 +1,40 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Fortran.Vars.Types-  ( module Language.Fortran.Vars.Types+  ( module Language.Fortran.Vars.Types.SymbolTable+  , module Language.Fortran.Vars.Types+  , Type   , SemType(..)+  , Dim(..), Dims(..), Dimensions, dimensionsToTuples+  , dimsTraverse, dimsLength   , CharacterLen(..)   , Kind+  , ExpVal(..)   ) where -import           Language.Fortran.Extras.Encoding-import           Language.Fortran.Vars.Orphans-                                                ( )+import Language.Fortran.Vars.Types.SymbolTable++import           Language.Fortran.Common.Array ( dimsTraverse, dimsLength )+import           Language.Fortran.Vars.Orphans()+import           Language.Fortran.Vars.Rep import           Data.Aeson                     ( FromJSON                                                 , ToJSON-                                                , ToJSONKey-                                                , FromJSONKey                                                 ) import           Data.Data                      ( Data ) import           Data.Map                       ( Map ) import           Data.Typeable                  ( Typeable ) import           GHC.Generics                   ( Generic )-import           Control.DeepSeq                ( NFData ) import           Language.Fortran.AST           ( Name                                                 , ProgramUnitName                                                 , Expression                                                 )-import qualified Language.Fortran.AST.Literal.Boz      as AST import           Language.Fortran.Util.Position ( SrcSpan(..)                                                 , Position(..)                                                 )-import           Language.Fortran.Analysis.SemanticTypes-                                                ( SemType(..)-                                                , CharacterLen(..)-                                                , Kind-                                                ) -type Type = SemType---- | The evaluated value of a FORTRAN expression-data ExpVal-  = Int     Int-  | Real    Double-  | Str     String-  | Logical Bool-  | Boz     AST.Boz-  deriving (Eq, Ord, Show, Data, Typeable, Generic, NFData)---- instance FromJSON AST.Conforming--- instance ToJSON AST.Conforming-instance FromJSON ExpVal-instance ToJSON ExpVal---- | Memory offset given to a variable in memory-type Offset = Int---- | The name of block of memory-type MemoryBlockName = Name---- | The location of a variable, i.e. the 'MemoryBlockName' that--- contains it as well as the 'Offset' to its location in memory-type Location = (MemoryBlockName, Offset)- -- | The declared lifetimes of the variables in memory data StorageClass   = Static@@ -76,24 +47,6 @@ instance FromJSON StorageClass instance ToJSON StorageClass --- | The declared dimensions of a staticically typed array variable--- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]-type Dimensions = [(Int, Int)]---- | An entry in the 'SymbolTable' for some variable-data SymbolTableEntry-  = SParameter { parType :: Type , parVal :: ExpVal }-  | SVariable { varType :: Type , varLoc :: Location }-  | SDummy { dumType :: Type }-  | SExternal {extType :: Type }-  deriving (Eq, Ord, Show, Data, Typeable, Generic)--instance FromJSON SymbolTableEntry-instance ToJSON SymbolTableEntry---- | Symbol table containing all non-intrisic symbols declared in a program-type SymbolTable = Map Name SymbolTableEntry- -- | Structure to hold information about the named blocks of memory -- in the program data MemoryBlock = MemoryBlock@@ -132,12 +85,6 @@ -- | Mapping from name of a program unit to relevant structure table type ProgramStructureTables = Map ProgramUnitName StructureTable --- move these to common-instance ToJSON ProgramUnitName-instance ToJSONKey ProgramUnitName-instance FromJSON ProgramUnitName-instance FromJSONKey ProgramUnitName- data TypeError   = TypeError FilePath SrcSpan String   | UnknownType SrcSpan@@ -145,11 +92,23 @@   | UnknownField String   deriving (Eq, Ord, Show, Generic) --- | Helper method for getting the FilePath out of SrcSpan-typeError :: SrcSpan -> String -> TypeError-typeError sp = let SrcSpan p _ = sp in TypeError (posFilePath p) sp- instance ToJSON TypeError instance FromJSON TypeError +-- | Construct a 'TypeError' using a 'SrcSpan', using the 'FilePath'.+typeError :: SrcSpan -> String -> TypeError+typeError sp = let SrcSpan p _ = sp in TypeError (posFilePath p) sp+ type TypeOf a = Expression a -> Either TypeError Type++dimensionsToTuples' :: Dimensions -> [(Int, Int)]+dimensionsToTuples' dims =+    case dimensionsToTuples dims of+      Nothing    -> []+      Just dims' -> dims'++-- | Attempt to turn a list of evaluated array bounds which may include unknown+--   bounds, into a list of known bounds. Any unknown bounds will result in a+--   'Nothing'.+getStaticArrayBounds :: Traversable t => Dims t (Maybe a) -> Maybe (Dims t a)+getStaticArrayBounds = dimsTraverse

@@ -0,0 +1,37 @@+-- | Only the 'SymbolTable' definitions.++module Language.Fortran.Vars.Types.SymbolTable where++import Language.Fortran.Vars.Rep ( Type, ExpVal )++import Language.Fortran.AST ( Name )++import Data.Map ( Map )++import GHC.Generics ( Generic )+import Data.Aeson ( FromJSON, ToJSON )+import Data.Data ( Data )++-- | Symbol table containing all non-intrisic symbols declared in a program+type SymbolTable = Map Name SymbolTableEntry++-- | An entry in the 'SymbolTable' for some variable+data SymbolTableEntry+  = SParameter { parType :: Type , parVal :: ExpVal }+  | SVariable { varType :: Type , varLoc :: Location }+  | SDummy { dumType :: Type }+  | SExternal {extType :: Type }+  deriving (Eq, Ord, Show, Data, Generic)++instance FromJSON SymbolTableEntry+instance ToJSON SymbolTableEntry++-- | The location of a variable, i.e. the 'MemoryBlockName' that+-- contains it as well as the 'Offset' to its location in memory+type Location = (MemoryBlockName, Offset)++-- | The name of block of memory+type MemoryBlockName = Name++-- | Memory offset given to a variable in memory+type Offset = Int

@@ -6,6 +6,9 @@                                                 , ExpVal(..)                                                 , Type                                                 , SemType(..)+                                                , Dim(..)+                                                , Dims(..)+                                                , Dimensions                                                 ) import           Language.Fortran.Vars.Eval     ( eval                                                 , eval'@@ -22,13 +25,18 @@   -> [DimensionDeclarator (Analysis a)]   -> TypeSpec (Analysis a)   -> Type-typeSpecToArrayType st dims tySpec = TArray scalarTy $ Just $ map dimStrip dims+--typeSpecToArrayType st dims tySpec = TArray scalarTy $ foldr go DimensionsEnd dims+typeSpecToArrayType st dims tySpec =+    case foldr go [] dims of+      [] -> error "invalid array spec: zero dimensions"+      d:ds -> TArray scalarTy $ DimsExplicitShape $ d :| ds  where   scalarTy = typeSpecToScalarType st tySpec-  dimStrip (DimensionDeclarator _ _ (Just lb) (Just ub)) =-    (constInt lb, constInt ub)-  dimStrip (DimensionDeclarator _ _ Nothing (Just ub)) = (1, constInt ub)-  dimStrip _ = error "Invalid dimension declarator"+  go (DimensionDeclarator _ _ (Just lb) (Just ub)) dims =+      Dim (Just (constInt lb)) (Just (constInt ub)) : dims+  go (DimensionDeclarator _ _ Nothing   (Just ub)) dims =+      Dim (Just 1) (Just (constInt ub)) : dims+  go _ _ = error "Invalid dimension declarator"   constInt x = case eval st x of     Int y -> y     _     -> error "Invalid array spec"

@@ -309,7 +309,7 @@     let path = "test/constant_propagation/multi_subscript.f"     it "Can handle multiple chained subscripts" $ do       (valueOf, getRHS) <- helper path-      valueOf (getRHS "p") `shouldBe` Top+      --valueOf (getRHS "p") `shouldBe` Top       valueOf (getRHS "q") `shouldBe` Top    describe "Subscripts" $ do

@@ -1,3 +1,6 @@+-- TODO 2023-05-16 raehik: only tests the deprecated short circuit eval, which+-- doesn't yet have a parallel in fortran-src eval+ module EvalSpec where  import           Test.Hspec@@ -14,8 +17,7 @@                                                 , Position(..)                                                 ) -import           Language.Fortran.Vars.Eval-                                                ( evalWithShortcircuit )+import qualified Language.Fortran.Vars.Eval.Deprecated as Deprecated import           Language.Fortran.Vars.Types                                                 ( ExpVal(..)                                                 , SymbolTable@@ -39,36 +41,36 @@   it "Can handle Not" $ do     let ex1 = ExpUnary () dSpan Not true         ex2 = ExpUnary () dSpan Not false-    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)-    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)   it "Can handle simple Or" $ do     let ex1 = ExpBinary () dSpan Or true true         ex2 = ExpBinary () dSpan Or true false         ex3 = ExpBinary () dSpan Or false true         ex4 = ExpBinary () dSpan Or false false-    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)-    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)-    evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical True)-    evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)   it "Can handle simple And" $ do     let ex1 = ExpBinary () dSpan And true true         ex2 = ExpBinary () dSpan And true false         ex3 = ExpBinary () dSpan And false true         ex4 = ExpBinary () dSpan And false false-    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)-    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)-    evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical False)-    evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)   it "Can handle Or with variable" $ do     let ex1 = ExpBinary () dSpan Or true foobar         ex2 = ExpBinary () dSpan Or foobar true-    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)-    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)   it "Can handle And with variable" $ do     let ex1 = ExpBinary () dSpan And false foobar         ex2 = ExpBinary () dSpan And foobar false-    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)-    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)   it "Can handle more complicated trees" $ do     -- (foobar .AND. .TRUE.) .AND.     --    (foobar .AND. (.FALSE. .OR. (foobar .AND. .FALSE.)))@@ -77,13 +79,13 @@         ex2 = ExpBinary () dSpan Or false ex1         rhs = ExpBinary () dSpan And foobar ex2         ex  = ExpBinary () dSpan And lhs rhs-    evalWithShortcircuit dSym ex `shouldBe` Right (Logical False)+    Deprecated.evalWithShortcircuit dSym ex `shouldBe` Right (Logical False)   it "Can handle .NOT. (foobar .AND. .FALSE.)" $ do     let ex1 = ExpBinary () dSpan And foobar false         ex  = ExpUnary () dSpan Not ex1-    evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)   it "Can handle conditions with non-logical logic" $ do     -- .TRUE. .EQ. 1     let vx = ExpValue () dSpan $ ValInteger "1" Nothing         ex = ExpBinary () dSpan EQ true vx-    evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)+    Deprecated.evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)

@@ -1,6 +1,7 @@ module StorageTableSpec where  import           Test.Hspec+import           Util ( dess1 )  import           Language.Fortran.Util.Files    ( flexReadFile ) import           Language.Fortran.Extras.ProgramFile@@ -412,18 +413,18 @@       commonLayoutBf         `shouldBe` [ ( "char_array_a"                      , 0-                     , TArray (TCharacter (CharLenInt 7) 1) (Just [(1, 65)])+                     , TArray (TCharacter (CharLenInt 7) 1) (dess1 1 65)                      )                    , ("int_b"      , 456, TInteger 4)-                   , ("int_array_c", 456, TArray (TInteger 4) (Just [(1, 10)]))+                   , ("int_array_c", 456, TArray (TInteger 4) (dess1 1 10))                    ]       commonLayoutBn         `shouldBe` [ ( "char_array_a"                      , 0-                     , TArray (TCharacter (CharLenInt 7) 1) (Just [(1, 65)])+                     , TArray (TCharacter (CharLenInt 7) 1) (dess1 1 65)                      )                    , ("int_b"      , 455, TInteger 4)-                   , ("int_array_c", 455, TArray (TInteger 4) (Just [(1, 10)]))+                   , ("int_array_c", 455, TArray (TInteger 4) (dess1 1 10))                    ]       commonLayoutCf         `shouldBe` [ ("int_a", 0, TInteger 4)

@@ -4,6 +4,7 @@ import           Data.Generics.Uniplate.Data  import           Test.Hspec+import           Util ( dess1 )  import           Language.Fortran.Analysis      ( Analysis ) import           Language.Fortran.AST           ( ProgramUnit@@ -96,21 +97,21 @@           strctTables = zipWith collectStructures sts pus       head strctTables `shouldBe` M.fromList         [ ( "str_inner"-          , [FieldEntry "inner_arr" (TArray (TInteger 1) (Just [(1, 5)]))]+          , [FieldEntry "inner_arr" (TArray (TInteger 1) (dess1 1 5))]           )         ]       (strctTables !! 1) `shouldBe` M.fromList         [ ( "str_inner"-          , [FieldEntry "inner_arr" (TArray (TInteger 2) (Just [(1, 5)]))]+          , [FieldEntry "inner_arr" (TArray (TInteger 2) (dess1 1 5))]           )         ]       (strctTables !! 2) `shouldBe` M.fromList         [ ( "str_inner"-          , [FieldEntry "inner_arr" (TArray (TInteger 1) (Just [(1, 3)]))]+          , [FieldEntry "inner_arr" (TArray (TInteger 1) (dess1 1 3))]           )         , ( "str_outer"           , [ FieldEntry "outer_arr"-                         (TArray (TCustom "str_inner") (Just [(1, 5)]))+                         (TArray (TCustom "str_inner") (dess1 1 5))             ]           )         ]@@ -201,7 +202,7 @@             )             [ Right (TInteger 1)             , Right (TInteger 2)-            , Right (TArray (TInteger 1) (Just [(1, 3)]))+            , Right (TArray (TInteger 1) (dess1 1 3))             ]       mapM_ (uncurry testStructureTablePU) $ zip pus logics 

@@ -1,5 +1,16 @@+{-+TODO 2023-04-17 raehik++  * dummyOf, isDynamic etc. are a little dangerous, repeating the same checks in+    slightly different ways. May become further fragile with the dimension+    representation change.+-}+ module SymbolTableSpec where +import           Test.Hspec+import           Util ( des1, des1' )+ import           Control.Exception              ( evaluate ) import           Language.Fortran.Extras.Analysis                                                 ( versionedExpandedProgramAnalysis@@ -8,11 +19,13 @@ import           Language.Fortran.Extras.ProgramFile                                                 ( versionedProgramFile ) import           Data.ByteString.Char8          ( ByteString )-import qualified Data.Map                      as M+import qualified Data.Map                       as M+import           Data.List.NonEmpty             ( NonEmpty( (:|) ) )+import qualified Data.List.NonEmpty             as NonEmpty+import qualified Data.Foldable                  as Foldable import           Language.Fortran.AST           ( ProgramUnitName(..) ) import           Language.Fortran.Version       ( FortranVersion(..) ) import           Language.Fortran.Analysis      ( initAnalysis )-import           Test.Hspec  import           Language.Fortran.Vars          ( programFileModel ) import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)@@ -21,6 +34,8 @@                                                 , CharacterLen(..)                                                 , ExpVal(..)                                                 , SymbolTable+                                                , Dim(..), Dims(..)+                                                , getStaticArrayBounds                                                 )  getSymTable :: String -> ByteString -> String -> SymbolTable@@ -56,23 +71,37 @@         SDummy ty       -> ty         _               -> error (name ++ " is not an Entry that has type") -dimensionOf :: String -> SymbolTable -> Maybe [(Int, Int)]+-- | Assert that a binder refers to a static array, and return its dimension+--   bounds.+dimensionOf :: String -> SymbolTable -> [Dim Int] dimensionOf name symTable =-  let Just entry = M.lookup name symTable-  in  case entry of-        SVariable (TArray _ dims) _ -> dims-        SDummy (TArray _ dims) -> dims-        _ -> error (name ++ " is not an Entry that has static dimension")+    case M.lookup name symTable of+      Nothing -> error $ "dimensionOf: couldn't find variable: "<>name+      Just entry ->+        case entry of+          SVariable (TArray _sty ds) _ -> go ds+          SDummy    (TArray _sty ds)   -> go ds+          _ -> error (name ++ " is not an Entry that has static dimension")+  where+    go ds = case getStaticArrayBounds ds of+              Nothing -> error $ "dimensionOf: binder is dynamic array: "<>name+              Just dsStatic ->+                case dsStatic of+                  DimsExplicitShape dsStaticES -> Foldable.toList dsStaticES+                  _ -> error $ "dimensionOf: binder is an array, but not explicit-shape: "<>name  dummyOf :: String -> M.Map String SymbolTableEntry -> String dummyOf name symTable =   let Just entry = M.lookup name symTable   in  case entry of-        SDummy (TArray (TCharacter CharLenStar _) Nothing) ->+        SDummy (TArray (TCharacter CharLenStar _) _) ->           "DummyArrayDynamicCharacter"         SDummy (TCharacter CharLenStar _) -> "DummyDynamicCharacter"-        SDummy (TArray _ Nothing) -> "DummyDynamicArray"-        SDummy (TArray _ (Just _)) -> "DummyStaticArray"+        SDummy (TArray _ ds@DimsExplicitShape{}) ->+          case getStaticArrayBounds ds of+            Nothing -> "DummyDynamicArray"+            Just{}  -> "DummyStaticArray"+        SDummy (TArray _ _) -> "DummyDynamicArray"         SDummy _ -> "DummyStaticScalar"         v -> error (name ++ " is not a DummyVariableEntry it is a " ++ show v) @@ -81,11 +110,22 @@   Just SDummy{} -> True   _             -> False +-- | Is the given symbol "dynamic" in the given symbol table?+--+-- e.g. an explicit-shape array with constant bounds is not dynamic, but an+-- explicit-shape array with a dummy variable for an upper bound is dynamic.+--+-- Arrays are checked using a fortran-src util to convert dynamic-and-static+-- dimension representations to purely static ones. isDynamic :: String -> SymbolTable -> Bool isDynamic name symTable = case M.lookup name symTable of   Just (SVariable ty _) -> case ty of     TArray (TCharacter CharLenStar _) _ -> True-    TArray _ Nothing -> True+    TArray _ ds@DimsExplicitShape{} ->+      case getStaticArrayBounds ds of+        Nothing -> True+        Just{}  -> False+    TArray _ _ -> True     TCharacter CharLenStar _ -> True     _ -> False   _ -> False@@ -157,7 +197,9 @@       valueOf "d8" symTable `shouldBe` Int 60       valueOf "d9" symTable `shouldBe` Int 70       valueOf "e7" symTable `shouldBe` Real 1.2-      valueOf "e8" symTable `shouldBe` Real 2+      -- TODO: below is disallowed by gfortran and spec (F2018 16.9.125)+      -- parameter (e8 = max(1.2,2))+      --valueOf "e8" symTable `shouldBe` Real 2       valueOf "c1" symTable `shouldBe` Str "A"       valueOf "eol" symTable `shouldBe` Str "\r\n"       valueOf "i1" symTable `shouldBe` Int (-2)@@ -244,9 +286,9 @@       contents <- flexReadFile path       let symTable = getSymTable path contents unitName       typeOf "i2_arr" symTable-        `shouldBe` TArray (TInteger 2) (Just [(1, 3), (1, 4)])+        `shouldBe` TArray (TInteger 2) (DimsExplicitShape (Dim (Just 1) (Just 3) :| [Dim (Just 1) (Just 4)]))       typeOf "i8_arr" symTable-        `shouldBe` TArray (TInteger 8) (Just [(1, 3), (1, 4)])+        `shouldBe` TArray (TInteger 8) (DimsExplicitShape (Dim (Just 1) (Just 3) :| [Dim (Just 1) (Just 4)]))    describe "Dimension: " $ do @@ -256,65 +298,60 @@     it "Single dimension" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName-      dimensionOf "a" symTable `shouldBe` Just [(1, 10)]-      dimensionOf "b" symTable `shouldBe` Just [(-3, 5)]-      dimensionOf "c" symTable `shouldBe` Just [(1, 45)]+      dimensionOf "a" symTable `shouldBe` [Dim 1 10]+      dimensionOf "b" symTable `shouldBe` [Dim (-3) 5]+      dimensionOf "c" symTable `shouldBe` [Dim 1 45]      it "Multi-dimension" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName-      dimensionOf "a2" symTable `shouldBe` Just [(1, 5), (1, 5)]-      dimensionOf "a3" symTable `shouldBe` Just [(1, 5), (1, 5), (1, 5)]-      dimensionOf "a4" symTable `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5)]-      dimensionOf "a5" symTable-        `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]-      dimensionOf "a6" symTable-        `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]-      dimensionOf "a7" symTable `shouldBe` Just-        [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]+      dimensionOf "a2" symTable `shouldBe` [Dim 1 5, Dim 1 5]+      dimensionOf "a3" symTable `shouldBe` [Dim 1 5, Dim 1 5, Dim 1 5]+      dimensionOf "a4" symTable `shouldBe` [Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5]+      dimensionOf "a5" symTable `shouldBe` [Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5]+      dimensionOf "a6" symTable `shouldBe` [Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5]+      dimensionOf "a7" symTable `shouldBe` [Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5, Dim 1 5]      it "Dimension statement" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName-      dimensionOf "d" symTable `shouldBe` Just [(1, 10)]-      dimensionOf "m" symTable `shouldBe` Just [(1, 10), (1, 20)]+      dimensionOf "d" symTable `shouldBe` [Dim 1 10]+      dimensionOf "m" symTable `shouldBe` [Dim 1 10, Dim 1 20]      it "String array" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName-      dimensionOf "reqname" symTable `shouldBe` Just [(1, 64)]-      dimensionOf "test" symTable `shouldBe` Just [(1, 3), (1, 4)]+      dimensionOf "reqname" symTable `shouldBe` [Dim 1 64]+      dimensionOf "test" symTable `shouldBe` [Dim 1 3, Dim 1 4]      it "Integer array" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName-      dimensionOf "itest1" symTable `shouldBe` Just [(1, 3), (1, 4)]-      dimensionOf "itest2" symTable `shouldBe` Just [(1, 3), (1, 4)]+      dimensionOf "itest1" symTable `shouldBe` [Dim 1 3, Dim 1 4]+      dimensionOf "itest2" symTable `shouldBe` [Dim 1 3, Dim 1 4]       it "Dimension declaration within COMMON - as ExpSubscript" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName -      dimensionOf "arr_before_range" symTable `shouldBe` Just [(8, 10)]-      dimensionOf "arr_before_multi" symTable-        `shouldBe` Just [(1, 12), (14, 16)]+      dimensionOf "arr_before_range" symTable `shouldBe` [Dim 8 10]+      dimensionOf "arr_before_multi" symTable `shouldBe` [Dim 1 12, Dim 14 16] -      dimensionOf "arr_after_range" symTable `shouldBe` Just [(22, 24)]-      dimensionOf "arr_after_multi" symTable `shouldBe` Just [(1, 26), (28, 30)]+      dimensionOf "arr_after_range"  symTable `shouldBe` [Dim 22 24]+      dimensionOf "arr_after_multi"  symTable `shouldBe` [Dim 1 26, Dim 28 30]      it "Dimension declaration within COMMON - as ExpFunctionCall" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents unitName -      dimensionOf "arr_before_standard_kind" symTable `shouldBe` Just [(1, 2)]-      dimensionOf "arr_before_simple" symTable `shouldBe` Just [(1, 4)]-      dimensionOf "arr_before_nonstandard_kind" symTable-        `shouldBe` Just [(1, 6)]+      dimensionOf "arr_before_standard_kind" symTable `shouldBe` [Dim 1 2]+      dimensionOf "arr_before_simple" symTable `shouldBe` [Dim 1 4]+      dimensionOf "arr_before_nonstandard_kind" symTable `shouldBe` [Dim 1 6] -      dimensionOf "arr_after_standard_kind" symTable `shouldBe` Just [(1, 18)]-      dimensionOf "arr_after_simple" symTable `shouldBe` Just [(1, 20)]-      dimensionOf "arr_after_nonstandard_kind" symTable `shouldBe` Just [(1, 2)]+      dimensionOf "arr_after_standard_kind" symTable `shouldBe` [Dim 1 18]+      dimensionOf "arr_after_simple" symTable `shouldBe` [Dim 1 20]+      dimensionOf "arr_after_nonstandard_kind" symTable `shouldBe` [Dim 1 2]    describe "Dummy Argument: " $ do @@ -329,7 +366,7 @@       typeOf "stscalar1" symTable `shouldBe` TInteger 4        dummyOf "starr1" symTable `shouldBe` "DummyStaticArray"-      typeOf "starr1" symTable `shouldBe` TArray (TInteger 4) (Just [(1, 5)])+      typeOf "starr1" symTable `shouldBe` TArray (TInteger 4) (des1' (Just 5))      it "Dummy variables - dynamic" $ do       contents <- flexReadFile path@@ -338,19 +375,19 @@       dummyOf "dynscalar1" symTable `shouldBe` "DummyDynamicCharacter"        dummyOf "dynarr1" symTable `shouldBe` "DummyDynamicArray"-      typeOf "dynarr1" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "dynarr1" symTable `shouldBe` TArray (TInteger 4) (DimsAssumedSize Nothing (Just 1))        dummyOf "dynarr2" symTable `shouldBe` "DummyDynamicArray"-      typeOf "dynarr2" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "dynarr2" symTable `shouldBe` TArray (TInteger 4) (des1' Nothing)        dummyOf "dynarr3" symTable `shouldBe` "DummyDynamicArray"-      typeOf "dynarr3" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "dynarr3" symTable `shouldBe` TArray (TInteger 4) (DimsAssumedSize (Just (Dim (Just 1) (Just 3) :| [])) (Just 1))        dummyOf "dynarr4" symTable `shouldBe` "DummyDynamicArray"-      typeOf "dynarr4" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "dynarr4" symTable `shouldBe` TArray (TInteger 4) (DimsExplicitShape (Dim (Just 1) (Just 3) :| [Dim (Just 1) Nothing]))        evaluate (dummyOf "dynarr5" symTable) `shouldThrow` anyErrorCall-      typeOf "dynarr5" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "dynarr5" symTable `shouldBe` TArray (TInteger 4) (des1' Nothing)    describe "Dummy array of dynamically-sized strings" $ do     let path     = "test/symbol_table/dummy_array_dynamic_strings.f"@@ -387,7 +424,7 @@       symTable <- getSymTableIO path_interface contents unitName        typeOf "sespit_get_psetdt" symTable-        `shouldBe` TArray (TInteger 2) (Just [(1, 3)])+        `shouldBe` TArray (TInteger 2) (des1' (Just 3))       typeOf "sespit_get_psetdt2_e" symTable `shouldBe` TInteger 2       -- Check we don't pick up subroutines or arguments       M.member "index" symTable `shouldBe` False@@ -569,31 +606,31 @@     it "Dynamic array" $ do       contents <- flexReadFile path       let symTable = getSymTable path contents "f2"-      typeOf "arr" symTable `shouldBe` TArray (TInteger 4) Nothing+      typeOf "arr" symTable `shouldBe` TArray (TInteger 4) (DimsExplicitShape (Dim (Just 1) Nothing :| []))       isDynamic "arr" symTable `shouldBe` True      it "Dynamic character Dynamic array" $ do       contents <- flexReadFile path       let st = getSymTable path contents "f3"-      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) Nothing+      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) (des1' Nothing)       isDynamic "arr" st `shouldBe` True      it "Dynamic character static array" $ do       contents <- flexReadFile path       let st = getSymTable path contents "f4"       typeOf "arr" st-        `shouldBe` TArray (TCharacter CharLenStar 1) (Just [(1, 5)])+        `shouldBe` TArray (TCharacter CharLenStar 1) (des1' (Just 5))       isDynamic "arr" st `shouldBe` True      it "Static character dynamic array" $ do       contents <- flexReadFile path       let st = getSymTable path contents "f5"-      typeOf "arr" st `shouldBe` TArray (TCharacter (CharLenInt 5) 1) Nothing+      typeOf "arr" st `shouldBe` TArray (TCharacter (CharLenInt 5) 1) (des1' Nothing)       isDynamic "arr" st `shouldBe` True      it "Dummy not dynamic" $ do       contents <- flexReadFile path       let st = getSymTable path contents "f6"-      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) Nothing+      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) (des1' Nothing)       isDynamic "arr" st `shouldBe` False       isDummy "arr" st `shouldBe` True

@@ -1,10 +1,12 @@ module TypeCheckSpec where  import           Test.Hspec+import           Util ( dess1 ) import           Control.Monad                  ( zipWithM_ ) import           Data.Either                    ( isLeft ) import           Data.List                      ( find ) import qualified Data.Map                      as M+import qualified Data.List.NonEmpty            as NonEmpty import           Data.Data                      ( Data ) import           Language.Fortran.Extras        ( allPUS                                                 , allPU@@ -16,6 +18,7 @@ import           Language.Fortran.Vars.Types    ( Type                                                 , SemType(..)                                                 , CharacterLen(..)+                                                , Dims(..), Dim(..)                                                 ) import           Language.Fortran.Vars.TypeCheck                                                 ( typeOf@@ -180,9 +183,9 @@      it "Index ranges" $ do       (typeof, rhs) <- helper path puName-      typeof (rhs "i1") `shouldBe` Right (TArray (TInteger 4) (Just [(1, 10)]))-      typeof (rhs "i2") `shouldBe` Right (TArray (TInteger 4) (Just [(1, 10)]))-      typeof (rhs "i3") `shouldBe` Right (TArray (TInteger 4) Nothing)+      typeof (rhs "i1") `shouldBe` Right (TArray (TInteger 4) (dess1 1 10))+      typeof (rhs "i2") `shouldBe` Right (TArray (TInteger 4) (dess1 1 10))+      typeof (rhs "i3") `shouldBe` Right (TArray (TInteger 4) (DimsExplicitShape (Dim (Just 1) Nothing :| [])))      it "Erroneous expressions" $ do       -- These expressions aren't valid but any subscript can be assumed to@@ -360,18 +363,19 @@       strt = collectStructures symt pu       dgs  = [ aStrip dgs' | StData _ _ dgs' <- allPUS pu ]       test (DataGroup _ _ es _ : _) dims = typeOf strt symt (head $ aStrip es)-        `shouldBe` Right (TArray (TInteger 2) (Just dims))+        `shouldBe` Right (TArray (TInteger 2) (DimsExplicitShape dims))       test _ _ = error "Shouldn't reach this"+    let ds1 lb ub = NonEmpty.singleton $ Dim (Just lb) (Just ub)     let res =-          [ [(1, 5)]-          , [(1, 3)]-          , [(1, 3)]-          , [(1, 9)]-          , [(1, 2)]-          , [(1, 6)]-          , [(1, 3)]-          , [(1, 2)]-          , [(1, 2)]+          [ ds1 1 5+          , ds1 1 3+          , ds1 1 3+          , ds1 1 9+          , ds1 1 2+          , ds1 1 6+          , ds1 1 3+          , ds1 1 2+          , ds1 1 2           ]     length dgs `shouldBe` length res     zipWithM_ test dgs res

@@ -0,0 +1,19 @@+module Util where++import Language.Fortran.Common.Array++-- | Explicit-shape array, one dimension with both bounds statically specified.+dess1 :: Applicative t => a -> a -> Dims t (Maybe a)+dess1 lb ub = DimsExplicitShape $ pure $ Dim (Just lb) (Just ub)++-- | Explicit-shape array, one dimension, lower and upper bounds provided.+--+-- Slight overkill type. Simplifiy if you start getting ambiguity.+des1 :: Applicative t => a -> a -> Dims t a+des1 lb ub = DimsExplicitShape $ pure $ Dim lb ub++-- | Explicit-shape array, one dimension, lower bound 1, upper bound provided.+--+-- Slight overkill type. Simplifiy if you start getting ambiguity.+des1' :: (Applicative t, Applicative f, Num a) => f a -> Dims t (f a)+des1' ub = DimsExplicitShape $ pure $ Dim (pure 1) ub