diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,39 @@ +### 0.16.9 + * Added support for legacy features in Fortran 90 free-form style + +### 0.16.8 + * Package build support up to GHC 9.12 + * Fixed pretty printing of array semantic types + +### 0.16.7 + * Added mention of Fortran 2003 version support in the help message + * Improved parsing of `allocate` statements + +### 0.16.5 + * Small fix to Fortran 2003 parsing around `procedure` statements. + +### 0.16.4 (Feb 07, 2025) + * Small fix around parsing of BOZ constants. + * This version was reviewed for JOSS. + +### 0.16.3 (Sep 30, 2024) + * Store source names for local declarations in .fsmod files. + * Constant evaluator now handles real-integer exponent and real-real exponent expression + +### 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) + * Helpers to work with the partial evaluation representation [#285](https://github.com/camfort/fortran-src/pull/285) + ### 0.15.1 (Jun 22, 2023) * remove unused vector-sized dependency diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,5 @@ Copyright (c) 2015-2021: Mistral Contrastin, Matthew Danish, Dominic Orchard and Andrew Rice -Additional thanks for contributions from: Anthony Burzillo, Azeem Bande-Ali, Ben Moon, Bradley Hardy, Eric Seidel, Harry Clarke, Jason Xu, Lukasz Kolodziejczyk, Raoul Charman, TravelTissues, Vaibhav Yenamandra and Ben Orchard - Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,14 @@ # fortran-src ![CI status badge](https://github.com/camfort/fortran-src/actions/workflows/ci.yml/badge.svg) +[![DOI](https://joss.theoj.org/papers/10.21105/joss.07571/status.svg)](https://doi.org/10.21105/joss.07571) -Provides lexing/parsing and early static analyses of Fortran code. The following + +fortran-src is an open-source Haskell library and command-line application for the lexing, parsing, and static analysis of Fortran source code. It provides an interface to build other tools, e.g., for static analysis, automated refactoring, verification, and compilation. + +> To cite this work, or for a high-level overview, please take a look at our paper: [Contrastin et al., (2025). fortran-src: Fortran static analysis infrastructure. Journal of Open Source Software, 10(106), 7571, https://doi.org/10.21105/joss.07571](https://joss.theoj.org/papers/10.21105/joss.07571) + + +The following Fortran standards are covered: * FORTRAN 66 (ANSI X3.9-1966) @@ -13,13 +20,30 @@ Parsing is configurable, and you can select the Fortran standard to target, including special extended modes for nonstandard FORTRAN 77. -Includes data flow and basic block analysis, a renamer, and type analysis. +Various static analyses are provided including: +* Control-flow analysis (building a super graph) (Language.Fortran.Analysis.BBlocks); +* General data flow analyses (Language.Fortran.Analysis.DataFlow), including: +* Reaching definitions; +* Def-use/use-def; +* Constant evaluation; +* Constant propagation; +* Live variable analysis; +* Induction variable analysis. +* Type analysis (Language.Fortran.Analysis.Types); +* Module graph analysis (Language.Fortran.Analysis.ModGraph); + This package primarily exports a Haskell library, but also builds an executable -that can be used for testing and debugging. For example usage, see the -[CamFort](https://github.com/camfort/camfort) project, which uses fortran-src as -its front end. +that can be used for testing and debugging. +The library is the basis of the [CamFort verification tool](https://github.com/camfort/camfort). + +## Statement of Need + +Fortran remains a popular language in the international scientific community. It is not only a mainstay of legacy software, but is also used to write new software. Fortran is particularly notable for its prevalence in earth sciences, e.g., for implementing climate models that inform international policy decisions. In 2024, Fortran re-entered the Top 10 programming languages in the TIOBE Index, showing its enduring popularity. The continued use of Fortran, particularly in scientific contexts, was the catalyst for this software package. A challenge in writing language tools for Fortran is its long history. There have been several major language standards (FORTRAN I-IV, FORTRAN 66 and 77, Fortran 90, 95, 2003, 2008, etc.) Newer standards often deprecate features that are known to be a ready source of errors, or difficult to specify or understand. However, compilers often support an amalgam of features across standards, enabling developers to use deprecated features and mix language standards. This complicates the development of new tools for manipulating Fortran source code; one must tame the weight of decades of language evolution. + +Our package, `fortran-src`, provides an open-source unified core for statically analysing Fortran code across language standards, with a focus on legacy code over cutting-edge modern Fortran. It is both a standalone tool and a library, providing a suite of standard static analyses as a basis for further programming language tools and systems. + ## Obtaining We provide [prebuilt binaries](https://github.com/camfort/fortran-src/releases) for Windows, Mac and Linux. @@ -39,17 +63,24 @@ ``` Usage: fortran-src [OPTION...] - -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90] + --version show fortran-src version + -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/90Legacy/2003] -a ACTION --action=ACTION choose the action, possible values: lex|parse -t --typecheck parse and run typechecker -R --rename parse and rename variables -B --bblocks analyse basic blocks -S --supergraph analyse super graph of basic blocks -r --reprint Parse and output using pretty printer + --split-long when using pretty printer, split long lines via continuations --dot output graphs in GraphViz DOT format --dump-mod-file dump the information contained within mod files + -C[CPP-OPTS] --cpp[=CPP-OPTS] run the C Pre Processor on the Fortran files first -I DIR --include-dir=DIR directory to search for precompiled 'mod files' - -c --compile compile an .fsmod file from the input + -c --summarise, --compile-mod build an .fsmod file from the input + -o FILE --output-file=FILE name of output file (e.g. name of generated fsmod file) + --make-mods, --make determine dependency order of modules and automatically build .fsmod files + --show-make-graph dump a graph showing the build structure of modules + --show-make-list dump a list of files in build dependency order (topological sort from the dependency graph) --show-block-numbers[=LINE-NUM] Show the corresponding AST-block identifier number next to every line of code. --show-flows-to=AST-BLOCK-ID dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph --show-flows-from=AST-BLOCK-ID dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph @@ -70,7 +101,7 @@ Haskell library dependencies are listed in `package.yaml`. fortran-src supports building with Stack or Cabal. -fortran-src supports **GHC 9.0 through GHC 9.2**. We regularly test at least the +fortran-src supports **GHC 9.0 through GHC 9.12** (as of Aug 2025). We regularly test at least the minimum and maximum supported GHCs. Releases prior to/newer than those may have issues. We welcome fixes that would let us support a wider range of compilers. @@ -117,6 +148,16 @@ cabal build ``` +You can leverage cabal to initialize a ghci session, and call the main function like such: + +```shell +cabal repl + +:load app/Main.hs + +:main --version +``` + ### Testing Unit tests are stored in `test`. Run with `stack test` or `cabal test`. @@ -161,3 +202,7 @@ contact with one of the team on the [CamFort team page](https://camfort.github.io/team.html) -- or create an issue describing your problem and we'll have a look. + +### For maintainers +See `doc/maintainers.md` in +[camfort/camfort](https://github.com/camfort/camfort). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -50,15 +50,24 @@ programName :: String programName = "fortran-src" +showVersion :: String +showVersion = "0.16.9" + main :: IO () main = do args <- getArgs (opts, parsedArgs) <- compileArgs args case (parsedArgs, action opts) of + (paths, ShowMyVersion) -> do + putStrLn $ "fortran-src version: " ++ showVersion (paths, ShowMakeGraph) -> do paths' <- expandDirs paths mg <- genModGraph (fortranVersion opts) (includeDirs opts) (cppOptions opts) paths' putStrLn $ modGraphToDOT mg + (paths, ShowMakeList) -> do + paths' <- expandDirs paths + mg <- genModGraph (fortranVersion opts) (includeDirs opts) (cppOptions opts) paths' + mapM_ putStrLn (modGraphToList mg) -- make: construct a build-dep graph and follow it (paths, Make) -> do let mvers = fortranVersion opts @@ -109,7 +118,7 @@ Right a -> a outfmt = outputFormat opts mmap = combinedModuleMap mods - tenv = combinedTypeEnv mods + tenv = stripExtended $ combinedTypeEnv mods pvm = combinedParamVarMap mods let runTypes = analyseAndCheckTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis @@ -134,7 +143,7 @@ Lex -> ioError $ userError $ usageInfo programName options Parse -> pp parsedPF Typecheck -> let (pf, _, errs) = runTypes parsedPF in - printTypeErrors errs >> printTypes (extractTypeEnv pf) + printTypeErrors errs >> printTypes (extractTypeEnvExtended pf) Rename -> pp $ runRenamer parsedPF BBlocks -> putStrLn $ runBBlocks parsedPF SuperGraph -> putStrLn $ runSuperGraph parsedPF @@ -205,48 +214,20 @@ _ -> fail $ usageInfo programName options _ -> fail $ usageInfo programName options --- | Expand all paths that are directories into a list of Fortran --- files from a recursive directory listing. -expandDirs :: [FilePath] -> IO [FilePath] -expandDirs = fmap concat . mapM each - where - each path = do - isDir <- doesDirectoryExist path - if isDir - then listFortranFiles path - else pure [path] --- | Get a list of Fortran files under the given directory. -listFortranFiles :: FilePath -> IO [FilePath] -listFortranFiles dir = filter isFortran <$> listDirectoryRecursively dir - where - -- | True if the file has a valid fortran extension. - isFortran :: FilePath -> Bool - isFortran x = map toLower (takeExtension x) `elem` exts - where exts = [".f", ".f90", ".f77", ".f03"] - -listDirectoryRecursively :: FilePath -> IO [FilePath] -listDirectoryRecursively dir = listDirectoryRec dir "" - where - listDirectoryRec :: FilePath -> FilePath -> IO [FilePath] - listDirectoryRec d f = do - let fullPath = d f - isDir <- doesDirectoryExist fullPath - if isDir - then do - conts <- listDirectory fullPath - concat <$> mapM (listDirectoryRec fullPath) conts - else pure [fullPath] - compileFileToMod :: Maybe FortranVersion -> ModFiles -> FilePath -> Maybe FilePath -> IO ModFile compileFileToMod mvers mods path moutfile = do contents <- flexReadFile path let version = fromMaybe (deduceFortranVersion path) mvers mmap = combinedModuleMap mods - tenv = combinedTypeEnv mods + tenv = stripExtended $ combinedTypeEnv mods runCompile = genModFile . fst . analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis - parsedPF = fromRight' $ (Parser.byVerWithMods mods version) path contents - mod = runCompile parsedPF + parsedPF <- + case (Parser.byVerWithMods mods version) path contents of + Right pf -> return pf + Left err -> do + fail $ "Error parsing " ++ path ++ ": " ++ show err + let mod = runCompile parsedPF fspath = path -<.> modFileSuffix `fromMaybe` moutfile LB.writeFile fspath $ encodeModFile [mod] return mod @@ -314,12 +295,14 @@ showStringMap = showGenericMap showModuleMap :: ModuleMap -> String showModuleMap = concatMap (\ (n, m) -> show n ++ ":\n" ++ (unlines . map (" "++) . lines . showGenericMap $ m)) . M.toList -showTypes :: TypeEnv -> String +showTypes :: TypeEnvExtended -> String showTypes tenv = - flip concatMap (M.toList tenv) $ - \ (name, IDType { idVType = vt, idCType = ct }) -> - printf "%s\t\t%s %s\n" name (drop 1 $ maybe " -" show vt) (drop 2 $ maybe " " show ct) -printTypes :: TypeEnv -> IO () + let sortedInfo = sortBy (\(_, (_, sp1, _)) (_, (_, sp2, _)) -> compare sp1 sp2) $ M.toList tenv + in + flip concatMap sortedInfo $ + \ (_, (name, sp, IDType { idVType = vt, idCType = ct })) -> + printf "%s\t %s\t\t%s %s\n" (show $ ssFrom sp) name (drop 1 $ maybe " -" show vt) (drop 2 $ maybe " " show ct) +printTypes :: TypeEnvExtended -> IO () printTypes = putStrLn . showTypes showTypeErrors :: [TypeError] -> String showTypeErrors errs = unlines [ show ss ++ ": " ++ msg | (msg, ss) <- sortBy (comparing snd) errs ] @@ -328,7 +311,8 @@ data Action = Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile | Compile - | ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) | ShowMakeGraph | Make + | ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) | ShowMakeGraph | ShowMakeList | Make + | ShowMyVersion deriving Eq instance Read Action where @@ -357,10 +341,14 @@ options :: [OptDescr (Options -> Options)] options = - [ Option ['v','F'] + [ Option [] + ["version"] + (NoArg $ \ opts -> opts { action = ShowMyVersion }) + "show fortran-src version" + , Option ['v','F'] ["fortranVersion"] (ReqArg (\v opts -> opts { fortranVersion = selectFortranVersion v }) "VERSION") - "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]" + "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/90Legacy/2003]" , Option ['a'] ["action"] (ReqArg (\a opts -> opts { action = read a }) "ACTION") @@ -423,6 +411,10 @@ ["show-make-graph"] (NoArg $ \ opts -> opts { action = ShowMakeGraph }) "dump a graph showing the build structure of modules" + , Option [] + ["show-make-list"] + (NoArg $ \ opts -> opts { action = ShowMakeList }) + "dump a list of files in build dependency order (topological sort from the dependency graph)" , Option [] ["show-block-numbers"] (OptArg (\a opts -> opts { action = ShowBlocks (a >>= readMaybe) } diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: fortran-src -version: 0.15.1 +version: 0.16.9 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 @@ -15,18 +15,21 @@ Matthew Danish, Dominic Orchard, Andrew Rice -maintainer: me@madgen.net, - Ben Orchard +maintainer: Dominic Orchard license: Apache-2.0 license-file: LICENSE build-type: Simple tested-with: - GHC >= 9.0 + GHC == 9.0, GHC == 9.2, GHC == 9.4, GHC == 9.6, GHC == 9.8, GHC == 9.10, GHC == 9.12 extra-source-files: README.md CHANGELOG.md test-data/f77-include/foo.f test-data/f77-include/no-newline/foo.f + test-data/module/leaf.f90 + test-data/module/mid1.f90 + test-data/module/mid2.f90 + test-data/module/top.f90 test-data/rewriter/replacementsmap-columnlimit/001_foo.f test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected test-data/rewriter/replacementsmap-columnlimit/002_other.f @@ -184,11 +187,11 @@ build-depends: GenericPretty >=1.2.2 && <2 , array ==0.5.* - , base >=4.6 && <5 + , base >=4.6 && <4.22 , binary >=0.8.3.0 && <0.11 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , containers >=0.5 && <0.7 - , deepseq ==1.4.* + , deepseq >=1.4 && <1.6 , directory >=1.2 && <2 , either >=5.0.1.1 && <5.1 , fgl ==5.* @@ -196,11 +199,11 @@ , mtl >=2.2 && <3 , pretty >=1.1 && <2 , process >=1.2.0.0 - , singletons >=3.0 && <3.2 - , singletons-base >=3.0 && <3.2 - , singletons-th >=3.0 && <3.2 + , singletons >=3.0 && <3.6 + , singletons-base >=3.0 && <3.6 + , singletons-th >=3.0 && <3.6 , temporary >=1.2 && <1.4 - , text >=1.2 && <2.1 + , text >=1.2 && <2.2 , uniplate >=1.6 && <2 default-language: Haskell2010 if os(windows) @@ -247,11 +250,11 @@ build-depends: GenericPretty >=1.2.2 && <2 , array ==0.5.* - , base >=4.6 && <5 + , base >=4.6 && <4.22 , binary >=0.8.3.0 && <0.11 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , containers >=0.5 && <0.7 - , deepseq ==1.4.* + , deepseq >=1.4 && <1.6 , directory >=1.2 && <2 , either >=5.0.1.1 && <5.1 , fgl ==5.* @@ -260,11 +263,11 @@ , mtl >=2.2 && <3 , pretty >=1.1 && <2 , process >=1.2.0.0 - , singletons >=3.0 && <3.2 - , singletons-base >=3.0 && <3.2 - , singletons-th >=3.0 && <3.2 + , singletons >=3.0 && <3.6 + , singletons-base >=3.0 && <3.6 + , singletons-th >=3.0 && <3.6 , temporary >=1.2 && <1.4 - , text >=1.2 && <2.1 + , text >=1.2 && <2.2 , uniplate >=1.6 && <2 default-language: Haskell2010 if os(windows) @@ -276,6 +279,8 @@ other-modules: Language.Fortran.Analysis.BBlocksSpec Language.Fortran.Analysis.DataFlowSpec + Language.Fortran.Analysis.ModFileSpec + Language.Fortran.Analysis.ModGraphSpec Language.Fortran.Analysis.RenamingSpec Language.Fortran.Analysis.SemanticTypesSpec Language.Fortran.Analysis.TypesSpec @@ -343,11 +348,11 @@ GenericPretty >=1.2.2 && <2 , QuickCheck >=2.10 && <2.15 , array ==0.5.* - , base >=4.6 && <5 + , base >=4.6 && <4.22 , binary >=0.8.3.0 && <0.11 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , containers >=0.5 && <0.7 - , deepseq ==1.4.* + , deepseq >=1.4 && <1.6 , directory >=1.2 && <2 , either >=5.0.1.1 && <5.1 , fgl ==5.* @@ -357,11 +362,11 @@ , mtl >=2.2 && <3 , pretty >=1.1 && <2 , process >=1.2.0.0 - , singletons >=3.0 && <3.2 - , singletons-base >=3.0 && <3.2 - , singletons-th >=3.0 && <3.2 + , singletons >=3.0 && <3.6 + , singletons-base >=3.0 && <3.6 + , singletons-th >=3.0 && <3.6 , temporary >=1.2 && <1.4 - , text >=1.2 && <2.1 + , text >=1.2 && <2.2 , uniplate >=1.6 && <2 default-language: Haskell2010 if os(windows) 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. @@ -95,7 +95,7 @@ | p' == 'x' = Just $ BozPrefixZ Nonconforming | otherwise = Nothing where p' = Char.toLower p - errInvalid = error "Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string" + errInvalid = error ("Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string: " <> show s) -- | Remove the first and last elements in a list. shave = tail . init 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,10 +3,11 @@ -- | -- 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(..), IDType(..), ConstructType(..) + , ModEnv, NameType(..), Locality(..), markAsImported, isImported + , IDType(..), ConstructType(..) , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars , blockVarUses, blockVarDefs , BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty @@ -77,9 +78,30 @@ type TransFuncM m f g a = (f (Analysis a) -> m (f (Analysis a))) -> g (Analysis a) -> m (g (Analysis a)) -- Describe a Fortran name as either a program unit or a variable. -data NameType = NTSubprogram | NTVariable | NTIntrinsic deriving (Show, Eq, Ord, Data, Typeable, Generic) +data Locality = + Local -- locally declared + | Imported -- declared in an imported module + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +data NameType = NTSubprogram Locality | NTVariable Locality | NTIntrinsic + deriving (Show, Eq, Ord, Data, Typeable, Generic) + instance Binary NameType instance Out NameType + +instance Binary Locality +instance Out Locality + +-- Mark any variables as being imported +markAsImported :: NameType -> NameType +markAsImported (NTVariable _) = NTVariable Imported +markAsImported (NTSubprogram _) = NTSubprogram Imported +markAsImported x = x + +isImported :: NameType -> Bool +isImported (NTVariable Imported) = True +isImported (NTSubprogram Imported) = True +isImported _ = False -- Module environments are associations between source name and -- (unique name, name type) in a specific module. diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs --- a/src/Language/Fortran/Analysis/BBlocks.hs +++ b/src/Language/Fortran/Analysis/BBlocks.hs @@ -13,6 +13,7 @@ import Control.Monad import Control.Monad.State.Lazy hiding (fix) import Control.Monad.Writer hiding (fix) +import Control.Monad ( forM_ ) -- required for mtl-2.3 (GHC 9.6) import Text.PrettyPrint.GenericPretty (pretty, Out) import Text.PrettyPrint (render) import Language.Fortran.Analysis 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 @@ -42,6 +42,7 @@ import Data.Maybe import Data.List (foldl', foldl1', (\\), union, intersect) import Control.Monad.Writer hiding (fix) +import Control.Monad -- required for mtl-2.3 (GHC 9.6) import qualified Language.Fortran.Repr as Repr import qualified Language.Fortran.Repr.Eval.Value as Repr @@ -368,31 +369,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/Analysis/ModGraph.hs b/src/Language/Fortran/Analysis/ModGraph.hs --- a/src/Language/Fortran/Analysis/ModGraph.hs +++ b/src/Language/Fortran/Analysis/ModGraph.hs @@ -1,6 +1,6 @@ -- | Generate a module use-graph. module Language.Fortran.Analysis.ModGraph - (genModGraph, ModGraph(..), ModOrigin(..), modGraphToDOT, takeNextMods, delModNodes) + (genModGraph, ModGraph(..), ModOrigin(..), modGraphToList, modGraphToDOT, takeNextMods, delModNodes) where import Language.Fortran.AST hiding (setName) @@ -10,13 +10,12 @@ import Language.Fortran.Util.Files import Prelude hiding (mod) -import Control.Monad import Control.Monad.State.Strict +import Control.Monad ( forM_ ) -- required for mtl-2.3 (GHC 9.6) import Data.Data import Data.Generics.Uniplate.Data import Data.Graph.Inductive hiding (version) import Data.Maybe -import Data.Either.Combinators ( fromRight' ) import qualified Data.Map as M -------------------------------------------------- @@ -85,16 +84,28 @@ let version = fromMaybe (deduceFortranVersion path) mversion mods = map snd fileMods parserF0 = Parser.byVerWithMods mods version - parserF fn bs = fromRight' $ parserF0 fn bs + parserF fn bs = + case parserF0 fn bs of + Right x -> return x + Left err -> do + error $ show err forM_ fileMods $ \ (fileName, mod) -> do forM_ [ name | Named name <- M.keys (combinedModuleMap [mod]) ] $ \ name -> do _ <- maybeAddModName name . Just $ MOFSMod fileName pure () - let pf = parserF path contents + pf <- parserF path contents mapM_ (perModule path) (childrenBi pf :: [ProgramUnit ()]) pure () execStateT (mapM_ iter paths) modGraph0 +-- Remove duplicates from a list preserving the left most occurrence. +removeDuplicates :: Eq a => [a] -> [a] +removeDuplicates [] = [] +removeDuplicates (x:xs) = + if x `elem` xs + then x : removeDuplicates (filter (/= x) xs) + else x : removeDuplicates xs + modGraphToDOT :: ModGraph -> String modGraphToDOT ModGraph { mgGraph = gr } = unlines dot where @@ -107,6 +118,18 @@ ["}\n"]) (labNodes gr) ++ [ "}\n" ] + +-- Provides a topological sort of the graph, giving a list of filenames +modGraphToList :: ModGraph -> [String] +modGraphToList m = removeDuplicates $ modGraphToList' m + where + modGraphToList' mg + | nxt <- takeNextMods mg + , not (null nxt) = + let mg' = delModNodes (map fst nxt) mg + in [ fn | (_, Just (MOFile fn)) <- nxt ] ++ modGraphToList' mg' + modGraphToList' _ = [] + takeNextMods :: ModGraph -> [(Node, Maybe ModOrigin)] takeNextMods ModGraph { mgModNodeMap = mnmap, mgGraph = gr } = noDepFiles diff --git a/src/Language/Fortran/Analysis/Renaming.hs b/src/Language/Fortran/Analysis/Renaming.hs --- a/src/Language/Fortran/Analysis/Renaming.hs +++ b/src/Language/Fortran/Analysis/Renaming.hs @@ -20,6 +20,7 @@ import Data.Map (insert, empty, lookup, Map) import qualified Data.Map.Strict as M import Control.Monad.State.Strict +import Control.Monad -- required for mtl-2.3 (GHC 9.6) import Data.Generics.Uniplate.Data import Data.Data import Data.Functor.Identity (Identity) @@ -120,7 +121,7 @@ blocks3 <- mapM renameDeclDecls blocks2 -- handle declarations m_contains' <- renameSubPUs m_contains -- handle contained program units blocks4 <- mapM renameBlock blocks3 -- process all uses of variables - let env = M.singleton name (name', NTSubprogram) + let env = M.singleton name (name', NTSubprogram Local) let a' = a { moduleEnv = Just env } -- also annotate it on the program unit popScope let pu' = PUFunction a' s ty rec name args' res' blocks4 m_contains' @@ -133,7 +134,7 @@ blocks2 <- mapM renameDeclDecls blocks1 -- handle declarations m_contains' <- renameSubPUs m_contains -- handle contained program units blocks3 <- mapM renameBlock blocks2 -- process all uses of variables - let env = M.singleton name (name', NTSubprogram) + let env = M.singleton name (name', NTSubprogram Local) let a' = a { moduleEnv = Just env } -- also annotate it on the program unit popScope let pu' = PUSubroutine a' s rec name args' blocks3 m_contains' @@ -230,10 +231,16 @@ mMap <- gets moduleMap modEnv <- fmap M.unions . forM uses $ \ use -> case use of (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ Nothing)) -> - return $ fromMaybe empty (Named m `lookup` mMap) + let + env = fromMaybe empty (Named m `lookup` mMap) + -- mark as imported all the local things from this module + in return $ M.map (\ (v, info) -> (v, markAsImported info)) env + (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ (Just onlyAList))) | only <- aStrip onlyAList -> do let env = fromMaybe empty (Named m `lookup` mMap) + -- mark as imported all the local things from this module + env <- return $ M.map (\ (v, info) -> (v, markAsImported info)) env -- list of (local name, original name) from USE declaration: let localNamePairs = flip mapMaybe only $ \ r -> case r of UseID _ _ v@(ExpValue _ _ ValVariable{}) -> Just (varName v, varName v) @@ -253,7 +260,7 @@ -- Include any mappings defined by COMMON blocks: use variable -- source name prefixed by name of COMMON block. - let common = M.fromList [ (v, (v', NTVariable)) + let common = M.fromList [ (v, (v', NTVariable Local)) | CommonGroup _ _ me1 alist <- universeBi blocks :: [CommonGroup (Analysis a)] , let prefix = case me1 of Just e1 -> srcName e1; _ -> "" , e@(ExpValue _ _ ValVariable{}) <- universeBi (aStrip alist) :: [Expression (Analysis a)] @@ -325,9 +332,9 @@ getFromEnvsIfSubprogram v = do mEntry <- getFromEnvsWithType v case mEntry of - Just (v', NTSubprogram) -> return $ Just v' - Just (_, NTVariable) -> getFromEnv v - _ -> return Nothing + Just (v', NTSubprogram _) -> return $ Just v' + Just (_, NTVariable _) -> getFromEnv v + _ -> return Nothing -- Add a renaming mapping to the environment. addToEnv :: String -> String -> NameType -> Renamer () @@ -372,10 +379,10 @@ -- to the environment. skimProgramUnits :: Data a => [ProgramUnit (Analysis a)] -> Renamer () skimProgramUnits pus = forM_ pus $ \ pu -> case pu of - PUModule _ _ name _ _ -> addToEnv name name NTSubprogram - PUFunction _ _ _ _ name _ _ _ _ -> addUnique_ name NTSubprogram - PUSubroutine _ _ _ name _ _ _ -> addUnique_ name NTSubprogram - PUMain _ _ (Just name) _ _ -> addToEnv name name NTSubprogram + PUModule _ _ name _ _ -> addToEnv name name (NTSubprogram Local) + PUFunction _ _ _ _ name _ _ _ _ -> addUnique_ name (NTSubprogram Local) + PUSubroutine _ _ _ name _ _ _ -> addUnique_ name (NTSubprogram Local) + PUMain _ _ (Just name) _ _ -> addToEnv name name (NTSubprogram Local) _ -> return () ---------- @@ -394,7 +401,8 @@ -- declaration that possibly requires the creation of a new unique -- mapping. renameExpDecl :: Data a => RenamerFunc (Expression (Analysis a)) -renameExpDecl e@(ExpValue _ _ (ValVariable v)) = flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTVariable +renameExpDecl e@(ExpValue _ _ (ValVariable v)) = + flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v (NTVariable Local) -- Intrinsics get unique names for each use. renameExpDecl e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic renameExpDecl e = return e @@ -407,7 +415,7 @@ interface :: Data a => RenamerFunc (Block (Analysis a)) interface (BlInterface a s (Just e@(ExpValue _ _ (ValVariable v))) abst pus bs) = do - e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTSubprogram + e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v (NTSubprogram Local) pure $ BlInterface a s (Just e') abst pus bs interface b = pure b diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs --- a/src/Language/Fortran/Analysis/SemanticTypes.hs +++ b/src/Language/Fortran/Analysis/SemanticTypes.hs @@ -66,7 +66,7 @@ TLogical k -> "logical"<>pd k TByte k -> "byte"<>pd k TCharacter _ _ -> "character(TODO)" - TArray st dims -> pprint' v st <> pprint' v dims + TArray st dims -> pprint' v st <> pdims v dims TCustom str -> pprint' v (TypeCustom str) | otherwise = \case TInteger k -> "integer"<>ad k @@ -75,11 +75,13 @@ TLogical k -> "logical"<>ad k TByte k -> "byte"<>ad k TCharacter _ _ -> "character*TODO" - TArray st dims -> pprint' v st <> pprint' v dims + TArray st dims -> pprint' v st <> pdims v dims TCustom str -> pprint' v (TypeCustom str) where pd = Pretty.parens . doc ad k = doc '*' <> doc k + pdims v dims = maybe Pretty.empty (pprint' v) (dimsTraverse dims) + -- | Convert 'Dimensions' data type to its previous type synonym -- @(Maybe [(Int, Int)])@. diff --git a/src/Language/Fortran/Analysis/Types.hs b/src/Language/Fortran/Analysis/Types.hs --- a/src/Language/Fortran/Analysis/Types.hs +++ b/src/Language/Fortran/Analysis/Types.hs @@ -2,8 +2,11 @@ ( analyseTypes , analyseTypesWithEnv , analyseAndCheckTypesWithEnv + , stripExtended , extractTypeEnv + , extractTypeEnvExtended , TypeEnv + , TypeEnvExtended , TypeError , deriveSemTypeFromDeclaration , deriveSemTypeFromTypeSpec @@ -23,6 +26,7 @@ import Data.List (find, foldl') import Control.Monad.State.Strict import Control.Monad.Reader +import Control.Monad -- required for mtl-2.3 (GHC 9.6) import Data.Generics.Uniplate.Data import Data.Data import Language.Fortran.Analysis @@ -35,7 +39,12 @@ -- | Mapping of names to type information. type TypeEnv = M.Map Name IDType +-- | Mapping of names to type information with more information about the source +type TypeEnvExtended = M.Map Name (Name, SrcSpan, IDType) +stripExtended :: TypeEnvExtended -> TypeEnv +stripExtended = M.map (\(_, _, t) -> t) + -- | Information about a detected type error. type TypeError = (String, SrcSpan) @@ -119,6 +128,24 @@ expEnv = M.fromList [ (n, ty) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)] , let n = varName e , ty <- maybeToList (idType (getAnnotation e)) ] + +extractTypeEnvExtended :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnvExtended +extractTypeEnvExtended pf = M.union puEnv expEnv + where + puEnv = M.fromList [ (n, (srcName, getSpan pu, ty)) | pu <- universeBi pf :: [ProgramUnit (Analysis a)] + , Named n <- [puName pu] + , Named srcName <- [puSrcName pu] + , ty <- maybeToList (idType (getAnnotation pu)) ] + expEnv = M.fromList [ (n, (srcName e, sp, ty)) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)] + , let n = varName e + , sp <- getDeclarator n + , ty <- maybeToList (idType (getAnnotation e)) ] + getDeclarator v' = + [ sp | d@(Declarator _ sp ev _ _ _) <- universeBi pf :: [Declarator (Analysis a)] + , varName ev == v' ] + + + type TransType f g a = (f (Analysis a) -> Infer (f (Analysis a))) -> g (Analysis a) -> Infer (g (Analysis a)) annotateTypes :: Data a => ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a)) diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs --- a/src/Language/Fortran/Parser.hs +++ b/src/Language/Fortran/Parser.hs @@ -17,12 +17,12 @@ , f66, f77, f77e, f77l, f90, f95, f2003 -- * Main parsers without post-parse transformation + , byVerNoTransform , f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform , f90NoTransform, f95NoTransform, f2003NoTransform -- * Other parsers , f90Expr - , f77lIncludesNoTransform , byVerFromFilename -- ** Statement @@ -30,6 +30,10 @@ , f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform , f77lStmtNoTransform, f90StmtNoTransform, f95StmtNoTransform , f2003StmtNoTransform + , byVerInclude + , f66IncludesNoTransform, f77IncludesNoTransform, f77eIncludesNoTransform + , f77lIncludesNoTransform, f90IncludesNoTransform, f95IncludesNoTransform + , f2003IncludesNoTransform -- * Various combinators , transformAs, defaultTransformation @@ -43,7 +47,10 @@ -- * F77 with inlined includes -- $f77includes - , f77lInlineIncludes + , byVerInlineIncludes + , f66InlineIncludes, f77InlineIncludes, f77eInlineIncludes + , f77lInlineIncludes, f90InlineIncludes , f95InlineIncludes + , f2003InlineIncludes ) where import Language.Fortran.AST @@ -175,6 +182,18 @@ v -> error $ "Language.Fortran.Parser.byVerStmt: " <> "no parser available for requested version: " <> show v +byVerNoTransform :: FortranVersion -> Parser (ProgramFile A0) +byVerNoTransform = \case + Fortran66 -> f66NoTransform + Fortran77 -> f77NoTransform + Fortran77Legacy -> f77lNoTransform + Fortran77Extended -> f77eNoTransform + Fortran90 -> f90NoTransform + Fortran95 -> f90NoTransform + Fortran2003 -> f2003NoTransform + v -> error $ "Language.Fortran.Parser.byVerNoTransform: " + <> "no parser available for requested version: " + <> show v f90Expr :: Parser (Expression A0) f90Expr = makeParser initParseStateFreeExpr F90.expressionParser Fortran90 @@ -291,35 +310,47 @@ Can be cleaned up and generalized to use for other parsers. -} -f77lInlineIncludes - :: [FilePath] -> ModFiles -> String -> B.ByteString +f66InlineIncludes, f77InlineIncludes, f77eInlineIncludes, f77lInlineIncludes, + f90InlineIncludes, f95InlineIncludes, f2003InlineIncludes + :: [FilePath] -> ModFiles -> String -> B.ByteString -> IO (ProgramFile A0) +f66InlineIncludes = byVerInlineIncludes Fortran66 +f77lInlineIncludes = byVerInlineIncludes Fortran77Legacy +f77eInlineIncludes = byVerInlineIncludes Fortran77Extended +f77InlineIncludes = byVerInlineIncludes Fortran77 +f90InlineIncludes = byVerInlineIncludes Fortran90 +f95InlineIncludes = byVerInlineIncludes Fortran95 +f2003InlineIncludes = byVerInlineIncludes Fortran2003 + +byVerInlineIncludes + :: FortranVersion -> [FilePath] -> ModFiles -> String -> B.ByteString -> IO (ProgramFile A0) -f77lInlineIncludes incs mods fn bs = do - case f77lNoTransform fn bs of - Left e -> liftIO $ throwIO e - Right pf -> do - let pf' = pfSetFilename fn pf - pf'' <- evalStateT (descendBiM (f77lInlineIncludes' incs []) pf') Map.empty - let pf''' = runTransform (combinedTypeEnv mods) - (combinedModuleMap mods) - (defaultTransformation Fortran77Legacy) - pf'' - return pf''' +byVerInlineIncludes version incs mods fn bs = do + case byVerNoTransform version fn bs of + Left e -> liftIO $ throwIO e + Right pf -> do + let pf' = pfSetFilename fn pf + pf'' <- evalStateT (descendBiM (parserInlineIncludes version incs []) pf') Map.empty + let pf''' = runTransform (combinedTypeEnv mods) + (combinedModuleMap mods) + (defaultTransformation version) + pf'' + return pf''' -f77lInlineIncludes' - :: [FilePath] -> [FilePath] -> Statement A0 +-- Internal function to go through the includes and inline them +parserInlineIncludes + :: FortranVersion -> [FilePath] -> [FilePath] -> Statement A0 -> StateT (Map String [Block A0]) IO (Statement A0) -f77lInlineIncludes' dirs = go +parserInlineIncludes version dirs = go where go seen st = case st of StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do - if notElem path seen then do + if path `notElem` seen then do incMap <- get case Map.lookup path incMap of Just blocks' -> pure $ StInclude a s e (Just blocks') Nothing -> do (fullPath, incBs) <- liftIO $ readInDirs dirs path - case f77lIncludesNoTransform fullPath incBs of + case byVerInclude version fullPath incBs of Right blocks -> do blocks' <- descendBiM (go (path:seen)) blocks modify (Map.insert path blocks') @@ -328,8 +359,30 @@ else pure st _ -> pure st -f77lIncludesNoTransform :: Parser [Block A0] +f66IncludesNoTransform, f77IncludesNoTransform, f77eIncludesNoTransform, + f77lIncludesNoTransform, f90IncludesNoTransform, f95IncludesNoTransform, + f2003IncludesNoTransform + :: Parser [Block A0] +f66IncludesNoTransform = makeParserFixed F66.includesParser Fortran66 +f77IncludesNoTransform = makeParserFixed F77.includesParser Fortran77 +f77eIncludesNoTransform = makeParserFixed F77.includesParser Fortran77Extended f77lIncludesNoTransform = makeParserFixed F77.includesParser Fortran77Legacy +f90IncludesNoTransform = makeParserFree F90.includesParser Fortran90 +f95IncludesNoTransform = makeParserFree F95.includesParser Fortran95 +f2003IncludesNoTransform = makeParserFree F2003.includesParser Fortran2003 + +byVerInclude :: FortranVersion -> Parser [Block A0] +byVerInclude = \case + Fortran66 -> f66IncludesNoTransform + Fortran77 -> f77IncludesNoTransform + Fortran77Extended -> f77eIncludesNoTransform + Fortran77Legacy -> f77lIncludesNoTransform + Fortran90 -> f90IncludesNoTransform + Fortran95 -> f95IncludesNoTransform + Fortran2003 -> f2003IncludesNoTransform + v -> error $ "Language.Fortran.Parser.byVerInclude: " + <> "no parser available for requested version: " + <> show v readInDirs :: [String] -> String -> IO (String, B.ByteString) readInDirs [] f = fail $ "cannot find file: " ++ f diff --git a/src/Language/Fortran/Parser/Fixed/Fortran66.y b/src/Language/Fortran/Parser/Fixed/Fortran66.y --- a/src/Language/Fortran/Parser/Fixed/Fortran66.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran66.y @@ -6,6 +6,7 @@ , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -25,6 +26,7 @@ %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -138,6 +140,9 @@ | {- Nothing -} { Nothing } NAME :: { Name } : id { let (TId _ name) = $1 in name } + +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } diff --git a/src/Language/Fortran/Parser/Fixed/Fortran77.y b/src/Language/Fortran/Parser/Fixed/Fortran77.y --- a/src/Language/Fortran/Parser/Fixed/Fortran77.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran77.y @@ -467,8 +467,12 @@ | dimension INITIALIZED_ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) } | common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) } | equivalence EQUIVALENCE_GROUPS { StEquivalence () (getTransSpan $1 $2) (aReverse $2) } -| pointer POINTER_LIST { StPointer () (getTransSpan $1 $2) (fromReverseList $2) } -| data DATA_GROUPS { StData () (getTransSpan $1 $2) (fromReverseList $2) } +| pointer POINTER_LIST + { let pl = fromReverseList $2 + in StPointer () (getTransSpan $1 pl) pl } +| data DATA_GROUPS + { let dgs = fromReverseList $2 + in StData () (getTransSpan $1 dgs) dgs } | automatic INITIALIZED_DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) } | static INITIALIZED_DECLARATORS { StStatic () (getTransSpan $1 $2) (aReverse $2) } -- Following is a fake node to make arbitrary FORMAT statements parsable. diff --git a/src/Language/Fortran/Parser/Fixed/Lexer.x b/src/Language/Fortran/Parser/Fixed/Lexer.x --- a/src/Language/Fortran/Parser/Fixed/Lexer.x +++ b/src/Language/Fortran/Parser/Fixed/Lexer.x @@ -30,7 +30,7 @@ import Language.Fortran.Version import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position -import Language.Fortran.Parser.LexerUtils ( readIntOrBoz ) +import Language.Fortran.Parser.LexerUtils ( readIntOrBoz, unescapeSpecialChars ) import Language.Fortran.AST.Literal.Boz } @@ -1128,7 +1128,7 @@ AlexEOF -> return $ TEOF $ SrcSpan (getPos alexInput) (getPos alexInput) AlexError _ -> do parseState <- get - fail $ psFilename parseState ++ " - lexing failed: " ++ show (psAlexInput parseState) + fail $ psFilename parseState ++ " - lexing failed: " ++ (unescapeSpecialChars $ show (psAlexInput parseState)) AlexSkip newAlex _ -> putAlex newAlex >> lexer' AlexToken newAlex _ action -> do putAlex newAlex diff --git a/src/Language/Fortran/Parser/Free/Fortran2003.y b/src/Language/Fortran/Parser/Free/Fortran2003.y --- a/src/Language/Fortran/Parser/Free/Fortran2003.y +++ b/src/Language/Fortran/Parser/Free/Fortran2003.y @@ -7,6 +7,7 @@ , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -28,6 +29,7 @@ %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -349,6 +351,9 @@ : IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } @@ -578,9 +583,9 @@ | save { StSave () (getSpan $1) Nothing } -- according to IBM F2003 docs, dcolon is always required -| procedure '(' MAYBE_PROC_INTERFACE ')' ATTRIBUTE_LIST '::' PROC_DECLS +| procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_ATTRIBUTE_LIST '::' PROC_DECLS { let declAList = fromReverseList $7 - in StProcedure () (getTransSpan $1 $7) $3 (Just (fromReverseList $5)) declAList } + in StProcedure () (getTransSpan $1 $7) $3 $5 declAList } | dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST { let declAList = fromReverseList $3 @@ -1032,6 +1037,14 @@ | TYPE_SPEC INITIALIZED_DECLARATOR_LIST { let { declAList = fromReverseList $2 } in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } + +MAYBE_ATTRIBUTE_LIST :: { Maybe (AList Attribute A0) } +: ',' NE_ATTRIBUTE_LIST { Just $ fromReverseList $2 } +| {- EMPTY -} { Nothing } + +NE_ATTRIBUTE_LIST :: { [ Attribute A0 ] } +: NE_ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 } +| ATTRIBUTE_SPEC { [ $1 ] } ATTRIBUTE_LIST :: { [ Attribute A0 ] } : ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 } diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -7,6 +7,7 @@ , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -20,6 +21,7 @@ import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Either ( partitionEithers ) import qualified Data.List as List +import Data.Maybe ( fromJust, isNothing, isJust ) } @@ -27,6 +29,7 @@ %name functionParser SUBPROGRAM_UNIT %name blockParser BLOCK %name statementParser STATEMENT +%name includesParser INCLUDES %name expressionParser EXPRESSION %monad { LexAction } %lexer { lexer } { TEOF _ } @@ -85,6 +88,14 @@ endBlockData { TEndBlockData _ } module { TModule _ } endModule { TEndModule _ } + structure { TStructure _ } + union { TUnion _ } + map { TMap _ } + endstructure { TEndStructure _ } + endunion { TEndUnion _ } + endmap { TEndMap _ } + automatic { TAutomatic _ } + static { TStatic _ } contains { TContains _ } use { TUse _ } only { TOnly _ } @@ -296,6 +307,9 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } @@ -523,6 +537,43 @@ -- Must be fixed in the future. TODO | format blob { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } +| structure MAYBE_NAME NEWLINE STRUCTURE_DECLARATIONS endstructure + { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) } +| automatic INITIALIZED_DECLARATOR_LIST + { let alist = fromReverseList $2 + in StAutomatic () (getTransSpan $1 alist) alist } +| static INITIALIZED_DECLARATOR_LIST + { let alist = fromReverseList $2 + in StStatic () (getTransSpan $1 alist) alist } + +MAYBE_NAME :: { Maybe Name } +: '/' NAME '/' { Just $2 } +| {- empty -} { Nothing } + +STRUCTURE_DECLARATIONS :: { [StructureItem A0] } +: STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT + { if isNothing $2 then $1 else fromJust $2 : $1 } +| STRUCTURE_DECLARATION_STATEMENT { if isNothing $1 then [] else [fromJust $1] } + +STRUCTURE_DECLARATION_STATEMENT :: { Maybe (StructureItem A0) } +: DECLARATION_STATEMENT NEWLINE + { let StDeclaration () s t attrs decls = $1 + in Just $ StructFields () s t attrs decls } +| union NEWLINE UNION_MAPS endunion NEWLINE + { Just $ StructUnion () (getTransSpan $1 $5) (fromReverseList $3) } +| structure MAYBE_NAME NAME NEWLINE STRUCTURE_DECLARATIONS endstructure NEWLINE + { Just $ StructStructure () (getTransSpan $1 $7) $2 $3 (fromReverseList $5) } +| comment NEWLINE { Nothing } + +UNION_MAPS :: { [ UnionMap A0 ] } +: UNION_MAPS UNION_MAP { if isNothing $2 then $1 else fromJust $2 : $1 } +| UNION_MAP { if isNothing $1 then [] else [fromJust $1] } + +UNION_MAP :: { Maybe (UnionMap A0) } +: map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE + { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } +| comment NEWLINE { Nothing } + EXECUTABLE_STATEMENT :: { Statement A0 } : allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' diff --git a/src/Language/Fortran/Parser/Free/Fortran95.y b/src/Language/Fortran/Parser/Free/Fortran95.y --- a/src/Language/Fortran/Parser/Free/Fortran95.y +++ b/src/Language/Fortran/Parser/Free/Fortran95.y @@ -7,6 +7,7 @@ , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -28,6 +29,7 @@ %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -304,6 +306,9 @@ : end { $1 } | endInterface { $1 } | endInterface id { $2 } NAME :: { Name } : id { let (TId _ name) = $1 in name } + +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } diff --git a/src/Language/Fortran/Parser/Free/Lexer.x b/src/Language/Fortran/Parser/Free/Lexer.x --- a/src/Language/Fortran/Parser/Free/Lexer.x +++ b/src/Language/Fortran/Parser/Free/Lexer.x @@ -51,9 +51,9 @@ @label = $digit{1,5} @name = $letter $alphanumeric* -@binary = b\'$bit+\' -@octal = o\'$octalDigit+\' -@hex = z\'$hexDigit+\' +@binary = b\'$bit+\' | \'$bit+\'b +@octal = o\'$octalDigit+\' | \'$octalDigit+\'o +@hex = [xz]\'$hexDigit+\' | \'$hexDigit+\'[xz] @digitString = $digit+ @kindParam = (@digitString|@name) @@ -146,6 +146,14 @@ <0,scI> "return" { addSpan TReturn } <0> "entry" { addSpan TEntry } <0> "include" { addSpan TInclude } +<0> "structure" / { legacy90P } { addSpan TStructure } +<0> "end"\ *"structure" / { legacy90P } { addSpan TEndStructure } +<0> "union" / { legacy90P } { addSpan TUnion } +<0> "end"\ *"union" / { legacy90P } { addSpan TEndUnion } +<0> "map" { addSpan TMap } +<0> "end"\ *"map" { addSpan TEndMap } +<0> "automatic" / { legacy90P } { addSpan TAutomatic } +<0> "static" / { legacy90P } { addSpan TStatic } -- Type def related <0,scT> "type" { addSpan TType } @@ -450,11 +458,20 @@ | fillConstr TRightPar == toConstr tok = n - 1 | otherwise = n +-- Detect whether the current line is part of an allocate statement +-- (which may be prepended with other tokens, e.g., if this is an `if` statement +-- with aan allocate statement inside on a single line). +allocateStatement :: [Token] -> Maybe [Token] +allocateStatement (hd1:hd2:rest) + | toConstr hd1 `elem` [fillConstr TAllocate, fillConstr TDeallocate] + , toConstr hd2 == fillConstr TLeftPar + = Just rest + | otherwise = allocateStatement (hd2:rest) +allocateStatement _ = Nothing + allocateP :: User -> AlexInput -> Int -> AlexInput -> Bool allocateP _ _ _ ai - | alloc:lpar:rest <- prevTokens - , toConstr alloc `elem` [fillConstr TAllocate, fillConstr TDeallocate] - , fillConstr TLeftPar == toConstr lpar + | Just rest <- allocateStatement (prevTokens) = null rest || (followsComma && parenLevel prevTokens == 1) | otherwise = False where @@ -634,6 +651,9 @@ -- Lexer helpers -------------------------------------------------------------------------------- +legacy90P :: User -> AlexInput -> Int -> AlexInput -> Bool +legacy90P (User fv _) _ _ _ = fv == Fortran90Legacy + adjustComment :: LexAction (Maybe Token) -> LexAction (Maybe Token) adjustComment action = do mTok <- action @@ -1105,20 +1125,28 @@ processLinePragma :: String -> AlexInput -> AlexInput processLinePragma m ai = - case dropWhile ((`elem` ["#", "line", "#line"]) . map toLower) (words m) of - -- 'line' pragma - rewrite the current line and filename - lineStr:otherWords - | line <- readIntOrBoz lineStr -> do - let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"") - let file = revdropWNQ . revdropWNQ $ unwords otherWords - -- if a newline is present, then the aiPosition is already on the next line - let maybe1 | elem '\n' m = 0 | otherwise = 1 - -- lineOffs is the difference between the given line and the current next line - let lineOffs = fromIntegral line - (posLine (aiPosition ai) + maybe1) - let newP = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file) - , posColumn = 1 } - ai { aiPosition = newP } - _ -> ai + let wordsm = words m + isLinePragma x = x `elem` ["#", "line", "#line"] + in -- If this is a line pragma then process this + if length wordsm > 0 && isLinePragma (head wordsm) + || (length wordsm > 1 && isLinePragma (head (tail wordsm))) + then + case dropWhile ((`elem` ["#", "line", "#line"]) . map toLower) wordsm of + -- 'line' pragma - rewrite the current line and filename + lineStr:otherWords + | line <- readIntOrBoz lineStr -> do + let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"") + let file = revdropWNQ . revdropWNQ $ unwords otherWords + -- if a newline is present, then the aiPosition is already on the next line + let maybe1 | elem '\n' m = 0 | otherwise = 1 + -- lineOffs is the difference between the given line and the current next line + let lineOffs = fromIntegral line - (posLine (aiPosition ai) + maybe1) + let newP = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file) + , posColumn = 1 } + ai { aiPosition = newP } + _ -> ai + -- Otherwise this is probably a CPP directive or some other pragma so ignore + else ai -- Handle pragmas that begin with # lexHash :: LexAction (Maybe Token) @@ -1244,6 +1272,14 @@ | TReturn SrcSpan | TEntry SrcSpan | TInclude SrcSpan + | TStructure SrcSpan + | TEndStructure SrcSpan + | TUnion SrcSpan + | TEndUnion SrcSpan + | TMap SrcSpan + | TEndMap SrcSpan + | TAutomatic SrcSpan + | TStatic SrcSpan -- language-binding-spec | TBind SrcSpan | TC SrcSpan diff --git a/src/Language/Fortran/Parser/LexerUtils.hs b/src/Language/Fortran/Parser/LexerUtils.hs --- a/src/Language/Fortran/Parser/LexerUtils.hs +++ b/src/Language/Fortran/Parser/LexerUtils.hs @@ -1,5 +1,5 @@ {-| Utils for both lexers. -} -module Language.Fortran.Parser.LexerUtils ( readIntOrBoz ) where +module Language.Fortran.Parser.LexerUtils ( readIntOrBoz, unescapeSpecialChars) where import Language.Fortran.AST.Literal.Boz import Numeric @@ -16,3 +16,17 @@ readSToMaybe :: [(a, b)] -> Maybe a readSToMaybe = \case (x, _):_ -> Just x _ -> Nothing + + +-- | Pretty prints exception message that contains things like carriage return, indents, etc. +unescapeSpecialChars :: String -> String +unescapeSpecialChars [] = [] +unescapeSpecialChars ('\\' : c : rest) = + case c of + 'n' -> '\n' : unescapeSpecialChars rest + 't' -> '\t' : unescapeSpecialChars rest + 'r' -> '\r' : unescapeSpecialChars rest + '\\' -> '\\' : unescapeSpecialChars rest + _ -> '\\' : c : unescapeSpecialChars rest +unescapeSpecialChars (c : rest) = + c : unescapeSpecialChars rest diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -5,6 +5,7 @@ import Data.Maybe (isJust, isNothing, listToMaybe) import Data.List (foldl') +import qualified Data.List as List import Prelude hiding (EQ,LT,GT,pred,exp,(<>)) @@ -16,11 +17,6 @@ import Text.PrettyPrint -tooOld :: FortranVersion -> String -> FortranVersion -> a -tooOld currentVersion featureName featureVersion = prettyError $ - featureName ++ " was introduced in " ++ show featureVersion ++ - ". You called pretty print with " ++ show currentVersion ++ "." - -- | Continue only if the given version is equal to or older than a "maximum" -- version, or emit a runtime error. olderThan :: FortranVersion -> String -> FortranVersion -> a -> a @@ -33,6 +29,24 @@ ++ show ver ++ "." else cont +-- | Continue if the given version is one of the given "permitted" versions, +-- else emit a runtime error. +continueOnlyFor :: [FortranVersion] -> String -> FortranVersion -> a -> a +continueOnlyFor permittedVers featureName ver cont = + if ver `List.elem` permittedVers then cont + else prettyError $ + featureName + ++ " is only available for: " ++ show permittedVers + ++ ". You called pretty print with " ++ show ver ++ "." + +-- | Emit a runtime error due to bad pretty printing. +-- +-- Intended to be used in the @otherwise@ guard. +tooOld :: FortranVersion -> String -> FortranVersion -> a +tooOld currentVersion featureName featureVersion = prettyError $ + featureName ++ " was introduced in " ++ show featureVersion ++ + ". You called pretty print with " ++ show currentVersion ++ "." + () :: Doc -> Doc -> Doc doc1 doc2 = if doc1 == empty || doc2 == empty then empty else doc1 <> doc2 infixl 7 @@ -391,9 +405,9 @@ pprint' _ TypeReal = "real" pprint' _ TypeDoublePrecision = "double precision" pprint' _ TypeComplex = "complex" - pprint' v TypeDoubleComplex - | v == Fortran77Extended = "double complex" - | otherwise = tooOld v "Double complex" Fortran77Extended + pprint' v TypeDoubleComplex = + continueOnlyFor [Fortran77Extended] "Double complex" v $ + "double complex" pprint' _ TypeLogical = "logical" pprint' v TypeCharacter | v >= Fortran77 = "character" @@ -466,7 +480,7 @@ | otherwise = prettyError "unhandled version" pprint' v (StStructure _ _ mName itemList) = - olderThan Fortran77Legacy "Structure" v $ + continueOnlyFor [Fortran77Legacy, Fortran90Legacy] "Structure" v $ "structure" <+> (if isJust mName then "/" <> pprint' v mName <> "/" else empty) <> newline @@ -530,19 +544,21 @@ | v >= Fortran90 = "data" <+> pprint' v aDataGroups | otherwise = "data" <+> hsep (map (pprint' v) dataGroups) - pprint' v (StAutomatic _ _ decls) - | v == Fortran77Extended = "automatic" <+> pprint' v decls - | otherwise = tooOld v "Automatic statement" Fortran90 + pprint' v (StAutomatic _ _ decls) = + continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Automatic statement" v $ + "automatic" <+> pprint' v decls - pprint' v (StStatic _ _ decls) - | v == Fortran77Extended = "static" <+> pprint' v decls - | otherwise = tooOld v "Static statement" Fortran90 + pprint' v (StStatic _ _ decls) = + continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Static statement" v $ + "static" <+> pprint' v decls pprint' v (StNamelist _ _ namelist) | v >= Fortran90 = "namelist" <+> pprint' v namelist | otherwise = tooOld v "Namelist statement" Fortran90 - pprint' v (StParameter _ _ aDecls) = "parameter" <+> parens (pprint' v aDecls) + -- We reuse the declaration node, but parameter statements use `=` even in + -- the older standards + pprint' _ (StParameter _ _ aDecls) = "parameter" <+> parens (pprint' Fortran90 aDecls) pprint' v (StExternal _ _ vars) = "external" <+> pprint' v vars pprint' v (StIntrinsic _ _ vars) = "intrinsic" <+> pprint' v vars @@ -650,7 +666,7 @@ pprint' v (StGotoComputed _ _ labels target) = "goto" <+> parens (pprint' v labels) <+> pprint' v target - pprint' v (StCall _ _ name args) = pprint' v name <+> parens (pprint' v args) + pprint' v (StCall _ _ name args) = "call" <+> pprint' v name <+> parens (pprint' v args) pprint' _ (StContinue _ _) = "continue" @@ -669,10 +685,9 @@ "write" <+> parens (pprint' v cilist) <+> pprint' v mIolist pprint' v (StPrint _ _ formatId mIolist) = "print" <+> pprint' v formatId <> comma pprint' v mIolist - pprint' v (StTypePrint _ _ formatId mIolist) - | v == Fortran77Extended - = "type" <+> pprint' v formatId <> comma pprint' v mIolist - | otherwise = tooOld v "Type (print) statement" Fortran77Extended + pprint' v (StTypePrint _ _ formatId mIolist) = + continueOnlyFor [Fortran77Extended] "Type (print) statement" v $ + "type" <+> pprint' v formatId <> comma pprint' v mIolist pprint' v (StOpen _ _ cilist) = "open" <+> parens (pprint' v cilist) pprint' v (StClose _ _ cilist) = "close" <+> parens (pprint' v cilist) 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 @@ -270,7 +272,14 @@ case (l', r') of (FSVInt li, FSVInt ri) -> pure $ MkFScalarValue $ FSVInt $ fIntBOpInplace (^) li ri + (FSVReal lr, FSVReal ri) -> + pure $ MkFScalarValue $ FSVReal $ fRealBOpInplace' (**) (**) lr ri + (FSVReal lr, FSVInt ri) -> + -- Handle case of a real raised to an integer power. + pure $ MkFScalarValue $ FSVReal $ fRealBOpInplace' (**) (**) lr (FReal8 $ withFInt ri) +-- _ -> err $ ELazy "exponentiation: unsupported types" + F.Concatenation -> case (l', r') of (FSVString ls, FSVString rs) -> @@ -425,7 +434,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 +502,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/Repr/Value/Machine.hs b/src/Language/Fortran/Repr/Value/Machine.hs --- a/src/Language/Fortran/Repr/Value/Machine.hs +++ b/src/Language/Fortran/Repr/Value/Machine.hs @@ -2,6 +2,8 @@ module Language.Fortran.Repr.Value.Machine where +import Language.Fortran.Repr.Value.Scalar.Real +import Language.Fortran.Repr.Value.Scalar.Int.Machine import Language.Fortran.Repr.Value.Scalar.Machine import Language.Fortran.Repr.Type @@ -18,3 +20,15 @@ fValueType :: FValue -> FType fValueType = \case MkFScalarValue a -> MkFScalarType $ fScalarValueType a + +fromConstInt :: FValue -> Maybe Integer +fromConstInt (MkFScalarValue (FSVInt a)) = Just $ withFInt a +fromConstInt _ = Nothing + +fromConstReal :: FValue -> Maybe Double +fromConstReal (MkFScalarValue (FSVReal (FReal4 a))) = Just $ floatToDouble a + where + floatToDouble :: Float -> Double + floatToDouble = realToFrac +fromConstReal (MkFScalarValue (FSVReal (FReal8 a))) = Just $ a +fromConstReal _ = Nothing diff --git a/src/Language/Fortran/Repr/Value/Scalar/Machine.hs b/src/Language/Fortran/Repr/Value/Scalar/Machine.hs --- a/src/Language/Fortran/Repr/Value/Scalar/Machine.hs +++ b/src/Language/Fortran/Repr/Value/Scalar/Machine.hs diff --git a/src/Language/Fortran/Transformation/Monad.hs b/src/Language/Fortran/Transformation/Monad.hs --- a/src/Language/Fortran/Transformation/Monad.hs +++ b/src/Language/Fortran/Transformation/Monad.hs @@ -9,6 +9,7 @@ import Prelude hiding (lookup) import Control.Monad.State.Lazy hiding (state) import Data.Data +import qualified Data.Map as M import Language.Fortran.Analysis import Language.Fortran.Analysis.Types @@ -22,13 +23,14 @@ runTransform :: Data a - => TypeEnv -> ModuleMap -> Transform a () -> ProgramFile a -> ProgramFile a + => TypeEnvExtended -> ModuleMap -> Transform a () -> ProgramFile a -> ProgramFile a runTransform env mmap trans pf = stripAnalysis . transProgramFile . execState trans $ initState where - (pf', _) = analyseTypesWithEnv env . analyseRenamesWithModuleMap mmap . initAnalysis $ pf + (pf', _) = analyseTypesWithEnv (removeExtendedInfo env) . analyseRenamesWithModuleMap mmap . initAnalysis $ pf initState = TransformationState { transProgramFile = pf' } + removeExtendedInfo = M.map (\(_, _, t) -> t) getProgramFile :: Transform a (ProgramFile (Analysis a)) getProgramFile = gets transProgramFile diff --git a/src/Language/Fortran/Util/Files.hs b/src/Language/Fortran/Util/Files.hs --- a/src/Language/Fortran/Util/Files.hs +++ b/src/Language/Fortran/Util/Files.hs @@ -3,18 +3,21 @@ , runCPP , getDirContents , rGetDirContents + , expandDirs + , listFortranFiles + , listDirectoryRecursively ) where import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import qualified Data.ByteString.Char8 as B import System.Directory (listDirectory, canonicalizePath, - doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) + doesDirectoryExist, getDirectoryContents, doesFileExist) +import System.FilePath ((), takeExtension) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess) import Data.List ((\\), foldl') -import Data.Char (isNumber) +import Data.Char (isNumber, toLower) -- | Obtain a UTF-8 safe 'B.ByteString' representation of a file's contents. -- -- Invalid UTF-8 is replaced with the space character. @@ -36,11 +39,11 @@ fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries where f x = do - path <- canonicalizePath $ d ++ "/" ++ x + path <- canonicalizePath $ d x g <- doesDirectoryExist path if g && notElem path seen then do x' <- go (path : seen) path - return $ map (\ y -> x ++ "/" ++ y) x' + return $ map (\ y -> x y) x' else return [x] -- | Run the C Pre Processor over the file before reading into a bytestring @@ -68,3 +71,36 @@ let ls = B.lines contents let ls' = reverse . fst $ foldl' processCPPLine ([], 1) ls return $ B.unlines ls' + +-- | Expand all paths that are directories into a list of Fortran +-- files from a recursive directory listing. +expandDirs :: [FilePath] -> IO [FilePath] +expandDirs = fmap concat . mapM each + where + each path = do + isDir <- doesDirectoryExist path + if isDir + then listFortranFiles path + else pure [path] + +-- | Get a list of Fortran files under the given directory. +listFortranFiles :: FilePath -> IO [FilePath] +listFortranFiles dir = filter isFortran <$> listDirectoryRecursively dir + where + -- | True if the file has a valid fortran extension. + isFortran :: FilePath -> Bool + isFortran x = map toLower (takeExtension x) `elem` exts + where exts = [".f", ".f90", ".f77", ".f03"] + +listDirectoryRecursively :: FilePath -> IO [FilePath] +listDirectoryRecursively dir = listDirectoryRec dir "" + where + listDirectoryRec :: FilePath -> FilePath -> IO [FilePath] + listDirectoryRec d f = do + let fullPath = d f + isDir <- doesDirectoryExist fullPath + if isDir + then do + conts <- listDirectory fullPath + concat <$> mapM (listDirectoryRec fullPath) conts + else pure [fullPath] 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 @@ -55,7 +55,7 @@ , moduleFilename , StringMap, extractStringMap, combinedStringMap , DeclContext(..), DeclMap, extractDeclMap, combinedDeclMap - , extractModuleMap, combinedModuleMap, combinedTypeEnv + , extractModuleMap, combinedModuleMap, localisedModuleMap, combinedTypeEnv , ParamVarMap, extractParamVarMap, combinedParamVarMap , genUniqNameToFilenameMap , TimestampStatus(..), checkTimestamps @@ -71,6 +71,7 @@ import Language.Fortran.Util.Files ( getDirContents ) import Control.Monad.State +import Control.Monad -- required for mtl-2.3 (GHC 9.6) import Data.Binary (Binary, encode, decodeOrFail) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Data @@ -80,7 +81,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 ) -------------------------------------------------- @@ -103,8 +104,9 @@ instance Binary DeclContext -- | Map of unique variable name to the unique name of the program --- unit where it was defined, and the corresponding SrcSpan. -type DeclMap = M.Map F.Name (DeclContext, P.SrcSpan) +-- unit where it was defined, its source name, +-- and the corresponding SrcSpan. +type DeclMap = M.Map F.Name (DeclContext, F.Name, P.SrcSpan) -- | A map of aliases => strings, in order to save space and share -- structure for repeated strings. @@ -118,9 +120,10 @@ , mfStringMap :: StringMap , mfModuleMap :: FAR.ModuleMap , mfDeclMap :: DeclMap - , mfTypeEnv :: FAT.TypeEnv + , mfTypeEnv :: FAT.TypeEnvExtended , mfParamVarMap :: ParamVarMap - , mfOtherData :: M.Map String LB.ByteString } + , mfOtherData :: M.Map String LB.ByteString + } deriving (Eq, Show, Data, Typeable, Generic) instance Binary ModFile @@ -139,16 +142,16 @@ -- | 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 + , mfTypeEnv = FAT.extractTypeEnvExtended pf , mfParamVarMap = extractParamVarMap pf , mfFilename = F.pfGetFilename 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 @@ -217,9 +220,14 @@ combinedModuleMap :: ModFiles -> FAR.ModuleMap combinedModuleMap = M.unions . map mfModuleMap +-- | Inside the module map, remove all imported declarations so that +-- we can properly localise declarations to the originator file. +localisedModuleMap :: FAR.ModuleMap -> FAR.ModuleMap +localisedModuleMap = M.map (M.filter (not . FA.isImported . snd)) + -- | Extract the combined module map from a set of ModFiles. Useful -- for parsing a Fortran file in a large context of other modules. -combinedTypeEnv :: ModFiles -> FAT.TypeEnv +combinedTypeEnv :: ModFiles -> FAT.TypeEnvExtended combinedTypeEnv = M.unions . map mfTypeEnv -- | Extract the combined declaration map from a set of @@ -244,14 +252,24 @@ -------------------------------------------------- -- | Create a map that links all unique variable/function names in the --- ModFiles to their corresponding filename. -genUniqNameToFilenameMap :: ModFiles -> M.Map F.Name String -genUniqNameToFilenameMap = M.unions . map perMF +-- ModFiles to their corresponding *originating* filename (i.e., where they are declared) +-- paired with their source name (maybe) +genUniqNameToFilenameMap :: FilePath -> ModFiles -> M.Map F.Name (String, Maybe F.Name) +genUniqNameToFilenameMap localPath m = M.unions . map perMF $ m where - perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems (mfModuleMap mf) - , (n, _) <- M.elems modEnv ] + perMF mf = M.fromList + $ [ (n, (fname, Nothing)) + | (_p, modEnv) <- M.toList localModuleMap + , (n, _) <- M.elems modEnv ] + -- decl map information + <> [(n, (fname, Just srcName)) | (n, (_dc, srcName, _)) <- M.toList declMap ] + where - fname = mfFilename mf + -- Make sure that we remove imported declarations so we can + -- properly localise declarations to the originator file. + localModuleMap = localisedModuleMap $ mfModuleMap mf + declMap = mfDeclMap mf + fname = normalise $ localPath mfFilename mf -------------------------------------------------- @@ -278,28 +296,28 @@ where -- Extract variable names, source spans from declarations (and -- from function return variable if present) - blockDecls :: (DeclContext, Maybe (F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) -> [(F.Name, (DeclContext, P.SrcSpan))] + blockDecls :: (DeclContext, Maybe (F.Name, F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) -> [(F.Name, (DeclContext, F.Name, P.SrcSpan))] blockDecls (dc, mret, bs) | Nothing <- mret = map decls (universeBi bs) - | Just (ret, ss) <- mret = (ret, (dc, ss)):map decls (universeBi bs) + | Just (ret, srcName, ss) <- mret = (ret, (dc, srcName, ss)):map decls (universeBi bs) where - decls d = let (v, ss) = declVarName d in (v, (dc, ss)) + decls d = let (v, srcName, ss) = declVarName d in (v, (dc, srcName, ss)) -- Extract variable name and source span from declaration - declVarName :: F.Declarator (FA.Analysis a) -> (F.Name, P.SrcSpan) - declVarName (F.Declarator _ _ e _ _ _) = (FA.varName e, P.getSpan e) + declVarName :: F.Declarator (FA.Analysis a) -> (F.Name, F.Name, P.SrcSpan) + declVarName (F.Declarator _ _ e _ _ _) = (FA.varName e, FA.srcName e, P.getSpan e) -- Extract context identifier, a function return value (+ source -- span) if present, and a list of contained blocks - nameAndBlocks :: F.ProgramUnit (FA.Analysis a) -> (DeclContext, Maybe (F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) + nameAndBlocks :: F.ProgramUnit (FA.Analysis a) -> (DeclContext, Maybe (F.Name, F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) nameAndBlocks pu = case pu of F.PUMain _ _ _ b _ -> (DCMain, Nothing, b) F.PUModule _ _ _ b _ -> (DCModule $ FA.puName pu, Nothing, b) F.PUSubroutine _ _ _ _ _ b _ -> (DCSubroutine (FA.puName pu, FA.puSrcName pu), Nothing, b) F.PUFunction _ _ _ _ _ _ mret b _ | Nothing <- mret - , F.Named n <- FA.puName pu -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (n, P.getSpan pu), b) - | Just ret <- mret -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (FA.varName ret, P.getSpan ret), b) + , F.Named n <- FA.puName pu -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (n, n, P.getSpan pu), b) + | Just ret <- mret -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (FA.varName ret, FA.srcName ret, P.getSpan ret), b) | otherwise -> error $ "nameAndBlocks: un-named function with no return value! " ++ show (FA.puName pu) ++ " at source-span " ++ show (P.getSpan pu) F.PUBlockData _ _ _ b -> (DCBlockData, Nothing, b) F.PUComment {} -> (DCBlockData, Nothing, []) -- no decls inside of comments, so ignore it diff --git a/src/Language/Fortran/Util/Position.hs b/src/Language/Fortran/Util/Position.hs --- a/src/Language/Fortran/Util/Position.hs +++ b/src/Language/Fortran/Util/Position.hs @@ -26,7 +26,10 @@ instance NFData Position instance Show Position where - show (Position _ c l _ _) = show l ++ ':' : show c + -- Column number decrement by 1 as the lexer generates column numbers + -- starting at position 1 + -- See PR https://github.com/camfort/fortran-src/pull/292 + show (Position _ c l _ _) = show l ++ ':' : show (c - 1) initPosition :: Position initPosition = Position diff --git a/src/Language/Fortran/Version.hs b/src/Language/Fortran/Version.hs --- a/src/Language/Fortran/Version.hs +++ b/src/Language/Fortran/Version.hs @@ -24,6 +24,7 @@ | Fortran77Extended -- ^ F77 with some extensions | Fortran77Legacy -- ^ F77 with most extensions | Fortran90 + | Fortran90Legacy -- ^ F90 with legacy extensions | Fortran95 | Fortran2003 | Fortran2008 @@ -35,6 +36,7 @@ show Fortran77Extended = "Fortran 77 Extended" show Fortran77Legacy = "Fortran 77 Legacy" show Fortran90 = "Fortran 90" + show Fortran90Legacy = "Fortran 90 Legacy" show Fortran95 = "Fortran 95" show Fortran2003 = "Fortran 2003" show Fortran2008 = "Fortran 2008" @@ -48,6 +50,7 @@ , ("77l", Fortran77Legacy) , ("77" , Fortran77) , ("90" , Fortran90) + , ("90l", Fortran90Legacy) , ("95" , Fortran95) , ("03" , Fortran2003) , ("08" , Fortran2008) ] diff --git a/test-data/module/leaf.f90 b/test-data/module/leaf.f90 new file mode 100644 --- /dev/null +++ b/test-data/module/leaf.f90 @@ -0,0 +1,4 @@ +module leaf + implicit none + real :: constant = 0.1 +end module diff --git a/test-data/module/mid1.f90 b/test-data/module/mid1.f90 new file mode 100644 --- /dev/null +++ b/test-data/module/mid1.f90 @@ -0,0 +1,4 @@ +module mid1 + implicit none + use leaf +end module diff --git a/test-data/module/mid2.f90 b/test-data/module/mid2.f90 new file mode 100644 --- /dev/null +++ b/test-data/module/mid2.f90 @@ -0,0 +1,4 @@ +module mid2 + implicit none + use leaf +end module diff --git a/test-data/module/top.f90 b/test-data/module/top.f90 new file mode 100644 --- /dev/null +++ b/test-data/module/top.f90 @@ -0,0 +1,5 @@ +module top + implicit none + use mid1 + use mid2 +end module diff --git a/test/Language/Fortran/Analysis/ModFileSpec.hs b/test/Language/Fortran/Analysis/ModFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/ModFileSpec.hs @@ -0,0 +1,47 @@ +module Language.Fortran.Analysis.ModFileSpec (spec) where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Util.ModFile +import Language.Fortran.Util.Files (expandDirs, flexReadFile) +import Language.Fortran.Version +import System.FilePath (()) +import qualified Data.Map as M +import qualified Language.Fortran.Parser as Parser +import qualified Data.ByteString.Char8 as B +import Language.Fortran.AST +import Language.Fortran.Analysis +import Language.Fortran.Analysis.Renaming +import Language.Fortran.Analysis.BBlocks +import Language.Fortran.Analysis.DataFlow + +spec :: Spec +spec = + describe "Modfiles" $ + it "Test module maps for a small package" $ + testModuleMaps + +pParser :: String -> IO (ProgramFile (Analysis A0)) +pParser name = do + contents <- flexReadFile name + let pf = Parser.byVerWithMods [] Fortran90 name contents + case pf of + Right pf -> return $ rename . analyseBBlocks . analyseRenames . initAnalysis $ pf + Left err -> error $ "Error parsing " ++ name ++ ": " ++ show err + +-- A simple test that checks that we correctly localise the declaration +-- of the variable `constant` to the leaf module, whilst understanding +-- in the `mid1` and `mid2` modules that it is an imported declaration. +testModuleMaps = do + 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 + -- 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/Analysis/ModGraphSpec.hs b/test/Language/Fortran/Analysis/ModGraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/ModGraphSpec.hs @@ -0,0 +1,30 @@ +module Language.Fortran.Analysis.ModGraphSpec (spec) where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Analysis.ModGraph +import Language.Fortran.Util.Files (expandDirs) +import Language.Fortran.Version +import System.FilePath (()) + +spec :: Spec +spec = + describe "Modgraph" $ + it "Dependency graph and topological sort on small package" $ + testDependencyList + +-- A simple test on a simple module structure to check that +-- we are understanding this correctly (via the dependency graph +-- and then its topological sort). +testDependencyList = do + paths' <- expandDirs ["test-data" "module"] + mg <- genModGraph (Just Fortran90) ["."] Nothing paths' + let list = modGraphToList mg + -- we should have two possible orderings + let files1 = ["leaf.f90", "mid1.f90", "mid2.f90", "top.f90"] + let filesWithPaths1 = map (("test-data" "module") ) files1 + -- or in a different order + let files2 = ["leaf.f90", "mid2.f90", "mid1.f90", "top.f90"] + let filesWithPaths2 = map (("test-data" "module") ) files2 + shouldSatisfy list (\x -> x == filesWithPaths1 || x == filesWithPaths2) diff --git a/test/Language/Fortran/Analysis/SemanticTypesSpec.hs b/test/Language/Fortran/Analysis/SemanticTypesSpec.hs --- a/test/Language/Fortran/Analysis/SemanticTypesSpec.hs +++ b/test/Language/Fortran/Analysis/SemanticTypesSpec.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + module Language.Fortran.Analysis.SemanticTypesSpec where import Test.Hspec @@ -7,6 +10,10 @@ import Language.Fortran.AST import Language.Fortran.Version +import Language.Fortran.PrettyPrint +import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.GenericPretty + spec :: Spec spec = do describe "Semantic types" $ do @@ -29,3 +36,9 @@ let semtype = TCharacter CharLenStar 1 typespec = TypeSpec () u TypeCharacter (Just (Selector () u (Just (ExpValue () u ValStar)) Nothing)) in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec + + it "prints semantic type with dimensions" $ do + let dims = DimsExplicitShape ( [ Dim (Just 1) (Just 3), Dim (Just 1) (Just 4) ] ) + let semtype = TArray (TReal 8) dims + pprint Fortran90 semtype Nothing `shouldBe` "real(8)(1:3, 1:4)" + diff --git a/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs @@ -56,6 +56,13 @@ st = StUse () u (varGen "mod") Nothing Permissive (Just renames) sParser "use :: mod, sprod => prod, a => b" `shouldBe'` st + it "parses simple procedure with no args" $ do + let st = StProcedure () u (Just (ProcInterfaceName () u (varGen "name"))) + Nothing + (AList () u [ProcDecl () u (varGen "other_name") Nothing] ) + sParser "procedure(name) :: other_name" `shouldBe'` st + + it "parses procedure (interface-name, attribute, proc-decl)" $ do let call = ExpFunctionCall () u (varGen "c") (aEmpty () u) st = StProcedure () u (Just (ProcInterfaceName () u (varGen "a"))) @@ -172,5 +179,18 @@ expValVar x = ExpValue () u (ValVariable x) expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2) bParser text `shouldBe'` expected + + describe "allocate statement" $ do + it "parses allocated nested in another statement" $ do + let text = "if(y) allocate(x,stat=ierr_allocate)" + let expected = StIfLogical () u + (ExpValue () u (ValVariable "y")) (StAllocate () u Nothing + (AList {alistAnno = (), + alistSpan = u, + alistList = [ExpValue () u (ValVariable "x")]}) + (Just AList {alistAnno = (), + alistSpan = u, + alistList = [AOStat () u (ExpValue () u (ValVariable "ierr_allocate"))]})) + sParser text `shouldBe'` expected specFreeCommon bParser sParser eParser diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs @@ -17,21 +17,24 @@ --import qualified Data.List as List import qualified Data.ByteString.Char8 as B -parseWith :: Parse Free.AlexInput Free.Token a -> String -> a -parseWith p = parseUnsafe (makeParserFree p Fortran90) . B.pack +parseWith :: FortranVersion -> Parse Free.AlexInput Free.Token a -> String -> a +parseWith v p = parseUnsafe (makeParserFree p v) . B.pack eParser :: String -> Expression () eParser = parseUnsafe p . B.pack where p = makeParser initParseStateFreeExpr F90.expressionParser Fortran90 sParser :: String -> Statement () -sParser = parseWith F90.statementParser +sParser = parseWith Fortran90 F90.statementParser +slParser :: String -> Statement () +slParser = parseWith Fortran90Legacy F90.statementParser + bParser :: String -> Block () -bParser = parseWith F90.blockParser +bParser = parseWith Fortran90 F90.blockParser fParser :: String -> ProgramUnit () -fParser = parseWith F90.functionParser +fParser = parseWith Fortran90 F90.functionParser {- Useful for parser debugging; Lexes the given source code. fTok :: String -> [Token] @@ -484,3 +487,83 @@ sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st specFreeCommon bParser sParser eParser + + describe "Legacy Extensions" $ do + it "parses automatic and static statements" $ do + let decl = declVariable () u (varGen "x") Nothing Nothing + autoStmt = StAutomatic () u (AList () u [decl]) + staticStmt = StStatic () u (AList () u [decl]) + autoSrc = "automatic x" + staticSrc = "static x" + resetSrcSpan (slParser autoSrc) `shouldBe` autoStmt + resetSrcSpan (slParser staticSrc) `shouldBe` staticStmt + + it "parses structure/union/map blocks" $ do + let src = init + $ unlines [ "structure /foo/" + , " union" + , " map" + , " integer i" + , " end map" + , " map" + , " real r" + , " end map" + , " end union" + , "end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [declVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [declVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses structure/union/map blocks with comments" $ do + let src = init + $ unlines [ "structure /foo/" + , "! comment before union" + , " union" + , "! comment inside union, before map" + , " map" + , "! comment inside map" + , " integer i" + , " end map" + , "! comment between maps" + , " map" + , " real r" + , " end map" + , "! comment after map" + , " end union" + , "! comment after union" + , "end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [declVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [declVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses nested structure blocks" $ do + let src = init + $ unlines [ "structure /foo/" + , " structure /bar/ baz" + , " integer qux" + , " end structure" + , "end structure"] + var = declVariable () u (varGen "qux") Nothing Nothing + innerst = StructStructure () u (Just "bar") "baz" + $ AList () u [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing + $ AList () u [var]] + st = StStructure () u (Just "foo") $ AList () u [innerst] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses structure data references" $ do + let st = StPrint () u expStar $ Just $ AList () u [foobar] + foobar = ExpDataRef () u (varGen "foo") (varGen "bar") + expStar = ExpValue () u ValStar + sParser "print *, foo % bar" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs @@ -15,7 +15,7 @@ import qualified Language.Fortran.Parser.Free.Lexer as Free import qualified Data.List as List -import Data.Foldable(forM_) +import Control.Monad ( forM_ ) import qualified Data.ByteString.Char8 as B import Control.Exception (evaluate) 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