Merge pull request #288 from camfort/improveConstExpr

Build a map (statefully) as we process declarations

.github/workflows/ci.yml

@@ -41,7 +41,7 @@ jobs:
       run: stack --no-terminal install
 
     - name: Upload executable
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         path: ~/.local/bin/${{ env.EXE_NAME }}
         name: ${{ env.EXE_NAME }}-ubuntu-stack-${{ github.sha }}
@@ -143,10 +143,10 @@ jobs:
       env:
         HSPEC_OPTIONS: --color
 
-    # note that Cabal uses symlinks -- actions/upload-artifact@v2 apparently
+    # note that Cabal uses symlinks -- actions/upload-artifact@v4 apparently
     # dereferences for us
     - name: Upload executable
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         path: ~/.cabal/bin/${{ env.EXE_NAME }}
         name: ${{ env.EXE_NAME }}-macos-ghc-${{ matrix.ghc }}-cabal-${{ github.sha }}
@@ -192,7 +192,7 @@ jobs:
         HSPEC_OPTIONS: --color
 
     - name: Upload executable
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         path: "C:/cabal/bin/${{ env.EXE_NAME }}.exe"
         name: ${{ env.EXE_NAME }}-windows-ghc-${{ matrix.ghc }}-cabal-${{ github.sha }}.exe

.github/workflows/disabled/hackage.yml

@@ -68,14 +68,14 @@ jobs:
     - run: cabal sdist
 
     - name: Upload Hackage sdist
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         path: dist-newstyle/sdist/${{ env.package_name }}-*.tar.gz
         name: ${{ env.package_name }}-sdist-${{ github.sha }}.tar.gz
         if-no-files-found: error
 
     - name: Upload Hackage Haddock docs
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         path: dist-newstyle/${{ env.package_name }}-*-docs.tar.gz
         name: ${{ env.package_name }}-hackage-haddocks-${{ github.sha }}.tar.gz

src/Language/Fortran/Analysis.hs

@@ -3,7 +3,7 @@
 -- |
 -- Common data structures and functions supporting analysis of the AST.
 module Language.Fortran.Analysis
-  ( initAnalysis, stripAnalysis, Analysis(..)
+  ( initAnalysis, analysis0, stripAnalysis, Analysis(..)
   , varName, srcName, lvVarName, lvSrcName, isNamedExpression
   , genVar, puName, puSrcName, blockRhsExprs, rhsExprs
   , ModEnv, NameType(..), Locality(..), markAsImported, isImported

src/Language/Fortran/Analysis/DataFlow.hs

@@ -368,31 +368,62 @@ type ConstExpMap = ASTExprNodeMap (Maybe Repr.FValue)
 -- | Generate a constant-expression map with information about the
 -- expressions (identified by insLabel numbering) in the ProgramFile
 -- pf (must have analysis initiated & basic blocks generated) .
-genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
+genConstExpMap :: forall a. (Data a) => ProgramFile (Analysis a) -> ConstExpMap
 genConstExpMap pf = ceMap
   where
-    -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.
-    pvMap = M.fromList $
-      [ (varName v, getE e)
-      | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]
-      , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]
-      , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ] ++
-      [ (varName v, getE e)
-      | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]
-      , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ]
-    getV :: Expression (Analysis a) -> Maybe Repr.FValue
-    getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e)
-
     -- Generate map of information about 'constant expressions'.
     ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ]
+
+    -- Initial map of parameter declarations
+    pvMap :: M.Map Name Repr.FValue
+    pvMap = execState (recursivelyProcessDecls declarations) M.empty
+
+    -- Gather all the declarations in order
+    declarations :: [Statement (Analysis a)]
+    declarations =
+      flip filter (universeBi pf :: [Statement (Analysis a)]) $
+          \case
+              StDeclaration{} -> True
+              StParameter{}   -> True
+              _               -> False
+
+    recursivelyProcessDecls :: [Statement (Analysis a)] -> State (M.Map Name Repr.FValue) ()
+    recursivelyProcessDecls [] = return ()
+    recursivelyProcessDecls (stmt:stmts) = do
+      let internalDecls =
+            case stmt of
+              (StDeclaration _ _ (TypeSpec _ _ _ _) _ _) ->
+                -- Gather up all the declarations that are contain in this StDeclaration
+                -- (there could be many)
+                [ (varName v, e)
+                   | (Declarator _ _ v _ _ (Just e)) <- universeBi stmt :: [Declarator (Analysis a)]
+                    , AttrParameter _ _ <- universeBi stmt :: [Attribute (Analysis a)] ]
+
+              StParameter{} ->
+                [(varName v, e) | (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi stmt ]
+              _ -> []
+      -- Now process these decls
+      forM_ internalDecls (\(v, e) -> modify (\map ->
+        case getE0 map e of
+          Just evalExpr -> M.insert v evalExpr map
+          Nothing       -> map))
+      recursivelyProcessDecls stmts
+
+    -- Evaluate an expression down to a value
+    getE0 :: M.Map Name Repr.FValue -> Expression (Analysis a) -> Maybe (Repr.FValue)
+    getE0 pvMap e = either (const Nothing) (Just . fst) (Repr.runEvalFValuePure pvMap (Repr.evalExpr e))
+
+    -- Lookup an expression in the constants maps
     getE :: Expression (Analysis a) -> Maybe Repr.FValue
     getE = join . (flip IM.lookup ceMap <=< labelOf)
+
     labelOf = insLabel . getAnnotation
+
     doExpr :: Expression (Analysis a) -> Maybe Repr.FValue
     doExpr e =
         -- TODO constants may use other constants! but genConstExpMap needs more
         -- changes to support that
-        case Repr.runEvalFValuePure mempty (Repr.evalExpr e) of
+        case Repr.runEvalFValuePure pvMap (Repr.evalExpr e) of
           Left _err -> Nothing
           Right (a, _msgs) -> Just a
 

src/Language/Fortran/Repr/Eval/Value.hs

@@ -25,6 +25,8 @@ import Language.Fortran.Repr.Type.Scalar ( fScalarTypeKind )
 import Language.Fortran.Repr.Eval.Common
 import qualified Language.Fortran.Repr.Eval.Value.Op as Op
 
+import qualified Language.Fortran.Analysis as FA
+
 import GHC.Generics ( Generic )
 import qualified Data.Text as Text
 import qualified Data.Char
@@ -102,11 +104,11 @@ evalVar name =
       Nothing  -> err $ ENoSuchVar name
       Just val -> pure val
 
-evalExpr :: MonadFEvalValue m => F.Expression a -> m FValue
+evalExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
 evalExpr = \case
-  F.ExpValue _ _ astVal ->
+  e@(F.ExpValue _ _ astVal) ->
     case astVal of
-      F.ValVariable name -> evalVar name
+      F.ValVariable name -> evalVar (FA.varName e)
       -- TODO: Do same with ValIntrinsic??? idk...
       _ -> MkFScalarValue <$> evalLit astVal
   F.ExpUnary  _ _ uop e   -> do
@@ -125,13 +127,13 @@ evalExpr = \case
     evalFunctionCall (forceVarExpr ve) evaledArgs
   _ -> err $ EUnsupported "Expression constructor"
 
-forceVarExpr :: F.Expression a -> F.Name
+forceVarExpr :: F.Expression (FA.Analysis a) -> F.Name
 forceVarExpr = \case
   F.ExpValue _ _ (F.ValVariable v) -> v
   F.ExpValue _ _ (F.ValIntrinsic v) -> v
   _ -> error "program error, sent me an expr that wasn't a name"
 
-evalLit :: MonadFEvalValue m => F.Value a -> m FScalarValue
+evalLit :: MonadFEvalValue m => F.Value (FA.Analysis a) -> m FScalarValue
 evalLit = \case
   F.ValInteger i mkp -> do
     evalMKp 4 mkp >>= \case
@@ -176,7 +178,7 @@ evalLit = \case
 err :: MonadError Error m => Error -> m a
 err = throwError
 
-evalKp :: MonadFEvalValue m => F.KindParam a -> m FKindLit
+evalKp :: MonadFEvalValue m => F.KindParam (FA.Analysis a) -> m FKindLit
 evalKp = \case
   F.KindParamInt _ _ k ->
     -- TODO we may wish to check kind param sensibility here
@@ -192,14 +194,14 @@ evalKp = \case
         _ -> err $ EKindLitBadType var (fValueType val)
       Nothing  -> err $ ENoSuchVar var
 
-evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam a) -> m FKindLit
+evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
 evalMKp kDef = \case
   Nothing -> pure kDef
   Just kp -> evalKp kp
 
 -- TODO needs cleanup: internal repetition, common parts with evalKp. also needs
 -- a docstring
-evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m FKindLit
+evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
 evalRealKp l = \case
   Nothing ->
     case l of
@@ -425,7 +427,7 @@ evalIntrinsicIntXCoerce coerceToIX v = do
         err $ EOpTypeError $
             "int: unsupported or unimplemented type: "<>show (fScalarValueType v')
 
-evalArg :: MonadFEvalValue m => F.Argument a -> m FValue
+evalArg :: MonadFEvalValue m => F.Argument (FA.Analysis a) -> m FValue
 evalArg (F.Argument _ _ _ ae) =
     case ae of
       F.ArgExpr        e -> evalExpr e
@@ -493,5 +495,5 @@ evalIntrinsicMax = \case
                 "max: unsupported type: "<> show (fScalarValueType vCurMax)
 
 -- | Evaluate a constant expression (F2018 10.1.12).
-evalConstExpr :: MonadFEvalValue m => F.Expression a -> m FValue
+evalConstExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
 evalConstExpr = evalExpr

src/Language/Fortran/Util/ModFile.hs

@@ -139,7 +139,7 @@ emptyModFile = ModFile "" M.empty M.empty M.empty M.empty M.empty M.empty
 -- | Extracts the module map, declaration map and type analysis from
 -- an analysed and renamed ProgramFile, then inserts it into the
 -- ModFile.
-regenModFile :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ModFile -> ModFile
+regenModFile :: forall a. (Data a) => F.ProgramFile (FA.Analysis a) -> ModFile -> ModFile
 regenModFile pf mf = mf { mfModuleMap   = extractModuleMap pf
                         , mfDeclMap     = extractDeclMap pf
                         , mfTypeEnv     = FAT.extractTypeEnv pf
@@ -148,7 +148,7 @@ regenModFile pf mf = mf { mfModuleMap   = extractModuleMap pf
 
 -- | Generate a fresh ModFile from the module map, declaration map and
 -- type analysis of a given analysed and renamed ProgramFile.
-genModFile :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ModFile
+genModFile :: forall a. (Data a) => F.ProgramFile (FA.Analysis a) -> ModFile
 genModFile = flip regenModFile emptyModFile
 
 -- | Looks up the raw "other data" that may be stored in a ModFile by

test/Language/Fortran/Repr/EvalSpec.hs

@@ -10,6 +10,8 @@ import Language.Fortran.AST
 import Language.Fortran.Repr
 import Language.Fortran.Repr.Eval.Value
 
+import Language.Fortran.Analysis
+
 import Data.Int
 
 spec :: Spec
@@ -29,15 +31,15 @@ shouldEvalTo checkVal prog =
           -- _ -> expectationFailure "not a scalar"
       Left e -> expectationFailure (show e)
 
-expBinary :: BinaryOp -> Expression () -> Expression () -> Expression ()
-expBinary = ExpBinary () u
+expBinary :: BinaryOp -> Expression (Analysis ()) -> Expression (Analysis ()) -> Expression (Analysis ())
+expBinary = ExpBinary (analysis0 ()) u
 
-expValue :: Value () -> Expression ()
-expValue = ExpValue () u
+expValue :: Value (Analysis ()) -> Expression (Analysis ())
+expValue = ExpValue (analysis0 ()) u
 
 -- | default kind. take integral-like over String because nicer to write :)
-valInteger :: (Integral a, Show a) => a -> Value ()
+valInteger :: (Integral a, Show a) => a -> Value (Analysis ())
 valInteger i = ValInteger (show i) Nothing
 
-expValInt :: (Integral a, Show a) => a -> Expression ()
+expValInt :: (Integral a, Show a) => a -> Expression (Analysis ())
 expValInt = expValue . valInteger