diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs index 34f10a76..10a47168 100644 --- a/src/Language/Fortran/Analysis.hs +++ b/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 diff --git a/src/Language/Fortran/Analysis/DataFlow.hs b/src/Language/Fortran/Analysis/DataFlow.hs index 688f227e..3f306453 100644 --- a/src/Language/Fortran/Analysis/DataFlow.hs +++ b/src/Language/Fortran/Analysis/DataFlow.hs @@ -368,33 +368,82 @@ 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 parameteri 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 + + -- -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily. + -- pvMapIter :: M.Map Name Repr.FValue -> M.Map Name Repr.FValue + -- pvMapIter map0 = map0 `M.union` M.fromList $ + -- [ (varName v, expr) + -- | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)] + -- , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)] + -- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st + -- , expr <- getE0 map0 e ] + -- ++ + -- [ (varName v, expr) + -- | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)] + -- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st + -- , expr <- getE0 map0 e ] + + 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)) + 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 - Left _err -> Nothing - Right (a, _msgs) -> Just a + case Repr.runEvalFValuePure pvMap (Repr.evalExpr e) of + Left _err -> + case e of + ExpValue _ _ (ValVariable{}) -> Nothing + _ -> Nothing + Right (a, _msgs) -> + case e of + ExpValue _ _ (ValVariable{}) -> Just a + _ -> Just a -- | Get constant-expression information and put it into the AST -- analysis annotation. Must occur after analyseBBlocks. diff --git a/src/Language/Fortran/Repr/Eval/Value.hs b/src/Language/Fortran/Repr/Eval/Value.hs index 0d3e5f9c..4620ed9d 100644 --- a/src/Language/Fortran/Repr/Eval/Value.hs +++ b/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 diff --git a/src/Language/Fortran/Util/ModFile.hs b/src/Language/Fortran/Util/ModFile.hs index 8cf040e9..67297422 100644 --- a/src/Language/Fortran/Util/ModFile.hs +++ b/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 diff --git a/test/Language/Fortran/Repr/EvalSpec.hs b/test/Language/Fortran/Repr/EvalSpec.hs index 61cbb996..d66ab22d 100644 --- a/test/Language/Fortran/Repr/EvalSpec.hs +++ b/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