diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,12 @@ -### 0.16.0 (Sept 4, 2024) +### 0.16.2 (Sep 13, 2024) + * Small change to allow a path to be added when building mod-file naming map + * Improvements to the power of constant propagation and constant expression evaluation. + +### 0.16.1 (Sep 04, 2024) + * Minor fix to `fromConstReal` which was partial. + * Added `Ord` instance for `AST` and all its sub data types, allowing, for example, ASTs to be in containers like Data.Set + +### 0.16.0 (Sep 04, 2024) * Added `--show-make-list` option to give a topological sort on the dependency graph for a source tree * Added `--version` option * Some robustness improvements around mod files [#286](https://github.com/camfort/fortran-src/pull/286) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -51,7 +51,7 @@ programName = "fortran-src" showVersion :: String -showVersion = "0.16.1" +showVersion = "0.16.2" main :: IO () main = do diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: fortran-src -version: 0.16.1 +version: 0.16.2 synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @@ project, which uses fortran-src as its front end. category: Language diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs --- a/src/Language/Fortran/AST.hs +++ b/src/Language/Fortran/AST.hs @@ -14,6 +14,9 @@ * Fortran 90 standard: ANSI X3.198-1992 (also ISO/IEC 1539:1991) * Fortran 90 Handbook (J. Adams) * Fortran 77 standard: ANSI X3.9-1978 + +Note that the 'Ord' instances provided here do not guarantee any specific +behaviour, other than being valid instances (they are largely for convenience). -} module Language.Fortran.AST @@ -172,7 +175,7 @@ , typeSpecSpan :: SrcSpan , typeSpecBaseType :: BaseType , typeSpecSelector :: Maybe (Selector a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | The "kind selector" of a declaration statement. Tightly bound to -- 'TypeSpec'. @@ -195,16 +198,16 @@ , selectorSpan :: SrcSpan , selectorLength :: Maybe (Expression a) , selectorKind :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data MetaInfo = MetaInfo { miVersion :: FortranVersion, miFilename :: String } - deriving stock (Eq, Show, Data, Generic) + deriving stock (Eq, Ord, Show, Data, Generic) -- Program structure definition data ProgramFile a = ProgramFile { programFileMeta :: MetaInfo , programFileProgramUnits :: [ ProgramUnit a ] - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) pfSetFilename :: String -> ProgramFile a -> ProgramFile a pfSetFilename fn (ProgramFile mi pus) = ProgramFile (mi { miFilename = fn }) pus @@ -259,7 +262,7 @@ | PUComment -- ^ Program unit-level comment a SrcSpan (Comment a) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) type Prefixes a = Maybe (AList Prefix a) type Suffixes a = Maybe (AList Suffix a) @@ -277,7 +280,7 @@ data Prefix a = PfxRecursive a SrcSpan | PfxElemental a SrcSpan | PfxPure a SrcSpan - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- see C1241 & C1242 (Fortran2003) validPrefixSuffix :: PrefixSuffix a -> Bool @@ -291,7 +294,7 @@ sfxs = aStrip' msfxs data Suffix a = SfxBind a SrcSpan (Maybe (Expression a)) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _) = bs @@ -323,7 +326,7 @@ programUnitSubprograms PUComment{} = Nothing newtype Comment a = Comment String - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Block a = BlStatement -- ^ Statement @@ -391,7 +394,7 @@ | BlComment -- ^ Block-level comment a SrcSpan (Comment a) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Statement a = StDeclaration @@ -615,7 +618,7 @@ -- Following is a temporary solution to a complicated FORMAT statement -- parsing problem. | StFormatBogus a SrcSpan String - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- R1214 proc-decl is procedure-entity-name [=> null-init] data ProcDecl a = ProcDecl @@ -623,12 +626,12 @@ , procDeclSpan :: SrcSpan , procDeclEntityName :: Expression a , procDeclInitName :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- R1212 proc-interface is interface-name or declaration-type-spec data ProcInterface a = ProcInterfaceName a SrcSpan (Expression a) | ProcInterfaceType a SrcSpan (TypeSpec a) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Part of a FORALL statement. Introduced in Fortran 95. data ForallHeader a = ForallHeader @@ -636,7 +639,7 @@ , forallHeaderSpan :: SrcSpan , forallHeaderHeaders :: [ForallHeaderPart a] , forallHeaderScaling :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data ForallHeaderPart a = ForallHeaderPart { forallHeaderPartAnno :: a @@ -645,13 +648,13 @@ , forallHeaderPartStart :: Expression a , forallHeaderPartEnd :: Expression a , forallHeaderPartStride :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Only = Exclusive | Permissive - deriving stock (Eq, Show, Data, Generic) + deriving stock (Eq, Ord, Show, Data, Generic) data ModuleNature = ModIntrinsic | ModNonIntrinsic - deriving stock (Eq, Show, Data, Generic) + deriving stock (Eq, Ord, Show, Data, Generic) -- | Part of USE statement. /(F2018 14.2.2)/ -- @@ -664,7 +667,7 @@ | UseID a SrcSpan (Expression a) -- ^ name - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- TODO potentially should throw Maybe String into ArgumentExpression too? data Argument a = Argument @@ -672,7 +675,7 @@ , argumentSpan :: SrcSpan , argumentName :: Maybe String , argumentExpr :: ArgumentExpression a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Extra data type to disambiguate between plain variable arguments and -- expression arguments (due to apparent behaviour of some Fortran compilers @@ -683,7 +686,7 @@ data ArgumentExpression a = ArgExpr (Expression a) | ArgExprVar a SrcSpan Name - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) instance Annotated ArgumentExpression where getAnnotation = \case @@ -729,17 +732,17 @@ | AttrTarget a SrcSpan | AttrValue a SrcSpan | AttrVolatile a SrcSpan - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Intent = In | Out | InOut - deriving stock (Eq, Show, Data, Generic) + deriving stock (Eq, Ord, Show, Data, Generic) data ControlPair a = ControlPair { controlPairAnno :: a , controlPairSpan :: SrcSpan , controlPairName :: Maybe String , controlPairExpr :: Expression a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Part of ALLOCATE statement. -- @@ -754,7 +757,7 @@ a SrcSpan (Expression a) -- ^ scalar character variable | AOSource a SrcSpan (Expression a) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | List of names for an IMPLICIT statement. data ImpList a = ImpList @@ -762,14 +765,14 @@ , impListSpan :: SrcSpan , impListType :: TypeSpec a , impListElements :: AList ImpElement a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data ImpElement a = ImpElement { impElementAnno :: a , impElementSpan :: SrcSpan , impElementFrom :: Char , impElementTo :: Maybe Char - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | A single COMMON block definition. -- @@ -779,14 +782,14 @@ , commonGroupSpan :: SrcSpan , commonGroupName :: Maybe (Expression a) , commonGroupVars :: AList Declarator a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Namelist a = Namelist { namelistAnno :: a , namelistSpan :: SrcSpan , namelistName :: Expression a , namelistVars :: AList Expression a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | The part of a DATA statement describing a single set of initializations. -- @@ -799,7 +802,7 @@ , dataGroupSpan :: SrcSpan , dataGroupNames :: AList Expression a , dataGroupInitializers :: AList Expression a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Field types in pre-Fortran 90 non-standard structure/record/union -- extension. @@ -821,13 +824,13 @@ (Maybe String) -- ^ Substructure name String -- ^ Field name (AList StructureItem a) -- ^ Substructure fields - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data UnionMap a = UnionMap { unionMapAnno :: a , unionMapSpan :: SrcSpan , unionMapFields :: AList StructureItem a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data FormatItem a = FIFormatList a SrcSpan (Maybe String) (AList FormatItem a) @@ -838,7 +841,7 @@ | FIFieldDescriptorAIL a SrcSpan (Maybe Integer) Char Integer | FIBlankDescriptor a SrcSpan Integer | FIScaleFactor a SrcSpan Integer - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Part of the newer (Fortran 2003?) FLUSH statement. -- @@ -856,7 +859,7 @@ | FSErr a SrcSpan (Expression a) -- ^ statement label - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data DoSpecification a = DoSpecification { doSpecAnno :: a @@ -864,7 +867,7 @@ , doSpecInitial :: Statement a -- ^ Guaranteed to be 'StExpressionAssign' , doSpecLimit :: Expression a , doSpecIncrement :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Expression a = ExpValue a SrcSpan (Value a) @@ -885,7 +888,7 @@ -- ^ Array initialisation | ExpReturnSpec a SrcSpan (Expression a) -- ^ Function return value specification - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) data Index a = IxSingle a SrcSpan (Maybe String) (Expression a) @@ -893,7 +896,7 @@ (Maybe (Expression a)) -- ^ Lower index (Maybe (Expression a)) -- ^ Upper index (Maybe (Expression a)) -- ^ Stride - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Values and literals. -- @@ -925,7 +928,7 @@ | ValType String | ValStar | ValColon -- see R402 / C403 in Fortran2003 spec. - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) deriving anyclass (NFData, Out) -- | Declarators. R505 entity-decl from F90 ISO spec. @@ -949,12 +952,12 @@ , declaratorType :: DeclaratorType a , declaratorLength :: Maybe (Expression a) , declaratorInitial :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data DeclaratorType a = ScalarDecl | ArrayDecl (AList DimensionDeclarator a) - deriving stock (Eq, Show, Data, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Generic, Functor) -- | Set a 'Declarator''s initializing expression only if it has none already. setInitialisation :: Declarator a -> Expression a -> Declarator a @@ -968,7 +971,7 @@ , dimDeclSpan :: SrcSpan , dimDeclLower :: Maybe (Expression a) , dimDeclUpper :: Maybe (Expression a) - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) data UnaryOp = Plus diff --git a/src/Language/Fortran/AST/AList.hs b/src/Language/Fortran/AST/AList.hs --- a/src/Language/Fortran/AST/AList.hs +++ b/src/Language/Fortran/AST/AList.hs @@ -21,7 +21,7 @@ { alistAnno :: a , alistSpan :: SrcSpan , alistList :: [t a] - } deriving stock (Eq, Show, Data, Generic) + } deriving stock (Eq, Ord, Show, Data, Generic) instance Functor t => Functor (AList t) where fmap f (AList a s xs) = AList (f a) s (map (fmap f) xs) @@ -76,7 +76,7 @@ , atupleSpan :: SrcSpan , atupleFst :: t1 a , atupleSnd :: t2 a - } deriving stock (Eq, Show, Data, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Generic, Functor) instance FirstParameter (ATuple t1 t2 a) a instance SecondParameter (ATuple t1 t2 a) SrcSpan diff --git a/src/Language/Fortran/AST/Literal.hs b/src/Language/Fortran/AST/Literal.hs --- a/src/Language/Fortran/AST/Literal.hs +++ b/src/Language/Fortran/AST/Literal.hs @@ -14,7 +14,7 @@ data KindParam a = KindParamInt a SrcSpan String -- ^ @[0-9]+@ | KindParamVar a SrcSpan Name -- ^ @[a-z][a-z0-9]+@ (case insensitive) - deriving stock (Eq, Show, Data, Typeable, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) deriving anyclass (NFData, Out) instance FirstParameter (KindParam a) a diff --git a/src/Language/Fortran/AST/Literal/Boz.hs b/src/Language/Fortran/AST/Literal/Boz.hs --- a/src/Language/Fortran/AST/Literal/Boz.hs +++ b/src/Language/Fortran/AST/Literal/Boz.hs @@ -71,7 +71,7 @@ _ -> False data Conforming = Conforming | Nonconforming - deriving stock (Eq, Show, Generic, Data, Typeable, Ord) + deriving stock (Eq, Ord, Show, Generic, Data, Typeable) deriving anyclass (NFData, Out) -- | UNSAFE. Parses a BOZ literal constant string. diff --git a/src/Language/Fortran/AST/Literal/Complex.hs b/src/Language/Fortran/AST/Literal/Complex.hs --- a/src/Language/Fortran/AST/Literal/Complex.hs +++ b/src/Language/Fortran/AST/Literal/Complex.hs @@ -27,7 +27,7 @@ , complexLitPos :: SrcSpan , complexLitRealPart :: ComplexPart a , complexLitImagPart :: ComplexPart a - } deriving stock (Eq, Show, Data, Typeable, Generic, Functor) + } deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) deriving anyclass (NFData, Out) instance FirstParameter (ComplexLit a) a @@ -51,7 +51,7 @@ = ComplexPartReal a SrcSpan RealLit (Maybe (KindParam a)) -- ^ signed real lit | ComplexPartInt a SrcSpan String (Maybe (KindParam a)) -- ^ signed int lit | ComplexPartNamed a SrcSpan Name -- ^ named constant - deriving stock (Eq, Show, Data, Typeable, Generic, Functor) + deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) deriving anyclass (NFData, Out) instance FirstParameter (ComplexPart a) a diff --git a/src/Language/Fortran/AST/Literal/Real.hs b/src/Language/Fortran/AST/Literal/Real.hs --- a/src/Language/Fortran/AST/Literal/Real.hs +++ b/src/Language/Fortran/AST/Literal/Real.hs @@ -40,13 +40,15 @@ -- ^ A string representing a signed decimal. -- ^ Approximate regex: @-? ( [0-9]+ \. [0-9]* | \. [0-9]+ )@ , realLitExponent :: Exponent - } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord) + } deriving stock (Eq, Ord, Show, Data, Typeable, Generic) + deriving anyclass (NFData, Out) -- | An exponent is an exponent letter (E, D) and a signed integer. data Exponent = Exponent { exponentLetter :: ExponentLetter , exponentNum :: String - } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord) + } deriving stock (Eq, Ord, Show, Data, Typeable, Generic) + deriving anyclass (NFData, Out) -- Note: Some Fortran language references include extensions here. HP's F90 -- reference provides a Q exponent letter which sets kind to 16. @@ -54,7 +56,8 @@ = ExpLetterE -- ^ KIND=4 (float) | ExpLetterD -- ^ KIND=8 (double) | ExpLetterQ -- ^ KIND=16 ("quad", rare? extension) - deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord) + deriving stock (Eq, Ord, Show, Data, Typeable, Generic) + deriving anyclass (NFData, Out) -- | Prettify a 'RealLit' in a Haskell-compatible way. prettyHsRealLit :: RealLit -> String diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs --- 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 --- a/src/Language/Fortran/Analysis/DataFlow.hs +++ b/src/Language/Fortran/Analysis/DataFlow.hs @@ -368,31 +368,62 @@ -- | 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 diff --git a/src/Language/Fortran/Repr/Eval/Value.hs b/src/Language/Fortran/Repr/Eval/Value.hs --- a/src/Language/Fortran/Repr/Eval/Value.hs +++ b/src/Language/Fortran/Repr/Eval/Value.hs @@ -25,6 +25,8 @@ 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 @@ 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 @@ 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 @@ 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 @@ _ -> 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 @@ 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 @@ "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 --- a/src/Language/Fortran/Util/ModFile.hs +++ b/src/Language/Fortran/Util/ModFile.hs @@ -80,7 +80,7 @@ import GHC.Generics (Generic) import System.Directory ( doesFileExist, getModificationTime ) import qualified System.FilePath -import System.FilePath ( (-<.>), () ) +import System.FilePath ( (-<.>), (), normalise ) import System.IO ( hPutStrLn, stderr ) -------------------------------------------------- @@ -139,7 +139,7 @@ -- | 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 @@ -- | 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 @@ -250,11 +250,13 @@ -- | Create a map that links all unique variable/function names in the -- ModFiles to their corresponding *originating* filename (i.e., where they are declared) -genUniqNameToFilenameMap :: ModFiles -> M.Map F.Name String -genUniqNameToFilenameMap = M.unions . map perMF +genUniqNameToFilenameMap :: FilePath -> ModFiles -> M.Map F.Name String +genUniqNameToFilenameMap localPath = M.unions . map perMF where - perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems localModuleMap - , (n, _) <- M.elems modEnv ] + perMF mf = M.fromList + [ (n, normalise $ localPath fname) + | modEnv <- M.elems localModuleMap + , (n, _) <- M.elems modEnv ] where -- Make sure that we remove imported declarations so we can -- properly localise declarations to the originator file. diff --git a/test/Language/Fortran/Analysis/ModFileSpec.hs b/test/Language/Fortran/Analysis/ModFileSpec.hs --- a/test/Language/Fortran/Analysis/ModFileSpec.hs +++ b/test/Language/Fortran/Analysis/ModFileSpec.hs @@ -34,12 +34,13 @@ -- of the variable `constant` to the leaf module, whilst understanding -- in the `mid1` and `mid2` modules that it is an imported declaration. testModuleMaps = do - paths <- expandDirs ["test-data" "module"] + let fixturePath = "test-data" "module" + paths <- expandDirs [fixturePath] -- parse all files into mod files pfs <- mapM (\p -> pParser p) paths let modFiles = map genModFile pfs -- get unique name to filemap - let mmap = genUniqNameToFilenameMap modFiles + let mmap = genUniqNameToFilenameMap "" modFiles -- check that `constant` is declared in leaf.f90 let Just leaf = M.lookup "leaf_constant_1" mmap leaf `shouldBe` ("test-data" "module" "leaf.f90") diff --git a/test/Language/Fortran/Repr/EvalSpec.hs b/test/Language/Fortran/Repr/EvalSpec.hs --- a/test/Language/Fortran/Repr/EvalSpec.hs +++ b/test/Language/Fortran/Repr/EvalSpec.hs @@ -10,6 +10,8 @@ import Language.Fortran.Repr import Language.Fortran.Repr.Eval.Value +import Language.Fortran.Analysis + import Data.Int spec :: Spec @@ -29,15 +31,15 @@ -- _ -> 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