fortran-src 0.11.0 → 0.16.9
raw patch · 80 files changed
Files
- CHANGELOG.md +77/−0
- LICENSE +0/−2
- README.md +62/−9
- app/Main.hs +50/−52
- fortran-src.cabal +40/−32
- src/Language/Fortran/AST.hs +42/−39
- src/Language/Fortran/AST/AList.hs +2/−2
- src/Language/Fortran/AST/Literal.hs +1/−1
- src/Language/Fortran/AST/Literal/Boz.hs +2/−2
- src/Language/Fortran/AST/Literal/Complex.hs +2/−2
- src/Language/Fortran/AST/Literal/Real.hs +6/−3
- src/Language/Fortran/Analysis.hs +29/−18
- src/Language/Fortran/Analysis/BBlocks.hs +1/−0
- src/Language/Fortran/Analysis/DataFlow.hs +62/−46
- src/Language/Fortran/Analysis/ModGraph.hs +31/−8
- src/Language/Fortran/Analysis/Renaming.hs +21/−13
- src/Language/Fortran/Analysis/SemanticTypes.hs +65/−29
- src/Language/Fortran/Analysis/Types.hs +27/−0
- src/Language/Fortran/Common/Array.hs +147/−0
- src/Language/Fortran/Parser.hs +97/−48
- src/Language/Fortran/Parser/Fixed/Fortran66.y +5/−0
- src/Language/Fortran/Parser/Fixed/Fortran77.y +6/−2
- src/Language/Fortran/Parser/Fixed/Lexer.x +4/−4
- src/Language/Fortran/Parser/Free/Fortran2003.y +15/−2
- src/Language/Fortran/Parser/Free/Fortran90.y +51/−0
- src/Language/Fortran/Parser/Free/Fortran95.y +5/−0
- src/Language/Fortran/Parser/Free/Lexer.x +72/−19
- src/Language/Fortran/Parser/LexerUtils.hs +15/−1
- src/Language/Fortran/Parser/Monad.hs +15/−9
- src/Language/Fortran/PrettyPrint.hs +46/−33
- src/Language/Fortran/Repr.hs +7/−4
- src/Language/Fortran/Repr/Eval/Common.hs +22/−10
- src/Language/Fortran/Repr/Eval/Type.hs +3/−1
- src/Language/Fortran/Repr/Eval/Value.hs +229/−138
- src/Language/Fortran/Repr/Eval/Value/Op.hs +37/−46
- src/Language/Fortran/Repr/Eval/Value/Op/Some.hs +0/−177
- src/Language/Fortran/Repr/Type/Array.hs +9/−0
- src/Language/Fortran/Repr/Type/Scalar.hs +10/−1
- src/Language/Fortran/Repr/Type/Scalar/Common.hs +8/−57
- src/Language/Fortran/Repr/Type/Scalar/Complex.hs +10/−8
- src/Language/Fortran/Repr/Type/Scalar/Int.hs +24/−66
- src/Language/Fortran/Repr/Type/Scalar/Real.hs +10/−31
- src/Language/Fortran/Repr/Type/Scalar/String.hs +5/−13
- src/Language/Fortran/Repr/Value/Array.hs +0/−5
- src/Language/Fortran/Repr/Value/Array/Machine.hs +0/−106
- src/Language/Fortran/Repr/Value/Machine.hs +25/−5
- src/Language/Fortran/Repr/Value/Scalar/Common.hs +85/−1
- src/Language/Fortran/Repr/Value/Scalar/Complex.hs +39/−13
- src/Language/Fortran/Repr/Value/Scalar/Int/Idealized.hs +12/−20
- src/Language/Fortran/Repr/Value/Scalar/Int/Machine.hs +70/−143
- src/Language/Fortran/Repr/Value/Scalar/Logical/Machine.hs +2/−2
- src/Language/Fortran/Repr/Value/Scalar/Machine.hs +20/−12
- src/Language/Fortran/Repr/Value/Scalar/Real.hs +52/−82
- src/Language/Fortran/Repr/Value/Scalar/String.hs +60/−4
- src/Language/Fortran/Rewriter/Internal.hs +19/−14
- src/Language/Fortran/Transformation/Monad.hs +4/−2
- src/Language/Fortran/Util/Files.hs +71/−6
- src/Language/Fortran/Util/ModFile.hs +43/−25
- src/Language/Fortran/Util/Position.hs +4/−1
- src/Language/Fortran/Version.hs +10/−7
- src/Text/PrettyPrint/GenericPretty/Orphans.hs +21/−0
- src/Text/PrettyPrint/GenericPretty/ViaShow.hs +31/−0
- test-data/module/leaf.f90 +4/−0
- test-data/module/mid1.f90 +4/−0
- test-data/module/mid2.f90 +4/−0
- test-data/module/top.f90 +5/−0
- test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f +4/−0
- test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected +5/−0
- test/Language/Fortran/Analysis/DataFlowSpec.hs +0/−7
- test/Language/Fortran/Analysis/ModFileSpec.hs +47/−0
- test/Language/Fortran/Analysis/ModGraphSpec.hs +30/−0
- test/Language/Fortran/Analysis/SemanticTypesSpec.hs +13/−0
- test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +2/−2
- test/Language/Fortran/Parser/Free/Fortran2003Spec.hs +20/−0
- test/Language/Fortran/Parser/Free/Fortran90Spec.hs +88/−5
- test/Language/Fortran/Parser/Free/Fortran95Spec.hs +1/−1
- test/Language/Fortran/Parser/Free/LexerSpec.hs +40/−1
- test/Language/Fortran/PrettyPrintSpec.hs +13/−0
- test/Language/Fortran/Repr/EvalSpec.hs +45/−0
- test/Language/Fortran/RewriterSpec.hs +20/−0
CHANGELOG.md view
@@ -1,3 +1,80 @@+### 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++### 0.15.0 (May 04, 2023)+ * handle more `INT` intrinsic forms+ [#263](https://github.com/camfort/fortran-src/pull/263)+ * add more `Language.Fortran.Common.Array` utils+ [#263](https://github.com/camfort/fortran-src/pull/263)+ * Analysis.SemanticTypes: use `type Dimensions = Dims NonEmpty (Maybe Int)`+ instead of `type Dimensions = Dims NonEmpty Int`+ [#263](https://github.com/camfort/fortran-src/pull/263)++### 0.14.0 (Mar 21, 2023)+ * provide extended evaluated array dimensions type at+ `Language.Fortran.Common.Array` (#261, @raehik)+ * replace the previous `Dimensions` type in+ `Language.Fortran.Analysis.SemanticTypes`++### 0.13.0 (Mar 14, 2023)+ * better handling for line directives in free form lexer (#248, @mrd)+ * don't inline solo includes in relevant F77 parsers (#245, @RaoulHC)+ * add `-C=opts` CLI option for passing CPP arguments (#250, @mrd)+ * fix reformatting of 73 character long lines in naive mixed form reformatter+ (#251, @ksromanov)+ * assume extended `Fortran77Legacy` rather than `Fortran77` for `*.f`, `*.for`+ etc. files (#260)+ * allow comment lines between continuation lines in F77 parser (in standard)+ (#257, @RaoulHC)+ * refactor Fortran type & value representation & expression evaluator without+ Fortran kind-indexed GADTs; replace constant folder (#253, @raehik)++### 0.12.0 (Oct 19, 2022)+ * clean up F77 include inlining (#245, @RaoulHC)+ * directly export F77 include parser at `f77lIncludesNoTransform`+ * `f77lIncIncludes :: String -> ByteString -> IO [Block A0]` should now be+ defined by the user e.g. `\fn bs -> throwIOLeft $ f77lIncludesNoTransform+ fn bs`+ * `Language.Fortran.Analysis.SemanticTypes`: alter `SemType` constructor+ `TArray` to support assumed-size (e.g. `integer arr(*)`) arrays (#244)+ * `Language.Fortran.Rewriter`: fix inline comment padding (#242, @RaoulHC)+ ### 0.11.0 (Oct 10, 2022) * add strong Fortran value & type representation at `Language.Fortran.Repr` (currently unused) (#235, @raehik)
LICENSE view
@@ -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
README.md view
@@ -1,7 +1,14 @@ # fortran-src +[](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,22 +63,37 @@ ``` Usage: fortran-src [OPTION...] <file>- -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]- -a ACTION --action=ACTION lex or parse action+ --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 ``` +If you do not pass a `--fortranVersion` flag, the version will be guessed from+the file name:++ * Files ending in `*.f` are parsed with extended FORTRAN 77 syntax.+ * Files ending in `*.f90` are parsed with Fortran 90 syntax (and respectively+ for `*.f2003`/`*.f03`, `*.f2008`/`*.f08`).+ * Unknown extensions are parsed like `*.f` files.+ ## Building You will need the GMP library plus header files: on many platforms, this will be via the package `libgmp-dev`.@@ -62,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. @@ -109,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`. @@ -153,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).
app/Main.hs view
@@ -50,21 +50,30 @@ 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) 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 paths' <- expandDirs paths -- Build the graph of module dependencies- mg0 <- genModGraph mvers (includeDirs opts) paths'+ mg0 <- genModGraph mvers (includeDirs opts) (cppOptions opts) paths' -- Start the list of mods with those from the command line mods0 <- decodeModFiles' $ includeDirs opts -- Loop through the dependency graph until it is empty@@ -101,7 +110,7 @@ mods <- decodeModFiles' $ includeDirs opts mapM_ (\ p -> compileFileToMod (fortranVersion opts) mods p (outputFile opts)) paths (path:_, actionOpt) -> do- contents <- flexReadFile path+ contents <- runCPP (cppOptions opts) path -- only runs CPP if cppOptions is not Nothing mods <- decodeModFiles' $ includeDirs opts let version = fromMaybe (deduceFortranVersion path) (fortranVersion opts) parsedPF = case (Parser.byVerWithMods mods version) path contents of@@ -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@@ -206,48 +215,19 @@ _ -> 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@@ -271,7 +251,7 @@ where gr' = superBBGrGraph sgr entries = superBBGrEntries sgr- dfStr gr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [+ dfStr gr = (\ (l, x) -> "\n********************\n " ++ l ++ ": " ++ "\n--------------------\n" ++ x ++ "\n") =<< [ ("callMap", show cm) , ("entries", show (bbgrEntries gr)) , ("exits", show (bbgrExits gr))@@ -315,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 ]@@ -329,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@@ -349,22 +332,27 @@ , outputFormat :: OutputFormat , outputFile :: Maybe FilePath , includeDirs :: [String]+ , cppOptions :: Maybe String -- ^ Nothing: no CPP; Just x: run CPP with options x. , useContinuationReformatter :: Bool } initOptions :: Options-initOptions = Options Nothing Parse Default Nothing [] False+initOptions = Options Nothing Parse Default Nothing [] Nothing False 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")- "lex or parse action"+ "choose the action, possible values: lex|parse" , Option ['t'] ["typecheck"] (NoArg $ \ opts -> opts { action = Typecheck })@@ -397,6 +385,12 @@ ["dump-mod-file"] (NoArg $ \ opts -> opts { action = DumpModFile }) "dump the information contained within mod files"+ , Option ['C']+ ["cpp"]+ (OptArg (\ cppOpts opts -> opts {+ cppOptions = Just (dropWhile (=='=') $ fromMaybe "" cppOpts) }+ ) "CPP-OPTS")+ "run the C Pre Processor on the Fortran files first" , Option ['I'] ["include-dir"] (ReqArg (\ d opts -> opts { includeDirs = d:includeDirs opts }) "DIR")@@ -417,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) }
fortran-src.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- 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.11.0+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 @<https://hackage.haskell.org/package/camfort CamFort>@ 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@@ -45,6 +48,8 @@ test-data/rewriter/replacementsmap-overlapping-filtered/001_foo.f.expected test-data/rewriter/replacementsmap-overlapping/001_foo.f test-data/rewriter/replacementsmap-overlapping/001_foo.f.expected+ test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f+ test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected test-data/rewriter/replacementsmap-simple/001_foo.f test-data/rewriter/replacementsmap-simple/001_foo.f.expected test-data/rewriter/replacementsmap-simple/002_foo.f@@ -78,6 +83,7 @@ Language.Fortran.AST.Literal.Boz Language.Fortran.AST.Literal.Complex Language.Fortran.AST.Literal.Real+ Language.Fortran.Common.Array Language.Fortran.Intrinsics Language.Fortran.LValue Language.Fortran.Parser@@ -100,7 +106,6 @@ Language.Fortran.Repr.Eval.Type Language.Fortran.Repr.Eval.Value Language.Fortran.Repr.Eval.Value.Op- Language.Fortran.Repr.Eval.Value.Op.Some Language.Fortran.Repr.Tmp Language.Fortran.Repr.Type Language.Fortran.Repr.Type.Array@@ -112,8 +117,6 @@ Language.Fortran.Repr.Type.Scalar.String Language.Fortran.Repr.Util Language.Fortran.Repr.Value- Language.Fortran.Repr.Value.Array- Language.Fortran.Repr.Value.Array.Machine Language.Fortran.Repr.Value.Common Language.Fortran.Repr.Value.Machine Language.Fortran.Repr.Value.Scalar@@ -140,6 +143,8 @@ Language.Fortran.Util.Position Language.Fortran.Util.SecondParameter Language.Fortran.Version+ Text.PrettyPrint.GenericPretty.Orphans+ Text.PrettyPrint.GenericPretty.ViaShow other-modules: Paths_fortran_src hs-source-dirs:@@ -182,24 +187,24 @@ 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.* , filepath ==1.4.* , mtl >=2.2 && <3 , pretty >=1.1 && <2- , singletons >=3.0- , singletons-base >=3.0- , singletons-th >=3.0+ , process >=1.2.0.0+ , 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+ , text >=1.2 && <2.2 , uniplate >=1.6 && <2- , vector-sized >=1.5.0 && <1.6 default-language: Haskell2010 if os(windows) cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS@@ -245,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.*@@ -257,13 +262,13 @@ , fortran-src , mtl >=2.2 && <3 , pretty >=1.1 && <2- , singletons >=3.0- , singletons-base >=3.0- , singletons-th >=3.0+ , process >=1.2.0.0+ , 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+ , text >=1.2 && <2.2 , uniplate >=1.6 && <2- , vector-sized >=1.5.0 && <1.6 default-language: Haskell2010 if os(windows) cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS@@ -274,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@@ -292,6 +299,7 @@ Language.Fortran.Parser.Free.LexerSpec Language.Fortran.Parser.MonadSpec Language.Fortran.PrettyPrintSpec+ Language.Fortran.Repr.EvalSpec Language.Fortran.Rewriter.InternalSpec Language.Fortran.RewriterSpec Language.Fortran.Transformation.Disambiguation.FunctionSpec@@ -340,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.*@@ -353,13 +361,13 @@ , hspec >=2.2 && <3 , mtl >=2.2 && <3 , pretty >=1.1 && <2- , singletons >=3.0- , singletons-base >=3.0- , singletons-th >=3.0+ , process >=1.2.0.0+ , 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+ , text >=1.2 && <2.2 , uniplate >=1.6 && <2- , vector-sized >=1.5.0 && <1.6 default-language: Haskell2010 if os(windows) cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS
src/Language/Fortran/AST.hs view
@@ -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
src/Language/Fortran/AST/AList.hs view
@@ -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
src/Language/Fortran/AST/Literal.hs view
@@ -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
src/Language/Fortran/AST/Literal/Boz.hs view
@@ -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
src/Language/Fortran/AST/Literal/Complex.hs view
@@ -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
src/Language/Fortran/AST/Literal/Real.hs view
@@ -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
src/Language/Fortran/Analysis.hs view
@@ -3,10 +3,11 @@ -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis- ( initAnalysis, stripAnalysis, Analysis(..), Constant(..)+ ( 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@@ -31,6 +32,8 @@ import Language.Fortran.Analysis.SemanticTypes (SemType(..)) +import Language.Fortran.Repr+ -------------------------------------------------- -- | Basic block@@ -75,10 +78,31 @@ 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. type ModEnv = M.Map String (String, NameType)@@ -105,18 +129,6 @@ instance Out IDType instance Binary IDType --- | Information about potential / actual constant expressions.-data Constant- = ConstInt Integer -- ^ interpreted integer- | ConstUninterpInt String -- ^ uninterpreted integer- | ConstUninterpReal String -- ^ uninterpreted real- | ConstBinary BinaryOp Constant Constant -- ^ binary operation on potential constants- | ConstUnary UnaryOp Constant -- ^ unary operation on potential constants- deriving (Show, Ord, Eq, Typeable, Generic, Data)--instance Out Constant-instance Binary Constant- data Analysis a = Analysis { prevAnnotation :: a -- ^ original annotation , uniqueName :: Maybe String -- ^ unique name for function/variable, after variable renaming phase@@ -126,9 +138,8 @@ , moduleEnv :: Maybe ModEnv , idType :: Maybe IDType , allLhsVarsAnn :: [Name]- , constExp :: Maybe Constant- }- deriving (Data, Show, Eq, Generic)+ , constExp :: Maybe FValue+ } deriving stock (Show, Generic, Data, Eq) instance Functor Analysis where fmap f analysis =
src/Language/Fortran/Analysis/BBlocks.hs view
@@ -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
src/Language/Fortran/Analysis/DataFlow.hs view
@@ -8,7 +8,7 @@ , genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap , genFlowsToGraph, FlowsGraph , genVarFlowsToMap, VarFlowsMap- , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars, constantFolding+ , ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars , genBlockMap, genDefMap, BlockMap, DefMap , genCallMap, CallMap , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap@@ -42,7 +42,11 @@ 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+ -------------------------------------------------- -- Better names for commonly used types type BBNodeMap = IM.IntMap@@ -354,63 +358,75 @@ inBounds :: Integer -> Bool inBounds x = minConst <= x && x <= maxConst --- | Evaluate possible constant expressions within tree.-constantFolding :: Constant -> Constant-constantFolding c = case c of- ConstBinary binOp a b | ConstInt x <- constantFolding a- , ConstInt y <- constantFolding b -> case binOp of- Addition | inBounds (x + y) -> ConstInt (x + y)- Subtraction | inBounds (x - y) -> ConstInt (x - y)- Multiplication | inBounds (x * y) -> ConstInt (x * y)- Division | y /= 0 -> ConstInt (x `div` y)- -- gfortran appears to do real exponentiation (allowing negative exponent)- -- and cast back to integer via floor() (?) as required- -- but we keep it simple & stick with Haskell-style integer exponentiation- Exponentiation | y >= 0 -> ConstInt (x ^ y)- _ -> ConstBinary binOp (ConstInt x) (ConstInt y)- ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x)- ConstUnary Plus a -> constantFolding a- _ -> c- -- | The map of all parameter variables and their corresponding values-type ParameterVarMap = M.Map Name Constant+type ParameterVarMap = M.Map Name Repr.FValue+ -- | The map of all expressions and whether they are undecided (not--- present in map), a constant value (Just Constant), or probably not--- constant (Nothing).-type ConstExpMap = ASTExprNodeMap (Maybe Constant)+-- present in map), a constant value ('Just'), or probably not+-- constant ('Nothing').+type ConstExpMap = ASTExprNodeMap (Maybe Repr.FValue) -- | Generate a constant-expression map with information about the -- expressions (identified by insLabel numbering) in the ProgramFile -- pf (must have analysis initiated & basic blocks generated) .-genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap+genConstExpMap :: forall a. (Data a) => ProgramFile (Analysis a) -> ConstExpMap genConstExpMap pf = ceMap where- -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.- pvMap = M.fromList $- [ (varName v, getE e)- | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]- , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ] ++- [ (varName v, getE e)- | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]- , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ]- getV :: Expression (Analysis a) -> Maybe Constant- 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] ]- getE :: Expression (Analysis a) -> Maybe Constant++ -- 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 Constant- doExpr e = case e of- ExpValue _ _ (ValInteger intStr _) -> Just . ConstInt $ read intStr- ExpValue _ _ (ValReal r _) -> Just $ ConstUninterpReal (prettyHsRealLit r) -- TODO- ExpValue _ _ (ValVariable _) -> getV e- -- Recursively seek information about sub-expressions, relying on laziness.- ExpBinary _ _ binOp e1 e2 -> constantFolding <$> liftM2 (ConstBinary binOp) (getE e1) (getE e2)- ExpUnary _ _ unOp e' -> constantFolding <$> ConstUnary unOp <$> getE e'- _ -> Nothing++ 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 pvMap (Repr.evalExpr e) of+ Left _err -> Nothing+ Right (a, _msgs) -> Just a -- | Get constant-expression information and put it into the AST -- analysis annotation. Must occur after analyseBBlocks.
src/Language/Fortran/Analysis/ModGraph.hs view
@@ -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 --------------------------------------------------@@ -61,8 +60,8 @@ mg@ModGraph { mgGraph = gr } <- get put $ mg { mgGraph = insEdge (i, j, ()) gr } -genModGraph :: Maybe FortranVersion -> [FilePath] -> [FilePath] -> IO ModGraph-genModGraph mversion includeDirs paths = do+genModGraph :: Maybe FortranVersion -> [FilePath] -> Maybe String -> [FilePath] -> IO ModGraph+genModGraph mversion includeDirs cppOpts paths = do let perModule path pu@(PUModule _ _ modName _ _) = do _ <- maybeAddModName modName (Just $ MOFile path) let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <-@@ -80,21 +79,33 @@ perModule _ _ = pure () let iter :: FilePath -> ModGrapher () iter path = do- contents <- liftIO $ flexReadFile path+ contents <- liftIO $ runCPP cppOpts path fileMods <- liftIO $ decodeModFiles includeDirs 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
src/Language/Fortran/Analysis/Renaming.hs view
@@ -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
src/Language/Fortran/Analysis/SemanticTypes.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -module Language.Fortran.Analysis.SemanticTypes where+module Language.Fortran.Analysis.SemanticTypes+ ( module Language.Fortran.Analysis.SemanticTypes+ , module Language.Fortran.Common.Array+ ) where -import Data.Data ( Data, Typeable )+import Language.Fortran.Common.Array++import Data.Data ( Data ) import Control.DeepSeq ( NFData ) import GHC.Generics ( Generic ) import Language.Fortran.AST ( BaseType(..)@@ -14,9 +20,12 @@ import Language.Fortran.Version ( FortranVersion(..) ) import Data.Binary ( Binary ) import Text.PrettyPrint.GenericPretty ( Out(..) )-import Text.PrettyPrint ( (<+>), parens ) import Language.Fortran.PrettyPrint ( Pretty(..) )+import qualified Text.PrettyPrint as Pretty +import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+ type Kind = Int -- | Semantic type assigned to variables.@@ -33,32 +42,62 @@ | TLogical Kind | TByte Kind | TCharacter CharacterLen Kind- | TArray SemType (Maybe Dimensions) -- ^ Nothing denotes dynamic dimensions- | TCustom String -- use for F77 structures, F90 DDTs- deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance Binary SemType-instance Out SemType+ | TArray SemType Dimensions+ -- ^ A Fortran array type is represented by a type and a set of dimensions. --- TODO placeholder, not final or tested--- should really attempt to print with kind info, and change to DOUBLE PRECISION--- etc. for <F90. Maybe cheat, use 'recoverSemTypeTypeSpec' and print resulting--- TypeSpec?+ | TCustom String+ -- ^ Constructor to use for F77 structures, F90 DDTs++ deriving stock (Ord, Eq, Show, Data, Generic)+ deriving anyclass (NFData, Binary, Out)++-- | The main dimension type is a non-empty list of dimensions where each bound+-- is @'Maybe' 'Int'@. @'Nothing'@ bounds indicate a dynamic bound (e.g. uses+-- a dummy variable).+type Dimensions = Dims NonEmpty (Maybe Int)+ instance Pretty SemType where- pprint' v = \case- TInteger _ -> "integer"- TReal _ -> "real"- TComplex _ -> "complex"- TLogical _ -> "logical"- TByte _ -> "byte"- TCharacter _ _ -> "character"- TArray st _ -> pprint' v st <+> parens "(A)"- TCustom str -> pprint' v (TypeCustom str)+ pprint' v+ | v >= Fortran90 = \case+ TInteger k -> "integer"<>pd k+ TReal k -> "real"<>pd k+ TComplex k -> "complex"<>pd k+ TLogical k -> "logical"<>pd k+ TByte k -> "byte"<>pd k+ TCharacter _ _ -> "character(TODO)"+ TArray st dims -> pprint' v st <> pdims v dims+ TCustom str -> pprint' v (TypeCustom str)+ | otherwise = \case+ TInteger k -> "integer"<>ad k+ TReal k -> "real"<>ad k+ TComplex k -> "complex"<>ad k+ TLogical k -> "logical"<>ad k+ TByte k -> "byte"<>ad k+ TCharacter _ _ -> "character*TODO"+ 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) --- | The declared dimensions of a staticically typed array variable--- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]-type Dimensions = [(Int, Int)] +-- | Convert 'Dimensions' data type to its previous type synonym+-- @(Maybe [(Int, Int)])@.+--+-- Drops all information for array dimensions that aren't fully static/known.+dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)]+dimensionsToTuples = \case+ DimsExplicitShape ds -> fmap NonEmpty.toList $ traverse go ds+ where+ go (Dim mlb mub) = do+ lb <- mlb+ ub <- mub+ pure $ (lb, ub)+ DimsAssumedSize _ds _d -> Nothing+ DimsAssumedShape _ss -> Nothing+ -------------------------------------------------------------------------------- data CharacterLen = CharLenStar -- ^ specified with a *@@ -66,11 +105,8 @@ -- FIXME, possibly, with a more robust const-exp: | CharLenExp -- ^ specified with a non-trivial expression | CharLenInt Int -- ^ specified with a constant integer- deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary CharacterLen-instance Out CharacterLen-instance NFData CharacterLen+ deriving stock (Ord, Eq, Show, Data, Generic)+ deriving anyclass (NFData, Binary, Out) charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String) charLenSelector Nothing = (Nothing, Nothing)
src/Language/Fortran/Analysis/Types.hs view
@@ -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))
+ src/Language/Fortran/Common/Array.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE UndecidableInstances #-} -- required due to instance design++module Language.Fortran.Common.Array where++import Control.DeepSeq ( NFData )+import GHC.Generics ( Generic )+import Data.Data ( Data, Typeable )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out(..) )++import qualified Text.PrettyPrint as Pretty++import qualified Language.Fortran.PrettyPrint as F++-- | A single array dimension with bounds of type @a@.+--+-- * @'Num' a => 'Dim' a@ is a static, known-size dimension.+-- * @'Dim' ('Language.Fortran.AST.Expression' '()')@ is a dimension with+-- unevaluated bounds expressions. Note that these bounds may be constant+-- expressions, or refer to dummy variables, or be invalid.+-- * @'Num' a => 'Dim' ('Maybe' a)@ is a dimension where some bounds are+-- known, and others are not. This may be useful to record some information+-- about dynamic explicit-shape arrays.+data Dim a = Dim+ { dimLower :: a -- ^ Dimension lower bound.+ , dimUpper :: a -- ^ Dimension upper bound.+ } deriving stock (Show, Generic, Data, Eq)+ deriving stock (Functor, Foldable, Traversable)+ deriving anyclass (NFData, Binary)++ -- | This instance is purely for convenience. No definition of ordering is+ -- provided, and the implementation may change at any time.+ deriving stock Ord++-- | Fortran syntax uses @lower:upper@, so only provide an 'Out' instance for+-- that style.+instance Out a => Out (Dim a) where+ doc (Dim lb ub) = doc lb <> Pretty.char ':' <> doc ub++instance Out (Dim a) => F.Pretty (Dim a) where+ pprint' _ = doc++-- | Fortran array dimensions, defined by a list of 'Dim's storing lower and+-- upper bounds.+--+-- You select the list type @t@ (which should be 'Functor', 'Foldable' and+-- 'Traversable') and the bound type @a@ (e.g. 'Int').+--+-- Using a non-empty list type such as 'Data.List.NonEmpty.NonEmpty' will+-- disallow representing zero-dimension arrays, providing extra soundness.+--+-- Note the following excerpt from the F2018 standard (8.5.8.2 Explicit-shape+-- array):+--+-- > If the upper bound is less than the lower bound, the range is empty, the+-- > extent in that dimension is zero, and the array is of zero size.+--+-- Note that the 'Foldable' instance does not provide "dimension-like" access to+-- this type. That is, @'length' (a :: 'Dims' t a)@ will _not_ tell you how many+-- dimensions 'a' represents. Use 'dimsLength' for that.+data Dims t a+ -- | Explicit-shape array. All dimensions are known.+ = DimsExplicitShape+ (t (Dim a)) -- ^ list of all dimensions++ -- | Assumed-size array. The final dimension has no upper bound (it is+ -- obtained from its effective argument). Earlier dimensions may be defined+ -- like explicit-shape arrays.+ | DimsAssumedSize+ (Maybe (t (Dim a))) -- ^ list of all dimensions except last+ a -- ^ lower bound of last dimension++ -- | Assumed-shape array. Shape is taken from effective argument. We store the+ -- lower bound for each dimension, and thus also the rank (via list length).+ | DimsAssumedShape+ (t a) -- ^ list of lower bounds++ deriving stock (Generic)+ deriving stock (Functor, Foldable, Traversable)++-- We have to standalone derive most instances due to the @t@ list-like.+deriving stock instance (Show a, Show (t a), Show (t (Dim a)))+ => Show (Dims t a)+deriving anyclass instance (NFData a, NFData (t a), NFData (t (Dim a)))+ => NFData (Dims t a)+deriving stock instance (Data a, Data (t a), Data (t (Dim a)), Typeable t)+ => Data (Dims t a)+deriving stock instance (Eq a, Eq (t a), Eq (t (Dim a)))+ => Eq (Dims t a)+deriving anyclass instance (Binary a, Binary (t a), Binary (t (Dim a)))+ => Binary (Dims t a)++-- | This instance is purely for convenience. No definition of ordering is+-- provided, and the implementation may change at any time.+deriving stock instance (Ord a, Ord (t a), Ord (t (Dim a)))+ => Ord (Dims t a)++instance (Foldable t, Functor t, Out (Dim a), Out a)+ => Out (Dims t a) where+ docPrec _ = doc+ doc = Pretty.parens . \case+ DimsExplicitShape ds ->+ prettyIntersperse dimSep $ fmap doc ds+ DimsAssumedShape ss ->+ prettyIntersperse dimSep $ fmap go ss+ where+ go s = doc s <> Pretty.char ':'+ DimsAssumedSize mds d ->+ -- A bit fragile, but hopefully won't explode on empty 'Just's.+ case mds of+ Nothing -> prettyLast+ Just ds -> prettyAfter dimSep (fmap doc ds) <> prettyLast+ where+ prettyLast = doc d <> Pretty.text ":*"+ where+ dimSep = Pretty.text ", "++instance Out (Dims t a) => F.Pretty (Dims t a) where+ pprint' _ = doc++-- Faster is possible for non @[]@ list-likes, but this is OK for the general+-- case.+prettyIntersperse :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc+prettyIntersperse dBetween ds =+ case foldMap (\d -> [dBetween, d]) ds of+ [] -> mempty+ _:ds' -> mconcat ds'++prettyAfter :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc+prettyAfter dAfter = foldMap (\d -> d <> dAfter)++-- | Traverse over the functor in a 'Dims' value with a functor bound type.+--+-- For example, to turn a @'Dims' t ('Maybe' a)@ into a @'Maybe' ('Dims' t a)@.+dimsTraverse :: (Traversable t, Applicative f) => Dims t (f a) -> f (Dims t a)+dimsTraverse = traverse id+-- TODO provide a SPECIALIZE clause for the above Maybe case. performance! :)++-- | How many dimensions does the given 'Dims' represent?+dimsLength :: Foldable t => Dims t a -> Int+dimsLength = \case+ DimsExplicitShape ds -> length ds+ DimsAssumedShape ss -> length ss+ DimsAssumedSize mds _d ->+ case mds of+ Nothing -> 1+ Just ds -> length ds + 1
src/Language/Fortran/Parser.hs view
@@ -17,6 +17,7 @@ , f66, f77, f77e, f77l, f90, f95, f2003 -- * Main parsers without post-parse transformation+ , byVerNoTransform , f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform , f90NoTransform, f95NoTransform, f2003NoTransform @@ -29,6 +30,10 @@ , f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform , f77lStmtNoTransform, f90StmtNoTransform, f95StmtNoTransform , f2003StmtNoTransform+ , byVerInclude+ , f66IncludesNoTransform, f77IncludesNoTransform, f77eIncludesNoTransform+ , f77lIncludesNoTransform, f90IncludesNoTransform, f95IncludesNoTransform+ , f2003IncludesNoTransform -- * Various combinators , transformAs, defaultTransformation@@ -38,11 +43,14 @@ , initParseStateFixedExpr, initParseStateFreeExpr , parseUnsafe , collectTokensSafe, collectTokens+ , throwIOLeft -- * F77 with inlined includes -- $f77includes- , f77lIncludes- , f77lIncIncludes+ , byVerInlineIncludes+ , f66InlineIncludes, f77InlineIncludes, f77eInlineIncludes+ , f77lInlineIncludes, f90InlineIncludes , f95InlineIncludes+ , f2003InlineIncludes ) where import Language.Fortran.AST@@ -85,11 +93,16 @@ { errorPos :: Position , errorFilename :: String , errorMsg :: String- } deriving (Exception)+ } deriving anyclass (Exception) instance Show ParseErrorSimple where show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err +-- | May be used to lift parse results into IO and force unwrap.+throwIOLeft :: (Exception e, MonadIO m) => Either e a -> m a+throwIOLeft = \case Right a -> pure a+ Left e -> liftIO $ throwIO e+ -------------------------------------------------------------------------------- byVer :: FortranVersion -> Parser (ProgramFile A0)@@ -169,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@@ -285,55 +310,79 @@ Can be cleaned up and generalized to use for other parsers. -} -f77lIncludes- :: [FilePath] -> ModFiles -> String -> B.ByteString- -> IO (ProgramFile A0)-f77lIncludes 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 (f77lIncludesInline incs []) pf') Map.empty- let pf''' = runTransform (combinedTypeEnv mods)- (combinedModuleMap mods)- (defaultTransformation Fortran77Legacy)- pf''- return pf'''+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 --- | Entry point for include files--- --- We can't perform full analysis (though it might be possible to do in future)--- but the AST is enough for certain types of analysis/refactoring-f77lIncIncludes- :: [FilePath] -> String -> B.ByteString -> IO [Block A0]-f77lIncIncludes incs fn bs =- case makeParserFixed F77.includesParser Fortran77Legacy fn bs of+byVerInlineIncludes+ :: FortranVersion -> [FilePath] -> ModFiles -> String -> B.ByteString+ -> IO (ProgramFile A0)+byVerInlineIncludes version incs mods fn bs = do+ case byVerNoTransform version fn bs of Left e -> liftIO $ throwIO e- Right bls ->- evalStateT (descendBiM (f77lIncludesInline incs []) bls) Map.empty--f77lIncludesInner :: Parser [Block A0]-f77lIncludesInner = makeParserFixed F77.includesParser Fortran77Legacy+ 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''' -f77lIncludesInline- :: [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)-f77lIncludesInline dirs seen st = case st of- StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do- if notElem path seen then do- incMap <- get- case Map.lookup path incMap of- Just blocks' -> pure $ StInclude a s e (Just blocks')- Nothing -> do- (fullPath, inc) <- liftIO $ readInDirs dirs path- case f77lIncludesInner fullPath inc of- Right blocks -> do- blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks- modify (Map.insert path blocks')- return $ StInclude a s e (Just blocks')- Left err -> liftIO $ throwIO err- else return st- _ -> return st+parserInlineIncludes version dirs = go+ where+ go seen st = case st of+ StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> 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 byVerInclude version fullPath incBs of+ Right blocks -> do+ blocks' <- descendBiM (go (path:seen)) blocks+ modify (Map.insert path blocks')+ pure $ StInclude a s e (Just blocks')+ Left err -> liftIO $ throwIO err+ else pure st+ _ -> pure st++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
src/Language/Fortran/Parser/Fixed/Fortran66.y view
@@ -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 }
src/Language/Fortran/Parser/Fixed/Fortran77.y view
@@ -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.
src/Language/Fortran/Parser/Fixed/Lexer.x view
@@ -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 }@@ -943,8 +943,8 @@ | posAbsoluteOffset _position == aiEndOffset ai = Nothing -- Skip the continuation line altogether | isContinuation ai && _isWhiteInsensitive = skip Continuation ai- -- Skip the newline before a comment- | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive+ -- Skip comment lines "between" continuations+ | aiFortranVersion ai >= Fortran77 && _isWhiteInsensitive && isNewlineCommentsFollowedByContinuation ai = skip NewlineComment ai -- If we are not parsing a Hollerith skip whitespace | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai@@ -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
src/Language/Fortran/Parser/Free/Fortran2003.y view
@@ -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 }
src/Language/Fortran/Parser/Free/Fortran90.y view
@@ -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 ')'
src/Language/Fortran/Parser/Free/Fortran95.y view
@@ -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 -} { [ ] }
src/Language/Fortran/Parser/Free/Lexer.x view
@@ -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)@@ -88,7 +88,7 @@ <0> "/*" { skipCComment } <0,scN> "!".*$ { adjustComment $ addSpanAndMatch TComment } -<0> $hash.*$ { lexHash }+<0> $hash.*(\n\r|\r\n|\n) { resetPar >> toSC 0 >> lexHash } <0,scN,scT> (\n\r|\r\n|\n) { resetPar >> toSC 0 >> addSpan TNewline } <0,scN,scI,scT> [\t\ ]+ ;@@ -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@@ -1050,6 +1070,8 @@ then _advance ai 3 else if _curChar == '!' then _advance ai 2+ else if _curChar == '#'+ then _pragma ai "" else if _curChar == '&' -- This state accepts as if there were no spaces between the broken -- line and whatever comes after second &. This is implicitly state (4)@@ -1065,7 +1087,15 @@ case advanceWithoutContinuation ai of Just ai'' -> _skipCont ai'' state Nothing -> error "File has ended prematurely during a continuation."+ -- special handling for line pragmas inside continuations+ _pragma ai revstr =+ if currentChar ai == '\n'+ then _advance (processLinePragma (reverse revstr) ai) (3 :: Integer)+ else case advanceWithoutContinuation ai of+ Just ai'' -> _pragma ai'' (currentChar ai:revstr)+ Nothing -> error "File has ended prematurely during a continuation." + -- skip a C comment (read until first "*/") skipCComment :: LexAction (Maybe Token) skipCComment = do@@ -1093,22 +1123,37 @@ _line = posLine position _absl = posAbsoluteOffset position +processLinePragma :: String -> AlexInput -> AlexInput+processLinePragma m 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) lexHash = do ai <- getAlex- m <- getMatch- case words (drop 1 m) of- -- 'line' pragma - rewrite the current line and filename- "line":lineStr:_- | line <- readIntOrBoz lineStr -> do- let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"")- let file = revdropWNQ . revdropWNQ $ m- let lineOffs = fromIntegral line - posLine (aiPosition ai) - 1- let newP = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file)- , posColumn = 1 }- putAlex $ ai { aiPosition = newP }- _ -> return ()+ let m = reverse . lexemeMatch . aiLexeme $ ai+ putAlex $ processLinePragma m ai return Nothing --------------------------------------------------------------------------------@@ -1227,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
src/Language/Fortran/Parser/LexerUtils.hs view
@@ -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
src/Language/Fortran/Parser/Monad.hs view
@@ -78,9 +78,22 @@ newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a } -instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where- return a = Parse $ \s -> ParseOk a s+instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where+ fmap f (Parse p) = Parse $ \s -> case p s of+ ParseOk a s' -> ParseOk (f a) s'+ ParseFailed e -> ParseFailed e +instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where+ pure a = Parse $ \s -> ParseOk a s+ (Parse pl) <*> (Parse pr) = Parse $ \s ->+ case pl s of+ ParseFailed e -> ParseFailed e+ ParseOk ab s' ->+ case pr s' of+ ParseFailed e -> ParseFailed e+ ParseOk a s'' -> ParseOk (ab a) s''++instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where (Parse m) >>= f = Parse $ \s -> case m s of ParseOk a s' -> unParse (f a) s'@@ -97,13 +110,6 @@ , errLastToken = (getLastToken . psAlexInput) s , errFilename = psFilename s , errMsg = msg }--instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where- fmap = liftM--instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where- pure = return- (<*>) = ap instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where get = Parse $ \s -> ParseOk s s
src/Language/Fortran/PrettyPrint.hs view
@@ -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)@@ -1134,7 +1149,11 @@ -- Ensures that no non-comment line exceeds 72 columns. -- -- The reformatting should be compatible with fixed and free-form Fortran--- standards. See: http://fortranwiki.org/fortran/show/Continuation+lines+-- standards, so called `intersection` format. In this format the+-- last statement character should not be placed after column 72, however+-- continuation character should be put at column 73 (it should be ignored in+-- fixed-form language)+-- See: http://fortranwiki.org/fortran/show/Continuation+lines -- -- This is a simple, delicate algorithm that must only be used on pretty printer -- output, due to relying on particular parser & pretty printer behaviour. In@@ -1165,17 +1184,11 @@ -- in statement: break when required go (RefmtStStmt col) (x:xs)- | col == maxCol =- -- lookahead: if next is newline or EOF, we don't need to break- case xs of- [] -> x : go (RefmtStStmt (col+1)) xs- x':_ ->- case x' of- '\n' -> x : go (RefmtStStmt (col+1)) xs- _ ->- -- pretend to continue, but we know that we'll break- -- on newline next- '&' : go (RefmtStStmt (col+1)) ("\n &" ++ x:xs)+ -- Checking if we are at column 73, since col is counted from 0!+ | col == maxCol && x == '&' = -- already a continuation in `intersection` format+ '&' : go (RefmtStStmt (col+1)) xs+ | col == maxCol = -- making continuation+ '&' : '\n' : go stNewline (" &" ++ x:xs) | otherwise = x : go (RefmtStStmt (col+1)) xs maxCol = 72
src/Language/Fortran/Repr.hs view
@@ -11,6 +11,13 @@ The aims for this representation are _correctness_ and _efficiency_. All values store enough information on the type level to recover their precise Fortran type via inspection.++TODO++ * Data (SYB) doesn't play nice with GADTs. They *are* entirely possible+ together with singletons, but remain extremely finicky. It was a source of+ issues during development. So no nice GADTs :(+ -} module Language.Fortran.Repr@@ -28,7 +35,6 @@ -- * Re-exports -- ** Fortran types module Language.Fortran.Repr.Type- , module Language.Fortran.Repr.Type.Array , module Language.Fortran.Repr.Type.Scalar , module Language.Fortran.Repr.Type.Scalar.Common , module Language.Fortran.Repr.Type.Scalar.Int@@ -38,7 +44,6 @@ -- ** Fortran values , module Language.Fortran.Repr.Value- , module Language.Fortran.Repr.Value.Array , module Language.Fortran.Repr.Value.Scalar , module Language.Fortran.Repr.Value.Scalar.Common , module Language.Fortran.Repr.Value.Scalar.Int@@ -49,7 +54,6 @@ ) where import Language.Fortran.Repr.Type-import Language.Fortran.Repr.Type.Array import Language.Fortran.Repr.Type.Scalar import Language.Fortran.Repr.Type.Scalar.Common import Language.Fortran.Repr.Type.Scalar.Int@@ -58,7 +62,6 @@ import Language.Fortran.Repr.Type.Scalar.String import Language.Fortran.Repr.Value-import Language.Fortran.Repr.Value.Array import Language.Fortran.Repr.Value.Scalar import Language.Fortran.Repr.Value.Scalar.Common import Language.Fortran.Repr.Value.Scalar.Int
src/Language/Fortran/Repr/Eval/Common.hs view
@@ -1,23 +1,35 @@+-- | Common Fortran evaluation definitions.+ module Language.Fortran.Repr.Eval.Common where import qualified Language.Fortran.AST as F -{- | Monads which provide functionality to evaluate some Fortran type or value.+{- | Monads which provide functionality to evaluate Fortran expressions in some+ static context. -We abstract over the evaluation target type in order to reuse this for both-value evaluation, and "type evaluation", since there is (a small amount of)-overlap.+Actions in this monad may -Instances of this class will have a way to access variables in the current-context (e.g. a @Reader@ over a @Map@), and log warnings (e.g. a @Writer-String@).+ * request the value of a variable (may return 'Nothing' if not in scope)+ * record some user-facing information concerning evaluation++As usage examples, a simple pure evaluator may use a plain map of 'F.Name' to+@'EvalTo' m@. A more complex type evaluator may allow "defaulting" for variables+not in scope via IMPLICIT rules.++The associated type family 'EvalTo' enables using this for both type and value+evaluators. -}-class Monad m => MonadEval m where+class Monad m => MonadFEval m where -- | Target type that we evaluate to. type EvalTo m++ -- | Request the value of a variable.+ --+ -- Returns 'Nothing' if the variable is not in scope. lookupFVar :: F.Name -> m (Maybe (EvalTo m)) - -- | Arbitrarily record some user-facing information concerning evaluation.+ -- | Record some user-facing information concerning evaluation. --- -- For example, potentially useful when making defaulting decisions.+ -- For example, you may want to inform the user when you've made a+ -- defaulting decision. warn :: String -> m ()
src/Language/Fortran/Repr/Eval/Type.hs view
@@ -7,10 +7,12 @@ import Language.Fortran.Repr.Eval.Common fromExpression- :: forall m a. (MonadEval m, EvalTo m ~ FType)+ :: forall m a. (MonadFEval m, EvalTo m ~ FType) => F.Expression a -> m (Either String FType) fromExpression = \case F.ExpValue _ _ (F.ValVariable name) -> lookupFVar name >>= \case Nothing -> return $ Left "no such variable found TODO" Just val -> return $ Right val++-- TODO support for IMPLICIT rules
src/Language/Fortran/Repr/Eval/Value.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingVia #-} -- | Evaluate AST terms to values in the value representation. @@ -18,71 +19,96 @@ import Language.Fortran.Repr.Value.Scalar.String import Language.Fortran.Repr.Type ( FType )+import Language.Fortran.Repr.Type.Scalar.Common ( FKindLit )+import Language.Fortran.Repr.Type.Scalar ( fScalarTypeKind ) import Language.Fortran.Repr.Eval.Common import qualified Language.Fortran.Repr.Eval.Value.Op as Op +import qualified Language.Fortran.Analysis as FA+ import GHC.Generics ( Generic ) import qualified Data.Text as Text import qualified Data.Char import qualified Data.Bits+import Data.Int import Control.Monad.Except --- simple implementation+import Data.Word ( Word8 )++-- pure implementation import Control.Monad.Reader import Control.Monad.Writer import qualified Data.Map as Map import Data.Map ( Map ) --- | A convenience type over 'MonadEval' bringing all requirements into scope.-type MonadEvalValue m = (MonadEval m, EvalTo m ~ FValue, MonadError Error m)---- | Value evaluation error.+-- | Error encountered while evaluating a Fortran expression to a value. data Error = ENoSuchVar F.Name | EKindLitBadType F.Name FType- | ENoSuchKindForType String KindLit+ | ENoSuchKindForType String FKindLit+ | EUnsupported String+ -- ^ Syntax which probably should be supported, but (currently) isn't.+ | EOp Op.Error | EOpTypeError String++ | ESpecial String+ -- ^ Special value-like expression that we can't evaluate usefully.+ | ELazy String -- ^ Catch-all for non-grouped errors.+ deriving stock (Generic, Show, Eq) --- TODO best for temp KPs: String, Integer, Text? Word8??-type KindLit = String+-- | A convenience constraint tuple defining the base requirements of the+-- 'FValue' evaluator.+--+-- The evaluator is formed of combinators returning values in this monad. You+-- may insert your own evaluator which handles monadic actions differently,+-- provided it can fulfill these constraints.+type MonadFEvalValue m = (MonadFEval m, EvalTo m ~ FValue, MonadError Error m) -------------------------------------------------------------------------------- +-- | derivingvia helper+type FEvalValuePureT = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))+ -- | A simple pure interpreter for Fortran value evaluation programs.-type EvalValueSimple = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))+newtype FEvalValuePure a = FEvalValuePure { unFEvalValuePure :: WriterT [String] (ExceptT Error (Reader (Map F.Name FValue))) a }+ deriving (Functor, Applicative, Monad) via FEvalValuePureT+ deriving (MonadReader (Map F.Name FValue)) via FEvalValuePureT+ deriving (MonadWriter [String]) via FEvalValuePureT+ deriving (MonadError Error) via FEvalValuePureT -instance MonadEval EvalValueSimple where- type EvalTo EvalValueSimple = FValue+instance MonadFEval FEvalValuePure where+ type EvalTo FEvalValuePure = FValue warn msg = tell [msg] lookupFVar nm = do m <- ask pure $ Map.lookup nm m -runEvalValueSimple+runEvalFValuePure :: Map F.Name FValue- -> EvalValueSimple a -> Either Error (a, [String])-runEvalValueSimple m = flip runReader m . runExceptT . runWriterT+ -> FEvalValuePure a -> Either Error (a, [String])+runEvalFValuePure m =+ flip runReader m . runExceptT . runWriterT . unFEvalValuePure -------------------------------------------------------------------------------- -evalVar :: MonadEvalValue m => F.Name -> m FValue+evalVar :: MonadFEvalValue m => F.Name -> m FValue evalVar name = lookupFVar name >>= \case Nothing -> err $ ENoSuchVar name- Just val -> return val+ Just val -> pure val -evalExpr :: MonadEvalValue 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@@ -101,33 +127,33 @@ 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 :: MonadEvalValue m => F.Value a -> m FScalarValue+evalLit :: MonadFEvalValue m => F.Value (FA.Analysis a) -> m FScalarValue evalLit = \case F.ValInteger i mkp -> do- evalKp "4" mkp >>= \case- "4" -> return $ FSVInt $ SomeFKinded $ FInt4 $ read i- "8" -> return $ FSVInt $ SomeFKinded $ FInt8 $ read i- "2" -> return $ FSVInt $ SomeFKinded $ FInt2 $ read i- "1" -> return $ FSVInt $ SomeFKinded $ FInt1 $ read i- k -> err $ ENoSuchKindForType "INTEGER" k+ evalMKp 4 mkp >>= \case+ 4 -> pure $ FSVInt $ FInt4 $ read i+ 8 -> pure $ FSVInt $ FInt8 $ read i+ 2 -> pure $ FSVInt $ FInt2 $ read i+ 1 -> pure $ FSVInt $ FInt1 $ read i+ k -> err $ ENoSuchKindForType "INTEGER" k F.ValReal r mkp -> do evalRealKp (F.exponentLetter (F.realLitExponent r)) mkp >>= \case- "4" -> return $ FSVReal $ SomeFKinded $ FReal4 $ F.readRealLit r- "8" -> return $ FSVReal $ SomeFKinded $ FReal8 $ F.readRealLit r- k -> err $ ENoSuchKindForType "REAL" k+ 4 -> pure $ FSVReal $ FReal4 $ F.readRealLit r+ 8 -> pure $ FSVReal $ FReal8 $ F.readRealLit r+ k -> err $ ENoSuchKindForType "REAL" k F.ValLogical b mkp -> do- evalKp "4" mkp >>= \case- "4" -> return $ FSVLogical $ SomeFKinded $ FInt4 $ fLogicalNumericFromBool b- "8" -> return $ FSVLogical $ SomeFKinded $ FInt8 $ fLogicalNumericFromBool b- "2" -> return $ FSVLogical $ SomeFKinded $ FInt2 $ fLogicalNumericFromBool b- "1" -> return $ FSVLogical $ SomeFKinded $ FInt1 $ fLogicalNumericFromBool b- k -> err $ ENoSuchKindForType "LOGICAL" k+ evalMKp 4 mkp >>= \case+ 4 -> pure $ FSVLogical $ FInt4 $ fLogicalNumericFromBool b+ 8 -> pure $ FSVLogical $ FInt8 $ fLogicalNumericFromBool b+ 2 -> pure $ FSVLogical $ FInt2 $ fLogicalNumericFromBool b+ 1 -> pure $ FSVLogical $ FInt1 $ fLogicalNumericFromBool b+ k -> err $ ENoSuchKindForType "LOGICAL" k F.ValComplex (F.ComplexLit _ _ _cr _ci) -> -- TODO annoying & tedious. see Fortran 2008 spec 4.4.2.4 -- 1. evaluate each part@@ -136,74 +162,69 @@ -- 3. upgrade both parts to that kind -- 4. package and return err $ EUnsupported "COMPLEX literals"- F.ValString s -> return $ FSVString $ someFString $ Text.pack s+ F.ValString s -> pure $ FSVString $ Text.pack s F.ValBoz boz -> do warn "requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)"- return $ FSVInt $ SomeFKinded $ FInt4 $ F.bozAsTwosComp boz- F.ValHollerith s -> return $ FSVString $ someFString $ Text.pack s- F.ValIntrinsic{} -> error "you tried to evaluate a lit, but it was an intrinsic name"- F.ValVariable{} -> error "you tried to evaluate a lit, but it was a variable name"- F.ValOperator{} -> error "you tried to evaluate a lit, but it was a custom operator name"- F.ValAssignment -> error "you tried to evaluate a lit, but it was an overloaded assignment name"- F.ValStar -> error "you tried to evaluate a lit, but it was a star"- F.ValColon -> error "you tried to evaluate a lit, but it was a colon"- F.ValType{} -> error "not used anywhere, don't know what it is"+ pure $ FSVInt $ FInt4 $ F.bozAsTwosComp boz+ F.ValHollerith s -> pure $ FSVString $ Text.pack s+ F.ValIntrinsic{} -> err $ ESpecial "lit was ValIntrinsic{} (intrinsic name)"+ F.ValVariable{} -> err $ ESpecial "lit was ValVariable{} (variable name)"+ F.ValOperator{} -> err $ ESpecial "lit was ValOperator{} (custom operator name)"+ F.ValAssignment -> err $ ESpecial "lit was ValAssignment (overloaded assignment name)"+ F.ValStar -> err $ ESpecial "lit was ValStar"+ F.ValColon -> err $ ESpecial "lit was ValColon"+ F.ValType{} -> err $ ELazy "lit was ValType: not used anywhere, don't know what it is" err :: MonadError Error m => Error -> m a err = throwError -evalKp :: MonadEvalValue m => KindLit -> Maybe (F.KindParam a) -> m KindLit-evalKp kDef = \case- Nothing -> return kDef- Just kp -> case kp of- F.KindParamInt _ _ k -> return k- F.KindParamVar _ _ var ->- lookupFVar var >>= \case- Just val -> case val of- MkFScalarValue (FSVInt (SomeFKinded i)) ->- return $ fIntUOp' show show show show i- _ -> err $ EKindLitBadType var (fValueType val)- Nothing -> err $ ENoSuchVar var+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+ -- easy check is length (<=3)+ -- to catch the rest, we may need to read to Int16 and check.+ -- slow and unideal so for now let's assume no bad play such as INTEGER(256)+ pure $ read k+ F.KindParamVar _ _ var ->+ lookupFVar var >>= \case+ Just val -> case val of+ MkFScalarValue (FSVInt i) ->+ pure $ fIntUOp fromIntegral i+ _ -> err $ EKindLitBadType var (fValueType val)+ Nothing -> err $ ENoSuchVar var +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 :: MonadEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m KindLit-evalRealKp l mkp =- kindViaKindParam >>= \case- Nothing ->- case l of- F.ExpLetterE -> pure "4"- F.ExpLetterD -> pure "8"- F.ExpLetterQ -> do- warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"- evalRealKp F.ExpLetterD mkp- Just kkp ->- case l of- F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param- pure kkp- F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical- warn $ "TODO exponent letter wasn't E but you gave kind parameter."- <> "\nthis isn't allowed, but we'll default to"- <> " using kind parameter"- pure kkp- F.ExpLetterQ -> do- warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"- evalRealKp F.ExpLetterD mkp- where- kindViaKindParam =- case mkp of- Nothing -> pure Nothing- Just kp -> case kp of- F.KindParamInt _ _ k -> pure $ Just k- F.KindParamVar _ _ var ->- lookupFVar var >>= \case- Just val -> case val of- MkFScalarValue (FSVInt (SomeFKinded i)) ->- pure $ Just $ fIntUOp' show show show show i- _ -> err $ EKindLitBadType var (fValueType val)- Nothing -> err $ ENoSuchVar var+evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit+evalRealKp l = \case+ Nothing ->+ case l of+ F.ExpLetterE -> pure 4+ F.ExpLetterD -> pure 8+ F.ExpLetterQ -> do+ warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"+ pure 8+ Just kp -> do+ k <- evalKp kp+ case l of+ F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param+ pure k+ F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical+ warn $ "TODO exponent letter wasn't E but you gave kind parameter."+ <> "\nthis isn't allowed, but we'll default to"+ <> " using kind parameter"+ pure k+ F.ExpLetterQ -> do+ warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"+ pure 8 -evalUOp :: MonadEvalValue m => F.UnaryOp -> FValue -> m FValue+evalUOp :: MonadFEvalValue m => F.UnaryOp -> FValue -> m FValue evalUOp op v = do v' <- forceScalar v case op of@@ -211,28 +232,28 @@ F.Minus -> wrapSOp $ Op.opIcNumericUOpInplace negate v' F.Not -> -- TODO move this to Op (but logicals are a pain) case v' of- FSVLogical (SomeFKinded bi) ->- return $ MkFScalarValue $ FSVLogical $ SomeFKinded $ fLogicalNot bi+ FSVLogical bi ->+ pure $ MkFScalarValue $ FSVLogical $ fLogicalNot bi _ -> err $ EOp $ Op.EBadArgType1 ["LOGICAL"] $ fScalarValueType v' _ -> err $ EUnsupported $ "operator: " <> show op -wrapOp :: MonadEvalValue m => Either Op.Error a -> m a+wrapOp :: MonadFEvalValue m => Either Op.Error a -> m a wrapOp = \case- Right a -> return a+ Right a -> pure a Left e -> err $ EOp e -- | Wrap the output of an operation that returns a scalar value into the main -- evaluator.-wrapSOp :: MonadEvalValue m => Either Op.Error FScalarValue -> m FValue+wrapSOp :: MonadFEvalValue m => Either Op.Error FScalarValue -> m FValue wrapSOp = \case- Right a -> return $ MkFScalarValue a+ Right a -> pure $ MkFScalarValue a Left e -> err $ EOp e -- | Evaluate explicit binary operators (ones denoted as such in the AST). -- -- Note that this does not cover all binary operators -- there are many -- intrinsics which use function syntax, but are otherwise binary operators.-evalBOp :: MonadEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue+evalBOp :: MonadFEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue evalBOp bop l r = do -- TODO also see evalExpr: implement short-circuit eval here l' <- forceScalar l@@ -246,13 +267,23 @@ -- TODO confirm correct operation (not checked much) F.Division -> wrapSOp $ Op.opIcNumericBOpRealIntSep (div) (/) l' r' - F.Exponentiation -> -- TODO not looked, certainly custom- err $ EUnsupported "exponentiation"+ -- TODO basic - ints only. probably should support floats too.+ F.Exponentiation ->+ 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) ->- return $ MkFScalarValue $ FSVString $ concatSomeFString ls rs+ pure $ MkFScalarValue $ FSVString $ ls <> rs _ -> err $ ELazy "concat strings only please" F.GT -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (>) l' r')@@ -278,12 +309,21 @@ defFLogical :: Bool -> FValue defFLogical =- MkFScalarValue . FSVLogical . SomeFKinded . FInt4 . fLogicalNumericFromBool+ MkFScalarValue . FSVLogical . FInt4 . fLogicalNumericFromBool -evalFunctionCall :: MonadEvalValue m => F.Name -> [FValue] -> m FValue+evalFunctionCall :: MonadFEvalValue m => F.Name -> [FValue] -> m FValue evalFunctionCall fname args = case fname of + "kind" -> do+ args' <- forceArgs 1 args+ let [v] = args'+ v' <- forceScalar v+ let t = fScalarValueType v'+ case fScalarTypeKind t of+ Nothing -> err $ ELazy "called kind with non-kinded scalar"+ Just k -> pure $ MkFScalarValue $ FSVInt $ FInt4 (fromIntegral k)+ "ior" -> do args' <- forceArgs 2 args let [l, r] = args'@@ -298,10 +338,10 @@ let [v] = args' v' <- forceScalar v case v' of- FSVInt (SomeFKinded i) -> do+ FSVInt i -> do -- TODO better error handling let c = Data.Char.chr (fIntUOp fromIntegral i)- pure $ MkFScalarValue $ FSVString $ someFString $ Text.singleton c+ pure $ MkFScalarValue $ FSVString $ Text.singleton c _ -> err $ EOpTypeError $ "char: expected INT(x), got "<>show (fScalarValueType v')@@ -311,27 +351,26 @@ let [v] = args' v' <- forceScalar v case v' of- FSVInt (SomeFKinded i) -> do- pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ fIntUOpInplace Data.Bits.complement i+ FSVInt i -> do+ pure $ MkFScalarValue $ FSVInt $ fIntUOpInplace Data.Bits.complement i _ -> err $ EOpTypeError $ "not: expected INT(x), got "<>show (fScalarValueType v') - "int" -> do- -- TODO a real pain. just implementing common bits for now- -- TODO gfortran actually performs some range checks for constants!- -- @int(128, 1)@ errors with "this INT(4) is too big for INT(1)".- args' <- forceArgs 1 args- let [v] = args'- v' <- forceScalar v- case v' of- FSVInt{} ->- pure $ MkFScalarValue v'- FSVReal (SomeFKinded r) ->- pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt4 $ fRealUOp truncate r- _ ->- err $ EOpTypeError $- "int: unsupported or unimplemented type: "<>show (fScalarValueType v')+ "int" ->+ case args of+ [] -> err $ EOpTypeError $ "int: expected 1 or 2 arguments, got 0"+ [v] -> do+ -- @INT(x)@ == @INT(x, 4)@ (F2018 16.9.100:23, pg.381)+ (MkFScalarValue . FSVInt . FInt4) <$> evalIntrinsicInt4 v+ [v, vk] -> do+ vk' <- forceScalar vk+ case vk' of+ FSVInt vkI -> (MkFScalarValue . FSVInt) <$> evalIntrinsicInt v vkI+ _ ->+ err $ EOpTypeError $+ "int: kind argument must be INTEGER, got "<>show (fScalarValueType vk')+ _ -> err $ EOpTypeError $ "int: expected 1 or 2 arguments, got >2" -- TODO all lies "int2" -> do@@ -341,15 +380,61 @@ case v' of FSVInt{} -> pure $ MkFScalarValue v'- FSVReal (SomeFKinded r) ->- pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt2 $ fRealUOp truncate r+ FSVReal r ->+ pure $ MkFScalarValue $ FSVInt $ FInt2 $ fRealUOp truncate r _ -> err $ EOpTypeError $ "int: unsupported or unimplemented type: "<>show (fScalarValueType v') _ -> err $ EUnsupported $ "function call: " <> fname -evalArg :: MonadEvalValue m => F.Argument a -> m FValue+-- TODO 2023-05-03 raehik: gfortran actually performs some range checks for+-- constants! @int(128, 1)@ errors with "this INT(4) is too big for INT(1)".+-- we don't do that currently. just means more plumbing+evalIntrinsicInt :: MonadFEvalValue m => FValue -> FInt -> m FInt+evalIntrinsicInt v = fIntUOp go+ where+ go :: (MonadFEvalValue m, Num a, Eq a) => a -> m FInt+ go = \case+ 1 -> FInt1 <$> evalIntrinsicInt1 v+ 2 -> FInt2 <$> evalIntrinsicInt2 v+ 4 -> FInt4 <$> evalIntrinsicInt4 v+ 8 -> FInt8 <$> evalIntrinsicInt8 v+ _ -> err $ ELazy "int: kind argument wasn't 1, 2, 4 or 8"++-- | @INT(a, 1)@+evalIntrinsicInt1 :: MonadFEvalValue m => FValue -> m Int8+evalIntrinsicInt1 = evalIntrinsicIntXCoerce coerceToI1+ where coerceToI1 = fIntUOp' id fromIntegral fromIntegral fromIntegral++-- | @INT(a, 2)@+evalIntrinsicInt2 :: MonadFEvalValue m => FValue -> m Int16+evalIntrinsicInt2 = evalIntrinsicIntXCoerce coerceToI2+ where coerceToI2 = fIntUOp' fromIntegral id fromIntegral fromIntegral++-- | @INT(a, 4)@, @INT(a)@+evalIntrinsicInt4 :: MonadFEvalValue m => FValue -> m Int32+evalIntrinsicInt4 = evalIntrinsicIntXCoerce coerceToI4+ where coerceToI4 = fIntUOp' fromIntegral fromIntegral id fromIntegral++-- | @INT(a, 8)@+evalIntrinsicInt8 :: MonadFEvalValue m => FValue -> m Int64+evalIntrinsicInt8 = evalIntrinsicIntXCoerce coerceToI8+ where coerceToI8 = fIntUOp' fromIntegral fromIntegral fromIntegral id++evalIntrinsicIntXCoerce+ :: forall r m+ . (MonadFEvalValue m, Integral r) => (FInt -> r) -> FValue -> m r+evalIntrinsicIntXCoerce coerceToIX v = do+ v' <- forceScalar v+ case v' of+ FSVInt i -> pure $ coerceToIX i+ FSVReal r -> pure $ fRealUOp truncate r+ _ ->+ err $ EOpTypeError $+ "int: unsupported or unimplemented type: "<>show (fScalarValueType v')++evalArg :: MonadFEvalValue m => F.Argument (FA.Analysis a) -> m FValue evalArg (F.Argument _ _ _ ae) = case ae of F.ArgExpr e -> evalExpr e@@ -357,33 +442,35 @@ -------------------------------------------------------------------------------- -forceScalar :: MonadEvalValue m => FValue -> m FScalarValue+-- exists because we used to support arrays (now stripped)+forceScalar :: MonadFEvalValue m => FValue -> m FScalarValue forceScalar = \case- MkFArrayValue{} -> err $ EUnsupported "no array values in eval for now thx"- MkFScalarValue v' -> return v'+ MkFScalarValue v' -> pure v' -forceUnconsArg :: MonadEvalValue m => [a] -> m (a, [a])+forceUnconsArg :: MonadFEvalValue m => [a] -> m (a, [a]) forceUnconsArg = \case [] -> err $ EOpTypeError "not enough arguments"- a:as -> return (a, as)+ a:as -> pure (a, as) -- TODO can I use vector-sized to improve safety here? lol -- it's just convenience either way-forceArgs :: MonadEvalValue m => Int -> [a] -> m [a]+forceArgs :: MonadFEvalValue m => Int -> [a] -> m [a] forceArgs numArgs l = if length l == numArgs- then return l+ then pure l else err $ EOpTypeError $ "expected "<>show numArgs<>" arguments; got "<>show (length l) evalIntrinsicIor- :: MonadEvalValue m => FScalarValue -> FScalarValue -> m FValue-evalIntrinsicIor l r = wrapSOp $ FSVInt <$> Op.opIor l r+ :: MonadFEvalValue m => FScalarValue -> FScalarValue -> m FValue+evalIntrinsicIor l r = case (l, r) of+ (FSVInt li, FSVInt ri) -> wrapSOp $ FSVInt <$> Op.opIor li ri+ _ -> err $ ELazy "ior: bad args" -- https://gcc.gnu.org/onlinedocs/gfortran/MAX.html -- TODO should support arrays! at least for >=F2010 evalIntrinsicMax- :: MonadEvalValue m => [FValue] -> m FValue+ :: MonadFEvalValue m => [FValue] -> m FValue evalIntrinsicMax = \case [] -> err $ EOpTypeError "max intrinsic expects at least 1 argument" v:vs -> do@@ -413,3 +500,7 @@ _ -> err $ EOpTypeError $ "max: unsupported type: "<> show (fScalarValueType vCurMax)++-- | Evaluate a constant expression (F2018 10.1.12).+evalConstExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue+evalConstExpr = evalExpr
src/Language/Fortran/Repr/Eval/Value/Op.hs view
@@ -2,8 +2,6 @@ module Language.Fortran.Repr.Eval.Value.Op where -import Language.Fortran.Repr.Eval.Value.Op.Some- import Language.Fortran.Repr.Value.Scalar.Machine import Language.Fortran.Repr.Value.Scalar.Common import Language.Fortran.Repr.Value.Scalar.Int.Machine@@ -28,15 +26,15 @@ deriving stock (Show, Eq) -- https://gcc.gnu.org/onlinedocs/gfortran/DBLE.html#DBLE-opIcDble :: FScalarValue -> Either Error (FReal 'FTReal8)+opIcDble :: FScalarValue -> Either Error FReal opIcDble = \case- FSVComplex (SomeFKinded c) -> case c of+ FSVComplex c -> case c of FComplex8 r _i -> rfr8 $ float2Double r FComplex16 r _i -> rfr8 r- FSVReal (SomeFKinded r) -> case r of+ FSVReal r -> case r of FReal4 r' -> rfr8 $ float2Double r' FReal8 _r' -> Right r- FSVInt (SomeFKinded i) -> rfr8 $ withFInt i+ FSVInt i -> rfr8 $ withFInt i v -> eBadArgType1 ["COMPLEX", "REAL", "INT"] v where rfr8 = Right . FReal8 @@ -55,14 +53,14 @@ -> FScalarValue -> FScalarValue -> Either Error FScalarValue opIcNumericBOp bop = go where- go (FSVInt l) (FSVInt r) = Right $ FSVInt $ someFIntBOpWrap bop l r- go (FSVInt (SomeFKinded l)) (FSVReal r) =- Right $ FSVReal $ someFRealUOpWrap (\x -> withFInt l `bop` x) r+ go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bop l r+ go (FSVInt l) (FSVReal r) =+ Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bop` x) r -- TODO int complex- go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bop l r+ go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace bop l r go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) go (FSVReal l) (FSVComplex r) =- Right $ FSVComplex $ someFComplexBOpWrap bop (someFComplexFromReal l) r+ Right $ FSVComplex $ fComplexBOpInplace bop (fComplexFromReal l) r opIcNumericBOpRealIntSep :: (forall a. Integral a => a -> a -> a)@@ -70,36 +68,36 @@ -> FScalarValue -> FScalarValue -> Either Error FScalarValue opIcNumericBOpRealIntSep bopInt bopReal = go where- go (FSVInt l) (FSVInt r) = Right $ FSVInt $ someFIntBOpWrap bopInt l r- go (FSVInt (SomeFKinded l)) (FSVReal r) =- Right $ FSVReal $ someFRealUOpWrap (\x -> withFInt l `bopReal` x) r+ go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bopInt l r+ go (FSVInt l) (FSVReal r) =+ Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bopReal` x) r -- TODO int complex- go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bopReal l r+ go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace bopReal l r go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) go (FSVReal l) (FSVComplex r) =- Right $ FSVComplex $ someFComplexBOpWrap bopReal (someFComplexFromReal l) r+ Right $ FSVComplex $ fComplexBOpInplace bopReal (fComplexFromReal l) r opIcNumRelBOp :: (forall a. Ord a => a -> a -> r) -> FScalarValue -> FScalarValue -> Either Error r opIcNumRelBOp bop = go where- go (FSVInt l) (FSVInt r) = Right $ someFIntBOp bop l r- go (FSVInt (SomeFKinded l)) (FSVReal r) =- Right $ someFRealUOp (\x -> withFInt l `bop` x) r+ go (FSVInt l) (FSVInt r) = Right $ fIntBOp bop l r+ go (FSVInt l) (FSVReal r) =+ Right $ fRealUOp (\x -> withFInt l `bop` x) r -- TODO int complex- go (FSVReal l) (FSVReal r) = Right $ someFRealBOp bop l r+ go (FSVReal l) (FSVReal r) = Right $ fRealBOp bop l r go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) -- TODO real complex- go (FSVString l) (FSVString r) = Right $ someFStringBOp bop l r+ go (FSVString l) (FSVString r) = Right $ l `bop` r -- plus, minus opIcNumericUOpInplace :: (forall a. Num a => a -> a) -> FScalarValue -> Either Error FScalarValue opIcNumericUOpInplace uop = \case- FSVInt (SomeFKinded v) -> Right $ FSVInt $ SomeFKinded $ fIntUOpInplace uop v- FSVReal (SomeFKinded v) -> Right $ FSVReal $ SomeFKinded $ fRealUOpInplace uop v+ FSVInt v -> Right $ FSVInt $ fIntUOpInplace uop v+ FSVReal v -> Right $ FSVReal $ fRealUOpInplace uop v v -> eBadArgType1 ["INT", "REAL"] v -- and, or, eqv, neqv@@ -108,37 +106,30 @@ -> FScalarValue -> FScalarValue -> Either Error r opIcLogicalBOp bop = go where- go (FSVLogical (SomeFKinded l)) (FSVLogical (SomeFKinded r)) =+ go (FSVLogical l) (FSVLogical r) = Right $ bop (fLogicalToBool l) (fLogicalToBool r) go l r = eBadArgType2 ["LOGICAL"] l r opEq :: FScalarValue -> FScalarValue -> Either Error Bool opEq = go where- go (FSVInt l) (FSVInt r) = Right $ someFIntBOp (==) l r- go (FSVReal l) (FSVReal r) = Right $ someFRealBOp (==) l r- go (FSVInt (SomeFKinded l)) (FSVReal r) =- Right $ someFRealUOp (\x -> withFInt l == x) r- go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l)- go (FSVString l) (FSVString r) = Right $ someFStringBOp (==) l r+ go (FSVInt l) (FSVInt r) = Right $ fIntBOp (==) l r+ go (FSVReal l) (FSVReal r) = Right $ fRealBOp (==) l r+ go (FSVInt i) (FSVReal r) =+ Right $ fRealUOp (\x -> withFInt i == x) r+ go (FSVReal r) (FSVInt i) =+ Right $ fRealUOp (\x -> withFInt i == x) r+ go (FSVString l) (FSVString r) = Right $ l == r -- | According to gfortran spec and F2010 spec, same kind required.-opIor' :: FInt k -> FInt k -> FInt k+opIor' :: FInt -> FInt -> FInt opIor' = fIntBOpInplace (.|.) -opIor :: FScalarValue -> FScalarValue -> Either Error SomeFInt-opIor (FSVInt (SomeFKinded l)) (FSVInt (SomeFKinded r)) =+opIor :: FInt -> FInt -> Either Error FInt+opIor l r = case (l, r) of- (FInt4{}, FInt4{}) -> do- let out = opIor' l r- pure $ SomeFKinded out- (FInt8{}, FInt8{}) -> do- let out = opIor' l r- pure $ SomeFKinded out- (FInt2{}, FInt2{}) -> do- let out = opIor' l r- pure $ SomeFKinded out- (FInt1{}, FInt1{}) -> do- let out = opIor' l r- pure $ SomeFKinded out-opIor l r = eBadArgType2 ["INT", "INT"] l r+ (FInt4{}, FInt4{}) -> Right $ opIor' l r+ (FInt8{}, FInt8{}) -> Right $ opIor' l r+ (FInt2{}, FInt2{}) -> Right $ opIor' l r+ (FInt1{}, FInt1{}) -> Right $ opIor' l r+ _ -> Left $ EGeneric "bad args to ior"
− src/Language/Fortran/Repr/Eval/Value/Op/Some.hs
@@ -1,177 +0,0 @@-module Language.Fortran.Repr.Eval.Value.Op.Some where--import Language.Fortran.Repr.Value.Scalar.Common-import Language.Fortran.Repr.Value.Scalar.Int.Machine-import Language.Fortran.Repr.Value.Scalar.Real-import Language.Fortran.Repr.Value.Scalar.Complex--import Data.Int--someFIntUOpInplace'- :: (Int8 -> Int8)- -> (Int16 -> Int16)- -> (Int32 -> Int32)- -> (Int64 -> Int64)- -> SomeFInt -> SomeFInt-someFIntUOpInplace' k1f k2f k4f k8f (SomeFKinded i) = SomeFKinded $- fIntUOpInplace' k1f k2f k4f k8f i--someFIntUOp'- :: (Int8 -> r)- -> (Int16 -> r)- -> (Int32 -> r)- -> (Int64 -> r)- -> SomeFInt -> r-someFIntUOp' k1f k2f k4f k8f (SomeFKinded i) =- fIntUOp' k1f k2f k4f k8f i--someFIntUOp- :: (forall a. IsFInt a => a -> r)- -> SomeFInt -> r-someFIntUOp f = someFIntUOp' f f f f--someFIntUOpWrap'- :: (Int8 -> Int8)- -> (Int16 -> Int16)- -> (Int32 -> Int32)- -> (Int64 -> Int64)- -> SomeFInt -> SomeFInt-someFIntUOpWrap' k1f k2f k4f k8f (SomeFKinded i) =- fIntUOp' k1f' k2f' k4f' k8f' i- where- k1f' = SomeFKinded . FInt1 . k1f- k2f' = SomeFKinded . FInt2 . k2f- k4f' = SomeFKinded . FInt4 . k4f- k8f' = SomeFKinded . FInt8 . k8f--someFIntUOpWrap- :: (forall a. IsFInt a => a -> a)- -> SomeFInt -> SomeFInt-someFIntUOpWrap f = someFIntUOpWrap' f f f f--someFIntBOp'- :: (Int8 -> Int8 -> r)- -> (Int16 -> Int16 -> r)- -> (Int32 -> Int32 -> r)- -> (Int64 -> Int64 -> r)- -> SomeFInt -> SomeFInt -> r-someFIntBOp' k1f k2f k4f k8f (SomeFKinded il) (SomeFKinded ir) =- fIntBOp' k1f k2f k4f k8f il ir--someFIntBOp- :: (forall a. IsFInt a => a -> a -> r)- -> SomeFInt -> SomeFInt -> r-someFIntBOp f = someFIntBOp' f f f f--someFIntBOpWrap'- :: (Int8 -> Int8 -> Int8)- -> (Int16 -> Int16 -> Int16)- -> (Int32 -> Int32 -> Int32)- -> (Int64 -> Int64 -> Int64)- -> SomeFInt -> SomeFInt -> SomeFInt-someFIntBOpWrap' k1f k2f k4f k8f =- someFIntBOp' k1f' k2f' k4f' k8f'- where- k1f' l r = SomeFKinded $ FInt1 $ k1f l r- k2f' l r = SomeFKinded $ FInt2 $ k2f l r- k4f' l r = SomeFKinded $ FInt4 $ k4f l r- k8f' l r = SomeFKinded $ FInt8 $ k8f l r--someFIntBOpWrap- :: (forall a. IsFInt a => a -> a -> a)- -> SomeFInt -> SomeFInt -> SomeFInt-someFIntBOpWrap f = someFIntBOpWrap' f f f f------------------------------------------------------------------------------------someFRealBOp'- :: (Float -> Float -> r)- -> (Double -> Double -> r)- -> SomeFReal -> SomeFReal -> r-someFRealBOp' k4f k8f (SomeFKinded l) (SomeFKinded r) =- fRealBOp' k4f k8f l r--someFRealBOp- :: (forall a. RealFloat a => a -> a -> r)- -> SomeFReal -> SomeFReal -> r-someFRealBOp f = someFRealBOp' f f--someFRealBOpWrap'- :: (Float -> Float -> Float)- -> (Double -> Double -> Double)- -> SomeFReal -> SomeFReal -> SomeFReal-someFRealBOpWrap' k4f k8f =- someFRealBOp' k4f' k8f'- where- k4f' l r = SomeFKinded $ FReal4 $ k4f l r- k8f' l r = SomeFKinded $ FReal8 $ k8f l r--someFRealBOpWrap- :: (forall a. RealFloat a => a -> a -> a)- -> SomeFReal -> SomeFReal -> SomeFReal-someFRealBOpWrap f = someFRealBOpWrap' f f--someFRealUOp'- :: (Float -> r)- -> (Double -> r)- -> SomeFReal -> r-someFRealUOp' k4f k8f (SomeFKinded x) =- fRealUOp' k4f k8f x--someFRealUOp- :: (forall a. RealFloat a => a -> r)- -> SomeFReal -> r-someFRealUOp f = someFRealUOp' f f--someFRealUOpWrap'- :: (Float -> Float)- -> (Double -> Double)- -> SomeFReal -> SomeFReal-someFRealUOpWrap' k4f k8f =- someFRealUOp' k4f' k8f'- where- k4f' = SomeFKinded . FReal4 . k4f- k8f' = SomeFKinded . FReal8 . k8f--someFRealUOpWrap- :: (forall a. RealFloat a => a -> a)- -> SomeFReal -> SomeFReal-someFRealUOpWrap f = someFRealUOpWrap' f f------------------------------------------------------------------------------------someFComplexBOp'- :: (Float -> Float -> a)- -> (a -> a -> r)- -> (Double -> Double -> b)- -> (b -> b -> r)- -> SomeFComplex -> SomeFComplex -> r-someFComplexBOp' k8f k8g k16f k16g (SomeFKinded l) (SomeFKinded r) =- fComplexBOp' k8f k8g k16f k16g l r--someFComplexBOp- :: (forall a. RealFloat a => a -> a -> b)- -> (b -> b -> r)- -> SomeFComplex -> SomeFComplex -> r-someFComplexBOp f g = someFComplexBOp' f g f g--someFComplexBOpWrap'- :: (Float -> Float -> Float)- -> (Double -> Double -> Double)- -> SomeFComplex -> SomeFComplex -> SomeFComplex-someFComplexBOpWrap' k8f k16f =- someFComplexBOp' k8f k8g k16f k16g- where- k8g l r = SomeFKinded $ FComplex8 l r- k16g l r = SomeFKinded $ FComplex16 l r--someFComplexBOpWrap- :: (forall a. RealFloat a => a -> a -> a)- -> SomeFComplex -> SomeFComplex -> SomeFComplex-someFComplexBOpWrap f = someFComplexBOpWrap' f f--someFComplexFromReal :: SomeFReal -> SomeFComplex-someFComplexFromReal (SomeFKinded r) =- case r of- FReal4 x -> SomeFKinded $ FComplex8 x 0.0- FReal8 x -> SomeFKinded $ FComplex16 x 0.0
src/Language/Fortran/Repr/Type/Array.hs view
@@ -14,6 +14,15 @@ , fatShape :: Shape } deriving stock (Generic, Data, Show, Eq, Ord) +-- | The shape of a Fortran array is a list of extents. (The rank of the array+-- is length of the list.)+--+-- Note that the F90 standard limits maximum array rank to 7 (R512).+--+-- TODO+-- * An empty list here feels nonsensical. Perhaps this should be NonEmpty.+-- * List type is inefficient here, since we don't care about pushing/popping,+-- and list length is important. Use a vector type instead. newtype Shape = Shape { getShape :: [Natural] } deriving stock (Generic, Data, Show, Eq, Ord)
src/Language/Fortran/Repr/Type/Scalar.hs view
@@ -30,5 +30,14 @@ FSTString l -> "CHARACTER("<>prettyCharLen l<>")" FSTCustom t -> "TYPE("<>t<>")" -prettyKinded :: FKinded a => a -> String -> String+fScalarTypeKind :: FScalarType -> Maybe FKindLit+fScalarTypeKind = \case+ FSTInt k -> Just $ printFKind k+ FSTReal k -> Just $ printFKind k+ FSTComplex k -> Just $ printFKind (FTComplexWrapper k)+ FSTLogical k -> Just $ printFKind k+ FSTString l -> Just $ fromIntegral l+ FSTCustom t -> Nothing++prettyKinded :: FKind a => a -> String -> String prettyKinded k name = name<>"("<>show (printFKind k)<>")"
src/Language/Fortran/Repr/Type/Scalar/Common.hs view
@@ -1,63 +1,14 @@ module Language.Fortran.Repr.Type.Scalar.Common where -import Language.Fortran.Repr.Util-import Language.Fortran.Repr.Compat.Natural--import Data.Kind-import GHC.TypeNats--import Data.Type.Equality-import Data.Ord.Singletons-import Unsafe.Coerce---- | Fortran kinds are represented by natural numbers. We use them on both type--- and term levels.-type FKindTerm = Natural-type FKindType = NaturalK+import Data.Word ( Word8 ) --- | Reify a kind tag to its 'Natural' equivalent.-reifyKinded- :: forall k (a :: k) n. (n ~ FKindOf a, KnownNat n)- => Sing a -> FKindTerm-reifyKinded _ = natVal'' @n+-- | The internal type used to pass type kinds around.+type FKindLit = Word8 -- | Fortran types which use simple integer kinds.-class FKinded (a :: Type) where- type FKindOf (x :: a) :: FKindType- type FKindDefault :: a-- -- | This we get via the type family, but require singletons.- printFKind :: a -> FKindTerm-- -- | This we *should* get via the type family, but again require singletons.- parseFKind :: FKindTerm -> Maybe a--{---- | Fortran strings-instance FKinded Natural where- type FKindOf n = n- type FKindDefault = 1 -- TODO ??- printFKind = id- parseFKind = Just--}------------------------------------------------------------------------------------data SingCmp (l :: k) (r :: k)- = SingEq (l :~: r)- | SingLt- | SingGt+class FKind a where+ -- | Serialize the kind tag to the shared kind representation.+ printFKind :: a -> FKindLit --- | Upgrade an 'SOrdering' to include a proof of type equality for the equal--- case.------ We have no choice but to fake the 'Refl' with 'unsafeCoerce'. But assuming--- 'SEQ' is used correctly, it should be safe.-singCompare- :: forall k (a :: k) (b :: k). SOrd k- => Sing a -> Sing b -> SingCmp a b-singCompare a b =- case a `sCompare` b of- SEQ -> SingEq (unsafeCoerce Refl)- SLT -> SingLt- SGT -> SingGt+ -- | Parse a kind tag from the shared kind representation.+ parseFKind :: FKindLit -> Maybe a
src/Language/Fortran/Repr/Type/Scalar/Complex.hs view
@@ -8,6 +8,8 @@ alternatively, could enforce usage of this -} +{-# LANGUAGE DerivingVia #-}+ module Language.Fortran.Repr.Type.Scalar.Complex where import Language.Fortran.Repr.Type.Scalar.Common@@ -15,17 +17,17 @@ import GHC.Generics ( Generic ) import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) newtype FTComplexWrapper = FTComplexWrapper { unFTComplexWrapper :: FTReal }- deriving stock (Generic, Data, Show, Eq, Ord)+ deriving stock (Show, Generic, Data)+ deriving (Enum, Eq, Ord) via FTReal+ deriving anyclass (Binary, Out) -instance FKinded FTComplexWrapper where- type FKindOf ('FTComplexWrapper 'FTReal4) = 8- type FKindOf ('FTComplexWrapper 'FTReal8) = 16- type FKindDefault = 'FTComplexWrapper 'FTReal4+instance FKind FTComplexWrapper where parseFKind = \case 8 -> Just $ FTComplexWrapper FTReal4 16 -> Just $ FTComplexWrapper FTReal8 _ -> Nothing- printFKind = \case- FTComplexWrapper FTReal4 -> 8- FTComplexWrapper FTReal8 -> 16+ printFKind = \case FTComplexWrapper FTReal4 -> 8+ FTComplexWrapper FTReal8 -> 16
src/Language/Fortran/Repr/Type/Scalar/Int.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}-{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE StandaloneKindSignatures #-} module Language.Fortran.Repr.Type.Scalar.Int where @@ -7,36 +6,35 @@ import GHC.Generics ( Generic ) import Data.Data ( Data )--import Data.Singletons.TH--- required for deriving instances (seems like bug)-import Prelude.Singletons hiding ( type (-), type (*) )-import Data.Ord.Singletons+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -import GHC.TypeNats+-- | The Fortran integer type.+data FTInt+ = FTInt1 -- ^ @INTEGER(1)@+ | FTInt2 -- ^ @INTEGER(2)@+ | FTInt4 -- ^ @INTEGER(4)@+ | FTInt8 -- ^ @INTEGER(8)@+ | FTInt16 -- ^ @INTEGER(16)@+ deriving stock (Show, Generic, Data, Enum, Eq, Ord)+ deriving anyclass (Binary, Out) -$(singletons [d|- -- | The Fortran integer type.- data FTInt- = FTInt1 -- ^ @INTEGER(1)@- | FTInt2 -- ^ @INTEGER(2)@- | FTInt4 -- ^ @INTEGER(4)@- | FTInt8 -- ^ @INTEGER(8)@- | FTInt16 -- ^ @INTEGER(16)@- deriving stock (Eq, Ord, Show)- |])-deriving stock instance Generic FTInt-deriving stock instance Data FTInt-deriving stock instance Enum FTInt+instance FKind FTInt where+ parseFKind = \case 1 -> Just FTInt1+ 2 -> Just FTInt2+ 4 -> Just FTInt4+ 8 -> Just FTInt8+ 16 -> Just FTInt16+ _ -> Nothing+ printFKind = \case FTInt1 -> 1+ FTInt2 -> 2+ FTInt4 -> 4+ FTInt8 -> 8+ FTInt16 -> 16 --- | Get the output type from combining two integer values of arbitrary kinds--- (for example, adding an @INTEGER(1)@ and an @INTEGER(4)@).------ TODO is this OK?? the @k k = k@ equation at top??? type FTIntCombine :: FTInt -> FTInt -> FTInt type family FTIntCombine k1 k2 where FTIntCombine k k = k- FTIntCombine 'FTInt16 _ = 'FTInt16 FTIntCombine _ 'FTInt16 = 'FTInt16 FTIntCombine 'FTInt8 _ = 'FTInt8@@ -45,43 +43,3 @@ FTIntCombine _ 'FTInt4 = 'FTInt4 FTIntCombine 'FTInt2 _ = 'FTInt2 FTIntCombine _ 'FTInt2 = 'FTInt2- FTIntCombine 'FTInt1 'FTInt1 = 'FTInt1--instance FKinded FTInt where- type FKindOf 'FTInt1 = 1- type FKindOf 'FTInt2 = 2- type FKindOf 'FTInt4 = 4- type FKindOf 'FTInt8 = 8- type FKindOf 'FTInt16 = 16- type FKindDefault = 'FTInt4- parseFKind = \case 1 -> Just FTInt1- 2 -> Just FTInt2- 4 -> Just FTInt4- 8 -> Just FTInt8- 16 -> Just FTInt16- _ -> Nothing- -- spurious warning on GHC 9.0- printFKind (FromSing x) = case x of- SFTInt1 -> reifyKinded x- SFTInt2 -> reifyKinded x- SFTInt4 -> reifyKinded x- SFTInt8 -> reifyKinded x- SFTInt16 -> reifyKinded x---- | @max k = 2^(8k-1) - 1@-type FTIntMax :: FTInt -> Nat-type family FTIntMax k where- FTIntMax 'FTInt1 = 2^(8*1 -1) - 1- FTIntMax 'FTInt2 = 2^(8*2 -1) - 1- FTIntMax 'FTInt4 = 2^(8*4 -1) - 1- FTIntMax 'FTInt8 = 2^(8*8 -1) - 1- FTIntMax 'FTInt16 = 2^(8*16-1) - 1---- | @min k = - (2^(8k-1))@ (make sure you negate when reifying etc!)-type FTIntMin :: FTInt -> Nat-type family FTIntMin k where- FTIntMin 'FTInt1 = 2^(8*1 -1)- FTIntMin 'FTInt2 = 2^(8*2 -1)- FTIntMin 'FTInt4 = 2^(8*4 -1)- FTIntMin 'FTInt8 = 2^(8*8 -1)- FTIntMin 'FTInt16 = 2^(8*16-1)
src/Language/Fortran/Repr/Type/Scalar/Real.hs view
@@ -1,43 +1,22 @@-{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}- module Language.Fortran.Repr.Type.Scalar.Real where import Language.Fortran.Repr.Type.Scalar.Common import GHC.Generics ( Generic ) import Data.Data ( Data )--import Data.Singletons.TH--- required for deriving instances (seems like bug)-import Prelude.Singletons-import Data.Ord.Singletons--$(singletons [d|- data FTReal- = FTReal4- | FTReal8- deriving stock (Eq, Ord, Show)- |])-deriving stock instance Generic FTReal-deriving stock instance Data FTReal-deriving stock instance Enum FTReal+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) --- | Get the output type from combining two real values of arbitrary kinds (for--- example, adding a @REAL(4)@ and a @REAL(8)@).-type FTRealCombine :: FTReal -> FTReal -> FTReal-type family FTRealCombine k1 k2 where- FTRealCombine 'FTReal8 _ = 'FTReal8- FTRealCombine _ 'FTReal8 = 'FTReal8- FTRealCombine 'FTReal4 'FTReal4 = 'FTReal4+data FTReal+ = FTReal4+ | FTReal8+ deriving stock (Show, Generic, Data, Enum, Eq, Ord)+ deriving anyclass (Binary, Out) -instance FKinded FTReal where- type FKindOf 'FTReal4 = 4- type FKindOf 'FTReal8 = 8- type FKindDefault = 'FTReal4+instance FKind FTReal where parseFKind = \case 4 -> Just FTReal4 8 -> Just FTReal8 _ -> Nothing -- spurious warning on GHC 9.0- printFKind (FromSing x) = case x of- SFTReal4 -> reifyKinded x- SFTReal8 -> reifyKinded x+ printFKind = \case FTReal4 -> 4+ FTReal8 -> 8
src/Language/Fortran/Repr/Type/Scalar/String.hs view
@@ -1,18 +1,13 @@-{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}- module Language.Fortran.Repr.Type.Scalar.String where import Language.Fortran.Repr.Compat.Natural import GHC.Generics ( Generic ) import Data.Data ( Data )----import Data.Singletons.TH--- required for deriving instances (seems like bug)---import Prelude.Singletons---import Data.Ord.Singletons+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans() --- $(singletons [d| -- | The length of a CHARACTER value. -- -- IanH provides a great reference on StackOverflow:@@ -32,11 +27,8 @@ -- ^ @CHARACTER(LEN=:)@. F2003. Value has deferred length. Must have the -- ALLOCATABLE or POINTER attribute. - deriving stock (Eq, Ord, Show)--- |])--deriving stock instance Generic CharLen-deriving stock instance Data CharLen+ deriving stock (Show, Generic, Data, Eq, Ord)+ deriving anyclass (Binary, Out) prettyCharLen :: Natural -> String prettyCharLen l = "LEN="<>show l
− src/Language/Fortran/Repr/Value/Array.hs
@@ -1,5 +0,0 @@-module Language.Fortran.Repr.Value.Array- ( module Language.Fortran.Repr.Value.Array.Machine- ) where--import Language.Fortran.Repr.Value.Array.Machine
− src/Language/Fortran/Repr/Value/Array/Machine.hs
@@ -1,106 +0,0 @@-{- | Fortran array representation primitives.--Fortran arrays are homogeneous: every element has the same type. That means a-@REAL(8)@ array must store only @REAL(8)@s, no @REAL(4)@s. We use some type-algebra to obtain correct-by-construction types.--Also, Fortran arrays are multi-dimensional. Rather than storing a single natural-number for a single dimension, or doing some recursive work for arrays of arrays-(which don't exist in Fortran), we instead store a list of naturals, defining-each dimension's extent.--}--{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE UndecidableInstances #-}---- unwrapping somes gets you kind and length at the same time - I figure because--- kind is just a convenience.--module Language.Fortran.Repr.Value.Array.Machine where--import Language.Fortran.Repr.Type.Array-import Language.Fortran.Repr.Type.Scalar-import Language.Fortran.Repr.Type.Scalar.Int-import Language.Fortran.Repr.Value.Scalar.Int.Machine-import Language.Fortran.Repr.Type.Scalar.Real-import Language.Fortran.Repr.Value.Scalar.Real-import Language.Fortran.Repr.Value.Scalar.Complex-import Language.Fortran.Repr.Value.Scalar.String-import Language.Fortran.Repr.Util ( natVal'' )--import GHC.TypeNats-import Language.Fortran.Repr.Compat.Natural--import qualified Data.Vector.Sized as V-import Data.Vector.Sized ( Vector )-import Data.Kind-import Data.Singletons--type Size :: [NaturalK] -> NaturalK-type family Size dims where- Size (dim ': dims) = dim + Size dims- Size '[] = 0---- can conveniently define kinded array types like so-data FVA (ft :: k -> Type) (fk :: k) (dims :: [NaturalK])- = FVA { unFVA :: Vector (Size dims) (ft fk) }-deriving stock instance Show (ft fk) => Show (FVA ft fk dims)---- makes rank 1 array-mkFVA1 :: forall l ft fk. Vector l (ft fk) -> FVA ft fk '[l]-mkFVA1 = FVA---- reifies type info-fvaShape :: forall dims ft fk. KnownNats dims => FVA ft fk dims -> Shape-fvaShape _ = Shape $ natVals @dims---- TODO-mkSomeFVA :: (forall l. KnownNat l => Vector l a -> r) -> [a] -> r-mkSomeFVA f as = V.withSizedList as f---- | Reify a list of type-level 'Natural's.-class KnownNats (ns :: [NaturalK]) where natVals :: [Natural]-instance (KnownNat n, KnownNats ns) => KnownNats (n ': ns) where- natVals = natVal'' @n : natVals @ns-instance KnownNats '[] where natVals = []---- | Wrapper for defining an array of a kind-tagged Fortran type.-data SomeFVA k ft =- forall (fk :: k) (dims :: [NaturalK]). (KnownNats dims, SingKind k, SingI fk)- => SomeFVA { unSomeFVA :: FVA ft fk dims }-deriving stock instance Show (SomeFVA FTInt FInt)-deriving stock instance Show (SomeFVA FTReal FReal)-deriving stock instance Show (SomeFVA FTReal FComplex)-deriving stock instance Show (SomeFVA NaturalK FString)--someFVAKind :: SomeFVA k ft -> Demote k-someFVAKind (SomeFVA (_ :: FVA ft fk dims)) = demote @fk--someFVAShape :: SomeFVA k ft -> Shape-someFVAShape (SomeFVA a) = fvaShape a---- makes rank 1 array-mkSomeFVA1- :: forall k ft (fk :: k). (SingKind k, SingI fk)- => [ft fk] -> SomeFVA k ft-mkSomeFVA1 = mkSomeFVA $ SomeFVA . mkFVA1--data FArrayValue- = FAVInt (SomeFVA FTInt FInt)- | FAVReal (SomeFVA FTReal FReal)- | FAVComplex (SomeFVA FTReal FComplex)- | FAVLogical (SomeFVA FTInt FInt)- | FAVString (SomeFVA NaturalK FString)-deriving stock instance Show FArrayValue--fArrayValueType :: FArrayValue -> FArrayType-fArrayValueType = \case- FAVInt a -> go FSTInt a- FAVReal a -> go FSTReal a- FAVComplex a -> go FSTComplex a- FAVLogical a -> go FSTLogical a- FAVString a -> go FSTString a- where- go :: (Demote k -> FScalarType) -> SomeFVA k ft -> FArrayType- go f a = FArrayType (f (someFVAKind a)) (someFVAShape a)
src/Language/Fortran/Repr/Value/Machine.hs view
@@ -1,14 +1,34 @@+{-# LANGUAGE DerivingVia #-}+ 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.Value.Array.Machine import Language.Fortran.Repr.Type --- | A Fortran value (scalar or array).-data FValue = MkFArrayValue FArrayValue | MkFScalarValue FScalarValue- deriving stock Show+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) +-- | A Fortran value (scalar only currently).+data FValue = MkFScalarValue FScalarValue+ deriving stock (Show, Generic, Data, Eq)+ deriving anyclass (Binary, Out)+ fValueType :: FValue -> FType fValueType = \case MkFScalarValue a -> MkFScalarType $ fScalarValueType a- MkFArrayValue a -> MkFArrayType $ fArrayValueType 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
src/Language/Fortran/Repr/Value/Scalar/Common.hs view
@@ -1,8 +1,22 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+ -- | Common definitions for Fortran scalar representations. module Language.Fortran.Repr.Value.Scalar.Common where +import Language.Fortran.Repr.Type.Scalar.Common+ import Data.Singletons +import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )+import Data.Binary+import Data.Data ( Data, Typeable )++import Data.Kind+ {- | Convenience wrapper which multiple Fortran tag-kinded intrinsic types fit. A type @ft@ takes some type @fk@ of kind @k@, and we are permitted to move the@@ -12,9 +26,79 @@ integer with an existential ("unknown") kind with the type @'SomeFKinded' FTInt FInt@. By pattern matching on it, we recover the hidden kind tag (as well as obtaining the value).++Note that many type classes usually derived generically (e.g.+'Data.Binary.Binary') instances should be manually derived on this wrapper type.+TODO give a better explanation why? -}-data SomeFKinded k ft = forall (fk :: k). (SingKind k, SingI fk) => SomeFKinded (ft fk)+data SomeFKinded k ft where+ SomeFKinded+ :: forall {k} ft (fk :: k)+ . (SingKind k, SingI fk, Data (ft fk))+ => ft fk+ -> SomeFKinded k ft +deriving stock instance+ ( SingKind k+ , forall (fk :: k). SingI fk+ , forall (fk :: k). Data (ft fk)+ , Typeable ft+ , Typeable k+ ) => Data (SomeFKinded k ft)+--instance (Typeable k, Typeable ft) => Data (SomeFKinded k ft) where++-- | GHC can derive stock 'Show' instances given some @QuantifiedConstraints@+-- guarantees (wow!).+deriving stock instance (forall fk. Show (ft fk)) => Show (SomeFKinded k ft)++-- | Derive 'Out' instances via 'Show'.+deriving via OutShowly (SomeFKinded k ft) instance (forall fk. Show (ft fk)) => Out (SomeFKinded k ft)++-- | For any Fortran type @ft@ kinded with @k@, we may derive a 'Binary'+-- instance by leveraging the kind tag's instance @'Binary' ('Demote' k)@ and+-- the kinded value's instance @'Binary' (ft k)@. (We also have to ferry some+-- singletons instances through.)+--+-- WARNING: This instance is only sound for types where each kind tag value is+-- used once at most (meaning if you know the fkind, you know the constructor).+--+-- Note that the 'Data.Binary.Get' instance works by parsing a kind tag,+-- promoting it to a singleton, then gleaning type information and using that to+-- parse the inner kinded value. Dependent types!+-- TODO if we pack a Data context into SomeFKinded, get can't recover it!!+instance+ ( Binary (Demote k)+ , SingKind k+ , forall (fk :: k). SingI fk => Binary (ft fk)+ , forall (fk :: k). Data (ft fk)+ ) => Binary (SomeFKinded k ft) where+ put someV@(SomeFKinded v) = do+ put $ someFKindedKind someV+ put v+ get = get @(Demote k) >>= \case -- parse fkind tag+ kindTag ->+ withSomeSing kindTag f+ where+ f :: forall (fk :: k). Sing fk -> Get (SomeFKinded k ft)+ f kind = do+ withSingI @fk kind $ do+ v <- get @(ft fk)+ pure $ undefined -- SomeFKinded @k @ft v+ -- | Recover some @TYPE(x)@'s kind (the @x@). someFKindedKind :: SomeFKinded k ft -> Demote k someFKindedKind (SomeFKinded (_ :: ft fk)) = demote @fk++---++-- | A kinded Fortran value.+class FKinded a where+ -- | The Haskell type used to record this Fortran type's kind.+ type FKindedT a++ -- | For every Fortran kind of this Fortran type @a@, the underlying+ -- representation @b@ has the given constraints.+ type FKindedC a b :: Constraint++ -- | Obtain the kind of a Fortran value.+ fKind :: a -> FKindedT a
src/Language/Fortran/Repr/Value/Scalar/Complex.hs view
@@ -3,30 +3,45 @@ A Fortran COMPLEX is simply two REALs of the same kind. -} +{-# LANGUAGE DerivingVia #-}+ module Language.Fortran.Repr.Value.Scalar.Complex where import Language.Fortran.Repr.Value.Scalar.Common import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Real import GHC.Float ( float2Double ) -data FComplex (k :: FTReal) where- FComplex8 :: Float -> Float -> FComplex 'FTReal4- FComplex16 :: Double -> Double -> FComplex 'FTReal8-deriving stock instance Show (FComplex k)-deriving stock instance Eq (FComplex k)-deriving stock instance Ord (FComplex k) -- TODO+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -type SomeFComplex = SomeFKinded FTReal FComplex-deriving stock instance Show SomeFComplex-instance Eq SomeFComplex where- (SomeFKinded l) == (SomeFKinded r) = fComplexBOp (==) (&&) l r+data FComplex+ = FComplex8 {- ^ @COMPLEX(8)@ -} Float Float+ | FComplex16 {- ^ @COMPLEX(16)@ -} Double Double+ deriving stock (Show, Generic, Data)+ deriving anyclass (Binary, Out) +instance FKinded FComplex where+ type FKindedT FComplex = FTReal+ type FKindedC FComplex a = RealFloat a+ fKind = \case+ FComplex8{} -> FTReal4+ FComplex16{} -> FTReal8++instance Eq FComplex where (==) = fComplexBOp (==) (&&)++fComplexFromReal :: FReal -> FComplex+fComplexFromReal = \case FReal4 x -> FComplex8 x 0.0+ FReal8 x -> FComplex16 x 0.0+ fComplexBOp' :: (Float -> Float -> a) -> (a -> a -> r) -> (Double -> Double -> b) -> (b -> b -> r)- -> FComplex kl -> FComplex kr -> r+ -> FComplex -> FComplex -> r fComplexBOp' k8f k8g k16f k16g l r = case (l, r) of (FComplex8 lr li, FComplex8 rr ri) -> k8g (k8f lr rr) (k8f li ri)@@ -40,8 +55,19 @@ ri' = float2Double ri in k16g (k16f lr rr') (k16f li ri') +fComplexBOpInplace'+ :: (Float -> Float -> Float)+ -> (Double -> Double -> Double)+ -> FComplex -> FComplex -> FComplex+fComplexBOpInplace' k8f k16f = fComplexBOp' k8f FComplex8 k16f FComplex16+ fComplexBOp- :: (forall a. RealFloat a => a -> a -> b)+ :: (forall a. FKindedC FComplex a => a -> a -> b) -> (b -> b -> r)- -> FComplex kl -> FComplex kr -> r+ -> FComplex -> FComplex -> r fComplexBOp f g = fComplexBOp' f g f g++fComplexBOpInplace+ :: (forall a. FKindedC FComplex a => a -> a -> a)+ -> FComplex -> FComplex -> FComplex+fComplexBOpInplace f = fComplexBOpInplace' f f
src/Language/Fortran/Repr/Value/Scalar/Int/Idealized.hs view
@@ -13,11 +13,14 @@ module Language.Fortran.Repr.Value.Scalar.Int.Idealized where import Language.Fortran.Repr.Type.Scalar.Int-import Language.Fortran.Repr.Value.Scalar.Common import Data.Kind import Data.Int-import Data.Singletons +import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+ type FIntMRep :: FTInt -> Type type family FIntMRep k = r | r -> k where FIntMRep 'FTInt1 = Int8@@ -26,7 +29,9 @@ FIntMRep 'FTInt8 = Int64 newtype FIntI (k :: FTInt) = FIntI Integer- deriving (Show, Eq, Ord) via Integer+ deriving stock (Show, Generic, Data)+ deriving (Eq, Ord) via Integer+ deriving anyclass (Binary, Out) fIntICheckBounds :: forall k rep. (rep ~ FIntMRep k, Bounded rep, Integral rep)@@ -38,31 +43,18 @@ then Just "TODO too small" else Nothing -type SomeFIntI = SomeFKinded FTInt FIntI+data SomeFIntI = forall fk. SomeFIntI (FIntI fk) deriving stock instance Show SomeFIntI instance Eq SomeFIntI where- (SomeFKinded (FIntI l)) == (SomeFKinded (FIntI r)) = l == r+ (SomeFIntI (FIntI l)) == (SomeFIntI (FIntI r)) = l == r -- this might look silly, but it's because even if we don't do kinded -- calculations, we must still kind the output someFIntIBOpWrap :: (Integer -> Integer -> Integer) -> SomeFIntI -> SomeFIntI -> SomeFIntI-someFIntIBOpWrap f l@(SomeFKinded (FIntI il)) r@(SomeFKinded (FIntI ir)) =- case (someFKindedKind l, someFKindedKind r) of- (FTInt16, _) -> as @'FTInt16- (_, FTInt16) -> as @'FTInt16- (FTInt8, _) -> as @'FTInt8- (_, FTInt8) -> as @'FTInt8- (FTInt4, _) -> as @'FTInt4- (_, FTInt4) -> as @'FTInt4- (FTInt2, _) -> as @'FTInt2- (_, FTInt2) -> as @'FTInt2- (FTInt1, FTInt1) -> as @'FTInt1- where- x = f il ir- as :: forall (k :: FTInt). SingI k => SomeFIntI- as = SomeFKinded $ FIntI @k x+someFIntIBOpWrap f (SomeFIntI (FIntI li :: FIntI lfk)) (SomeFIntI (FIntI ri :: FIntI rfk)) =+ SomeFIntI $ FIntI @(FTIntCombine lfk rfk) $ f li ri {- fIntIBOpWrap
src/Language/Fortran/Repr/Value/Scalar/Int/Machine.hs view
@@ -7,119 +7,64 @@ integral types. -} -{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE AllowAmbiguousTypes #-}--module Language.Fortran.Repr.Value.Scalar.Int.Machine- ( FInt(..)- , SomeFInt- , type IsFInt-- , fIntUOp- , fIntUOp'- , fIntUOpInplace- , fIntUOpInplace'- , fIntUOpInternal-- , fIntBOp- , fIntBOp'- , fIntBOpInplace- , fIntBOpInplace'- , fIntBOpInternal-- , withFInt- ) where+module Language.Fortran.Repr.Value.Scalar.Int.Machine where import Language.Fortran.Repr.Type.Scalar.Int import Language.Fortran.Repr.Value.Scalar.Common import Data.Int-import Data.Functor.Const import Data.Bits ( Bits ) -import Language.Fortran.Repr.Util ( natVal'' )-import GHC.TypeNats+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans() --- | A Fortran integer value, tagged with its kind.-data FInt (k :: FTInt) where- FInt1 :: Int8 -> FInt 'FTInt1 -- ^ @INTEGER(1)@- FInt2 :: Int16 -> FInt 'FTInt2 -- ^ @INTEGER(2)@- FInt4 :: Int32 -> FInt 'FTInt4 -- ^ @INTEGER(4)@- FInt8 :: Int64 -> FInt 'FTInt8 -- ^ @INTEGER(8)@-deriving stock instance Show (FInt k)-deriving stock instance Eq (FInt k)-deriving stock instance Ord (FInt k)+-- | A Fortran integer value, type @INTEGER(k)@.+data FInt+ = FInt1 {- ^ @INTEGER(1)@ -} Int8+ | FInt2 {- ^ @INTEGER(2)@ -} Int16+ | FInt4 {- ^ @INTEGER(4)@ -} Int32+ | FInt8 {- ^ @INTEGER(8)@ -} Int64+ deriving stock (Show, Generic, Data)+ deriving anyclass (Binary, Out) -type IsFInt a = (Integral a, Bits a)+instance FKinded FInt where+ type FKindedT FInt = FTInt+ type FKindedC FInt a = (Integral a, Bits a)+ fKind = \case+ FInt1{} -> FTInt1+ FInt2{} -> FTInt2+ FInt4{} -> FTInt4+ FInt8{} -> FTInt8 -type SomeFInt = SomeFKinded FTInt FInt-deriving stock instance Show SomeFInt-instance Eq SomeFInt where- (SomeFKinded l) == (SomeFKinded r) = fIntBOp (==) l r+instance Eq FInt where (==) = fIntBOp (==) --- | Low-level 'FInt' unary operator. Runs an operation over some 'FInt', and--- stores it kinded. The user gets to choose how the kind is used: it can be--- used to wrap the result back into an 'FInt', or ignored using 'Const'.------ Pattern matches are ordered to match more common ops earlier.-fIntUOpInternal- :: (Int8 -> ft 'FTInt1)- -> (Int16 -> ft 'FTInt2)- -> (Int32 -> ft 'FTInt4)- -> (Int64 -> ft 'FTInt8)- -> FInt k -> ft k-fIntUOpInternal k1f k2f k4f k8f = \case- FInt4 i32 -> k4f i32- FInt8 i64 -> k8f i64- FInt2 i16 -> k2f i16- FInt1 i8 -> k1f i8+withFInt :: Num a => FInt -> a+withFInt = fIntUOp fromIntegral --- | Run an operation over some 'FInt', with a concrete function for each kind.+-- Pattern matches are ordered to match more common ops earlier. fIntUOp' :: (Int8 -> r) -> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r)- -> FInt k -> r-fIntUOp' k1f k2f k4f k8f =- getConst- . fIntUOpInternal (Const . k1f) (Const . k2f) (Const . k4f) (Const . k8f)---- | Run an operation over some 'FInt'.-fIntUOp- :: forall r k- . (forall a. IsFInt a => a -> r)- -> FInt k -> r-fIntUOp f = fIntUOp' f f f f---- | Run an inplace operation over some 'FInt', with a concrete function for--- each kind.-fIntUOpInplace'- :: (Int8 -> Int8)- -> (Int16 -> Int16)- -> (Int32 -> Int32)- -> (Int64 -> Int64)- -> FInt k -> FInt k-fIntUOpInplace' k1f k2f k4f k8f =- fIntUOpInternal (FInt1 . k1f) (FInt2 . k2f) (FInt4 . k4f) (FInt8 . k8f)---- | Run an inplace operation over some 'FInt'.-fIntUOpInplace- :: (forall a. IsFInt a => a -> a)- -> FInt k -> FInt k-fIntUOpInplace f = fIntUOpInplace' f f f f+ -> FInt -> r+fIntUOp' k1f k2f k4f k8f = \case+ FInt4 i32 -> k4f i32+ FInt8 i64 -> k8f i64+ FInt2 i16 -> k2f i16+ FInt1 i8 -> k1f i8 --- | Low-level 'FInt' binary operator. Combine two 'FInt's, coercing different--- kinds, and store the result kinded.--- -- Pattern matches are ordered to match more common ops earlier.-fIntBOpInternal- :: (Int8 -> Int8 -> ft 'FTInt1)- -> (Int16 -> Int16 -> ft 'FTInt2)- -> (Int32 -> Int32 -> ft 'FTInt4)- -> (Int64 -> Int64 -> ft 'FTInt8)- -> FInt kl -> FInt kr -> ft (FTIntCombine kl kr)-fIntBOpInternal k1f k2f k4f k8f il ir = case (il, ir) of+fIntBOp'+ :: (Int8 -> Int8 -> r)+ -> (Int16 -> Int16 -> r)+ -> (Int32 -> Int32 -> r)+ -> (Int64 -> Int64 -> r)+ -> FInt -> FInt -> r+fIntBOp' k1f k2f k4f k8f il ir = case (il, ir) of (FInt4 l32, FInt4 r32) -> k4f l32 r32 (FInt8 l64, FInt8 r64) -> k8f l64 r64 @@ -144,55 +89,43 @@ (FInt1 l8, FInt1 r8) -> k1f l8 r8 -fIntBOp'- :: (Int8 -> Int8 -> r)- -> (Int16 -> Int16 -> r)- -> (Int32 -> Int32 -> r)- -> (Int64 -> Int64 -> r)- -> FInt kl -> FInt kr -> r-fIntBOp' k1f k2f k4f k8f il ir =- getConst- $ fIntBOpInternal (go k1f) (go k2f) (go k4f) (go k8f) il ir- where go g l r = Const $ g l r--fIntBOp- :: (forall a. IsFInt a => a -> a -> r)- -> FInt kl -> FInt kr -> r-fIntBOp f = fIntBOp' f f f f+fIntUOpInplace'+ :: (Int8 -> Int8)+ -> (Int16 -> Int16)+ -> (Int32 -> Int32)+ -> (Int64 -> Int64)+ -> FInt -> FInt+fIntUOpInplace' k1f k2f k4f k8f =+ fIntUOp' (FInt1 . k1f) (FInt2 . k2f) (FInt4 . k4f) (FInt8 . k8f) fIntBOpInplace' :: (Int8 -> Int8 -> Int8) -> (Int16 -> Int16 -> Int16) -> (Int32 -> Int32 -> Int32) -> (Int64 -> Int64 -> Int64)- -> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)+ -> FInt -> FInt -> FInt fIntBOpInplace' k1f k2f k4f k8f =- fIntBOpInternal (go FInt1 k1f) (go FInt2 k2f) (go FInt4 k4f) (go FInt8 k8f)- where go f g l r = f $ g l r+ fIntBOp' (f FInt1 k1f) (f FInt2 k2f) (f FInt4 k4f) (f FInt8 k8f)+ where f cstr bop l r = cstr $ bop l r -fIntBOpInplace- :: (forall a. IsFInt a => a -> a -> a)- -> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)-fIntBOpInplace f = fIntBOpInplace' f f f f+fIntUOp :: (forall a. FKindedC FInt a => a -> r) -> FInt -> r+fIntUOp f = fIntUOp' f f f f --- | Treat any 'FInt' as a 'Num'.------ TODO remove. means being explicit with coercions to real in eval.-withFInt :: Num a => FInt k -> a-withFInt = fIntUOp fromIntegral+fIntUOpInplace :: (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt+fIntUOpInplace f = fIntUOpInplace' f f f f -fIntMax :: forall (k :: FTInt). KnownNat (FTIntMax k) => Int64-fIntMax = fromIntegral $ natVal'' @(FTIntMax k)+fIntBOp :: (forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r+fIntBOp f = fIntBOp' f f f f -fIntMin :: forall (k :: FTInt). KnownNat (FTIntMin k) => Int64-fIntMin = fromIntegral $ natVal'' @(FTIntMin k)+fIntBOpInplace :: (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt+fIntBOpInplace f = fIntBOpInplace' f f f f --- TODO improve (always return answer, and a flag indicating if there was an--- error)-fIntCoerceChecked- :: forall kout kin- . (KnownNat (FTIntMax kout), KnownNat (FTIntMin kout))- => SFTInt kout -> FInt kin -> Either String (FInt kout)+{-++-- TODO improve: always return answer, plus a flag indicating if there was an+-- error, plus this should be in eval instead and this should be simpler+-- (shouldn't be wrapping in Either)+fIntCoerceChecked :: FTInt -> FInt -> Either String FInt fIntCoerceChecked ty = fIntUOp $ \n -> if fromIntegral n > fIntMax @kout then Left "too large for new size"@@ -200,16 +133,10 @@ Left "too small for new size" else case ty of- SFTInt1 -> Right $ FInt1 $ fromIntegral n- SFTInt2 -> Right $ FInt2 $ fromIntegral n- SFTInt4 -> Right $ FInt4 $ fromIntegral n- SFTInt8 -> Right $ FInt8 $ fromIntegral n- SFTInt16 -> Left "can't represent INTEGER(16) yet, sorry"+ FTInt1 -> Right $ FInt1 $ fromIntegral n+ FTInt2 -> Right $ FInt2 $ fromIntegral n+ FTInt4 -> Right $ FInt4 $ fromIntegral n+ FTInt8 -> Right $ FInt8 $ fromIntegral n+ FTInt16 -> Left "can't represent INTEGER(16) yet, sorry" --- can also define this (and stronger funcs) with singletons-fIntType :: FInt (k :: FTInt) -> FTInt-fIntType = \case- FInt1{} -> FTInt1- FInt2{} -> FTInt2- FInt4{} -> FTInt4- FInt8{} -> FTInt8+-}
src/Language/Fortran/Repr/Value/Scalar/Logical/Machine.hs view
@@ -11,7 +11,7 @@ import Language.Fortran.Repr.Value.Scalar.Int.Machine -- | Retrieve the boolean value stored by a @LOGICAL(x)@.-fLogicalToBool :: FInt k -> Bool+fLogicalToBool :: FInt -> Bool fLogicalToBool = fIntUOp $ consumeFLogicalNumeric True False -- | Convert a bool to its Fortran machine representation in any numeric type.@@ -23,5 +23,5 @@ consumeFLogicalNumeric whenTrue whenFalse bi = if bi == 1 then whenTrue else whenFalse -fLogicalNot :: FInt k -> FInt k+fLogicalNot :: FInt -> FInt fLogicalNot = fIntUOpInplace (consumeFLogicalNumeric 0 1)
src/Language/Fortran/Repr/Value/Scalar/Machine.hs view
@@ -11,9 +11,16 @@ import Language.Fortran.Repr.Value.Scalar.Int.Machine import Language.Fortran.Repr.Value.Scalar.Real import Language.Fortran.Repr.Value.Scalar.Complex-import Language.Fortran.Repr.Value.Scalar.String import Language.Fortran.Repr.Type.Scalar++import Data.Text ( Text )+import qualified Data.Text as Text+ import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans() {- $type-coercion-implementation @@ -33,18 +40,19 @@ -- | A Fortran scalar value. data FScalarValue- = FSVInt SomeFInt- | FSVReal SomeFReal- | FSVComplex SomeFComplex- | FSVLogical SomeFInt- | FSVString SomeFString- deriving stock (Generic, Show, Eq)+ = FSVInt FInt+ | FSVReal FReal+ | FSVComplex FComplex+ | FSVLogical FInt+ | FSVString Text+ deriving stock (Show, Generic, Data, Eq)+ deriving anyclass (Binary, Out) -- | Recover a Fortran scalar value's type. fScalarValueType :: FScalarValue -> FScalarType fScalarValueType = \case- FSVInt a -> FSTInt $ someFKindedKind a- FSVReal a -> FSTReal $ someFKindedKind a- FSVComplex a -> FSTComplex $ someFKindedKind a- FSVLogical a -> FSTLogical $ someFKindedKind a- FSVString a -> FSTString $ someFStringLen a+ FSVInt a -> FSTInt $ fKind a+ FSVReal a -> FSTReal $ fKind a+ FSVComplex a -> FSTComplex $ fKind a+ FSVLogical a -> FSTLogical $ fKind a+ FSVString a -> FSTString $ fromIntegral $ Text.length a
src/Language/Fortran/Repr/Value/Scalar/Real.hs view
@@ -1,106 +1,76 @@-module Language.Fortran.Repr.Value.Scalar.Real- ( FReal(..)- , SomeFReal-- , fRealUOp- , fRealUOp'- , fRealUOpInplace- , fRealUOpInplace'- , fRealUOpInternal-- , fRealBOp- , fRealBOp'- , fRealBOpInplace- , fRealBOpInplace'- , fRealBOpInternal- ) where+module Language.Fortran.Repr.Value.Scalar.Real where import Language.Fortran.Repr.Type.Scalar.Real import Language.Fortran.Repr.Value.Scalar.Common import GHC.Float ( float2Double )-import Data.Functor.Const -data FReal (k :: FTReal) where- FReal4 :: Float -> FReal 'FTReal4- FReal8 :: Double -> FReal 'FTReal8-deriving stock instance Show (FReal k)-deriving stock instance Eq (FReal k)-deriving stock instance Ord (FReal k)+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -fRealUOpInternal- :: (Float -> ft 'FTReal4)- -> (Double -> ft 'FTReal8)- -> FReal k -> ft k-fRealUOpInternal k4f k8f = \case- FReal4 fl -> k4f fl- FReal8 db -> k8f db+data FReal+ = FReal4 {- ^ @REAL(4)@ -} Float+ | FReal8 {- ^ @REAL(8)@ -} Double+ deriving stock (Show, Generic, Data)+ deriving anyclass (Binary, Out) --- | Run an operation over some 'FReal', with a concrete function for each kind.+instance FKinded FReal where+ type FKindedT FReal = FTReal+ type FKindedC FReal a = RealFloat a+ fKind = \case+ FReal4{} -> FTReal4+ FReal8{} -> FTReal8++instance Eq FReal where (==) = fRealBOp (==)+ fRealUOp' :: (Float -> r) -> (Double -> r)- -> FReal k -> r-fRealUOp' k4f k8f = getConst . fRealUOpInternal (Const . k4f) (Const . k8f)+ -> FReal -> r+fRealUOp' k4f k8f = \case+ FReal4 fl -> k4f fl+ FReal8 db -> k8f db --- | Run an operation over some 'FReal'.-fRealUOp- :: (forall a. RealFloat a => a -> r)- -> FReal k -> r-fRealUOp f = fRealUOp' f f+fRealBOp'+ :: (Float -> Float -> r)+ -> (Double -> Double -> r)+ -> FReal -> FReal -> r+fRealBOp' k4f k8f l r = case (l, r) of+ (FReal4 lr, FReal4 rr) -> k4f lr rr+ (FReal8 lr, FReal8 rr) -> k8f lr rr+ (FReal4 lr, FReal8 rr) -> k8f (float2Double lr) rr+ (FReal8 lr, FReal4 rr) -> k8f lr (float2Double rr) --- | Run an inplace operation over some 'FReal', with a concrete function for--- each kind. fRealUOpInplace' :: (Float -> Float) -> (Double -> Double)- -> FReal k -> FReal k-fRealUOpInplace' k4f k8f = fRealUOpInternal (FReal4 . k4f) (FReal8. k8f)+ -> FReal -> FReal+fRealUOpInplace' k4f k8f = fRealUOp' (FReal4 . k4f) (FReal8 . k8f) --- | Run an inplace operation over some 'FReal'.-fRealUOpInplace- :: (forall a. RealFloat a => a -> a)- -> FReal k -> FReal k-fRealUOpInplace f = fRealUOpInplace' f f+fRealBOpInplace'+ :: (Float -> Float -> Float)+ -> (Double -> Double -> Double)+ -> FReal -> FReal -> FReal+fRealBOpInplace' k4f k8f = fRealBOp' (f FReal4 k4f) (f FReal8 k8f)+ where f cstr bop l r = cstr $ bop l r --- | Combine two Fortran reals with a binary operation, coercing different--- kinds.-fRealBOpInternal- :: (Float -> Float -> ft 'FTReal4)- -> (Double -> Double -> ft 'FTReal8)- -> FReal kl -> FReal kr -> ft (FTRealCombine kl kr)-fRealBOpInternal k4f k8f l r = case (l, r) of- (FReal4 lr, FReal4 rr) -> k4f lr rr- (FReal8 lr, FReal8 rr) -> k8f lr rr- (FReal4 lr, FReal8 rr) -> k8f (float2Double lr) rr- (FReal8 lr, FReal4 rr) -> k8f lr (float2Double rr)+fRealUOp+ :: (forall a. FKindedC FReal a => a -> r)+ -> FReal -> r+fRealUOp f = fRealUOp' f f -fRealBOp'- :: (Float -> Float -> r)- -> (Double -> Double -> r)- -> FReal kl -> FReal kr -> r-fRealBOp' k4f k8f l r = getConst $ fRealBOpInternal (go k4f) (go k8f) l r- where go g l' r' = Const $ g l' r'+fRealUOpInplace+ :: (forall a. FKindedC FReal a => a -> a)+ -> FReal -> FReal+fRealUOpInplace f = fRealUOpInplace' f f fRealBOp- :: (forall a. RealFloat a => a -> a -> r)- -> FReal kl -> FReal kr -> r+ :: (forall a. FKindedC FReal a => a -> a -> r)+ -> FReal -> FReal -> r fRealBOp f = fRealBOp' f f -fRealBOpInplace'- :: (Float -> Float -> Float)- -> (Double -> Double -> Double)- -> FReal kl -> FReal kr -> FReal (FTRealCombine kl kr)-fRealBOpInplace' k4f k8f = fRealBOpInternal (go FReal4 k4f) (go FReal8 k8f)- where go f g l r = f $ g l r- fRealBOpInplace- :: (forall a. RealFloat a => a -> a -> a)- -> FReal kl -> FReal kr -> FReal (FTRealCombine kl kr)+ :: (forall a. FKindedC FReal a => a -> a -> a)+ -> FReal -> FReal -> FReal fRealBOpInplace f = fRealBOpInplace' f f--type SomeFReal = SomeFKinded FTReal FReal-deriving stock instance Show SomeFReal-instance Eq SomeFReal where- (SomeFKinded l) == (SomeFKinded r) = fRealBOp (==) l r-instance Ord SomeFReal where- compare (SomeFKinded l) (SomeFKinded r) = fRealBOp compare l r
src/Language/Fortran/Repr/Value/Scalar/String.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+ {- | Fortran CHAR value representation. Currently only CHARs of known length.@@ -13,13 +16,45 @@ import Data.Proxy import Unsafe.Coerce +import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )+import Data.Binary+import Data.Data++import Data.Singletons+import GHC.TypeLits.Singletons+ -- TODO unsafe constructor do not use >:( -- need context for Reasons(TM) data FString (l :: NaturalK) = KnownNat l => FString Text deriving stock instance Show (FString l) deriving stock instance Eq (FString l) deriving stock instance Ord (FString l) -- TODO+deriving stock instance KnownNat l => Data (FString l) +{-+instance Data (FString l) where+ --gunfold k z c = k (z (\x -> case someFString x of SomeFString y -> y))+ gunfold k z c = k (z (FString @l))+-}++eqFString :: FString l -> FString r -> Bool+eqFString (FString l) (FString r) = l == r++-- | This is a painful instance to define. We cheat by leveraging the instance+-- of the length-hiding type 'SomeFString', then asserting length. It's CPU+-- and memory inefficient and has backwards dependencies, but is comfortably+-- safe.+instance KnownNat l => Binary (FString l) where+ put t = put (SomeFString t)+ get =+ get @SomeFString >>= \case+ SomeFString (FString t) ->+ case fString @l t of+ Just t' -> pure t'+ Nothing -> fail "FString had incorrect length"++-- | Attempt to a 'Text' into an 'FString' of the given length. fString :: forall l. KnownNat l => Text -> Maybe (FString l) fString s = if Text.length s == fromIntegral (natVal'' @l)@@ -31,13 +66,34 @@ data SomeFString = forall (l :: NaturalK). KnownNat l => SomeFString (FString l) deriving stock instance Show SomeFString+deriving via (OutShowly SomeFString) instance Out SomeFString+ instance Eq SomeFString where- (SomeFString (FString sl)) == (SomeFString (FString sr)) = sl == sr+ (SomeFString l) == (SomeFString r) = l `eqFString` r +-- TODO impossible??+instance Data SomeFString where++{-+dataSomeFStringT = mkDataType "TODO" [dataSomeFStringC1]+dataSomeFStringC1 = mkConstr dataSomeFStringT "SomeFString" [] Prefix+instance Data SomeFString where+ dataTypeOf _ = dataSomeFStringT+ toConstr = \case+ SomeFString{} -> dataSomeFStringC1+ --gunfold k z c = k (z SomeFString)+ gunfold k z c = k (z (\(FString fstr :: FString l) -> SomeFString @l (FString fstr)))+-}++instance Binary SomeFString where+ put (SomeFString (FString t)) = put t+ get = someFString <$> get @Text++-- | Lift a 'Text' into 'SomeFString'. someFString :: Text -> SomeFString-someFString s =- case someNatVal (fromIntegral (Text.length s)) of- SomeNat (_ :: Proxy n) -> SomeFString $ FString @n s+someFString t =+ case someNatVal (fromIntegral (Text.length t)) of+ SomeNat (_ :: Proxy l) -> SomeFString $ FString @l t someFStringLen :: SomeFString -> Natural someFStringLen (SomeFString s) = fStringLen s
src/Language/Fortran/Rewriter/Internal.hs view
@@ -267,20 +267,22 @@ -- Text after line 72 is an implicit comment, so should stay there regardless -- of what happens to the rest of the source padImplicitComments :: Chunk -> Int -> Chunk- padImplicitComments chunk targetCol =- let zippedChunk = zip [0 ..] chunk- in case findCommentRChar zippedChunk of- Just (index, rc) ->- case- findExclamationRChar zippedChunk- >>= \(id2, _) -> return (id2 >= index)- of- Just False -> chunk -- in this case there's a "!" before column 73- _ ->- take index chunk- ++ padCommentRChar rc (targetCol - index)- : drop (index + 1) chunk- Nothing -> chunk+ padImplicitComments chunk targetCol+ | isMarkedForRemoval chunk = chunk+ | otherwise =+ let zippedChunk = zip [0 ..] chunk+ in case findCommentRChar zippedChunk of+ Just (index, rc) ->+ case+ findExclamationRChar zippedChunk+ >>= \(id2, _) -> return (id2 >= index)+ of+ Just False -> chunk -- in this case there's a "!" before column 73+ _ ->+ take index chunk+ ++ padCommentRChar rc (targetCol - index)+ : drop (index + 1) chunk+ Nothing -> chunk where -- Find the first location of a '!' in the chunks findExclamationRChar = find ((\(RChar c _ _ _) -> c == Just '!') . snd)@@ -298,6 +300,9 @@ (BC.pack (replicate padding ' ' ++ maybeToList char) `BC.append` repl) +isMarkedForRemoval (RChar _ True _ _ : _) = True+isMarkedForRemoval (_ : rs) = isMarkedForRemoval rs+isMarkedForRemoval [] = False -- | Return TRUE iff the 'Replacement' constitutes a character -- insertion.
src/Language/Fortran/Transformation/Monad.hs view
@@ -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
src/Language/Fortran/Util/Files.hs view
@@ -1,17 +1,23 @@ module Language.Fortran.Util.Files ( flexReadFile+ , 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 ((</>))-import Data.List ((\\))-+ doesDirectoryExist, getDirectoryContents, doesFileExist)+import System.FilePath ((</>), takeExtension)+import System.IO.Temp (withSystemTempDirectory)+import System.Process (callProcess)+import Data.List ((\\), foldl')+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.@@ -33,9 +39,68 @@ 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+runCPP :: Maybe String -> FilePath -> IO B.ByteString+runCPP Nothing path = flexReadFile path -- Nothing = do not run CPP+runCPP (Just cppOpts) path = do+ -- Fold over the lines, skipping CPP pragmas and inserting blank+ -- lines as needed to make the line numbers match up for the current+ -- file. CPP pragmas for other files are just ignored.+ let processCPPLine :: ([B.ByteString], Int) -> B.ByteString -> ([B.ByteString], Int)+ processCPPLine (revLs, curLineNo) curLine+ | B.null curLine || B.head curLine /= '#' = (curLine:revLs, curLineNo + 1)+ | linePath /= path = (revLs, curLineNo)+ | newLineNo <= curLineNo = (revLs, curLineNo)+ | otherwise = (replicate (newLineNo - curLineNo) B.empty ++ revLs,+ newLineNo)+ where+ newLineNo = read . B.unpack . B.takeWhile isNumber . B.drop 2 $ curLine+ linePath = B.unpack . B.takeWhile (/='"') . B.drop 1 . B.dropWhile (/='"') $ curLine++ withSystemTempDirectory "fortran-src" $ \ tmpdir -> do+ let outfile = tmpdir </> "cpp.out"+ callProcess "cpp" $ words cppOpts ++ ["-CC", "-nostdinc", "-o", outfile, path]+ contents <- flexReadFile outfile+ 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]
src/Language/Fortran/Util/ModFile.hs view
@@ -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,10 +120,11 @@ , mfStringMap :: StringMap , mfModuleMap :: FAR.ModuleMap , mfDeclMap :: DeclMap- , mfTypeEnv :: FAT.TypeEnv+ , mfTypeEnv :: FAT.TypeEnvExtended , mfParamVarMap :: ParamVarMap- , mfOtherData :: M.Map String LB.ByteString }- deriving (Eq, Ord, Show, Data, Typeable, Generic)+ , 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
src/Language/Fortran/Util/Position.hs view
@@ -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
src/Language/Fortran/Version.hs view
@@ -20,10 +20,11 @@ -- The constructor ordering is important, since it's used for the Ord instance -- (which is used extensively for pretty printing). data FortranVersion = Fortran66- | Fortran77- | Fortran77Extended- | Fortran77Legacy+ | Fortran77 -- ^ fairly close to FORTRAN 77 standard+ | 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) ]@@ -60,10 +63,10 @@ -- Defaults to Fortran 90 if suffix is unrecognized. deduceFortranVersion :: FilePath -> FortranVersion deduceFortranVersion path- | isExtensionOf ".f" = Fortran77Extended- | isExtensionOf ".for" = Fortran77- | isExtensionOf ".fpp" = Fortran77- | isExtensionOf ".ftn" = Fortran77+ | isExtensionOf ".f" = Fortran77Legacy+ | isExtensionOf ".for" = Fortran77Legacy+ | isExtensionOf ".fpp" = Fortran77Legacy+ | isExtensionOf ".ftn" = Fortran77Legacy | isExtensionOf ".f90" = Fortran90 | isExtensionOf ".f95" = Fortran95 | isExtensionOf ".f03" = Fortran2003
+ src/Text/PrettyPrint/GenericPretty/Orphans.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DerivingVia #-}+-- TODO orphans pragma++module Text.PrettyPrint.GenericPretty.Orphans where++import Text.PrettyPrint.GenericPretty+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )++import Data.Text ( Text )+import qualified Data.Text as Text+import Data.Int+import Numeric.Natural++-- | Not particularly efficient (but neither is GenericPretty).+deriving via OutShowly Text instance Out Text++deriving via OutShowly Int8 instance Out Int8+deriving via OutShowly Int16 instance Out Int16+deriving via OutShowly Int32 instance Out Int32+deriving via OutShowly Int64 instance Out Int64+deriving via OutShowly Natural instance Out Natural
+ src/Text/PrettyPrint/GenericPretty/ViaShow.hs view
@@ -0,0 +1,31 @@+{- | Low-boilerplate 'Text.PrettyPrint.GenericPretty.Out' instances for+ 'Show'ables using @DerivingVia@.++Useful for integrating types that don't work nicely with 'Generic' with+@GenericPretty@. (Really, there should be a class like+'Text.PrettyPrint.GenericPretty.Out' directly in @pretty@, but alas.)++Use as follows:++data EeGadts a where+ C1 :: EeGadts Bool+ C2 :: EeGadts String+deriving stock instance Show (EeGadts a)+deriving via OutShowly (EeGadts a) instance Out (EeGadts a)+-}++{-# LANGUAGE DerivingVia #-}++module Text.PrettyPrint.GenericPretty.ViaShow+ ( module Text.PrettyPrint.GenericPretty.ViaShow+ , Text.PrettyPrint.GenericPretty.Out+ ) where++import Text.PrettyPrint.GenericPretty ( Out(..) )+import qualified Text.PrettyPrint++newtype OutShowly a = OutShowly { unOutShowly :: a }++instance Show a => Out (OutShowly a) where+ doc (OutShowly a) = Text.PrettyPrint.text $ show a+ docPrec n (OutShowly a) = Text.PrettyPrint.text $ showsPrec n a ""
+ test-data/module/leaf.f90 view
@@ -0,0 +1,4 @@+module leaf+ implicit none+ real :: constant = 0.1+end module
+ test-data/module/mid1.f90 view
@@ -0,0 +1,4 @@+module mid1+ implicit none+ use leaf+end module
+ test-data/module/mid2.f90 view
@@ -0,0 +1,4 @@+module mid2+ implicit none+ use leaf+end module
+ test-data/module/top.f90 view
@@ -0,0 +1,5 @@+module top+ implicit none+ use mid1+ use mid2+end module
+ test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f view
@@ -0,0 +1,4 @@+ program main+ integer hello*4 ! This is a long comment that goes over the 72 columns+ + , hello2*2+ end program main
+ test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected view
@@ -0,0 +1,5 @@+ program main+ ! This is a long comment that goes over the 72 columns+ integer*4 hello+ integer*2 hello2+ end program main
test/Language/Fortran/Analysis/DataFlowSpec.hs view
@@ -2,8 +2,6 @@ import Test.Hspec import TestUtil-import Test.Hspec.QuickCheck-import Test.QuickCheck (Positive(..)) import Language.Fortran.AST import Language.Fortran.Analysis@@ -251,11 +249,6 @@ describe "other" $ it "dominators on disconnected graph" $ dominators (BBGr (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)])) [0,5] [3,9]) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])]-- describe "Constants" $ do- prop "constant folding evaluates exponentation (positive exponent)" $- let constExpoExpr b e = ConstBinary Exponentiation (ConstInt b) (ConstInt e)- in \(base, Positive expo) -> constantFolding (constExpoExpr base expo) `shouldBe` ConstInt (base ^ expo) -------------------------------------------------- -- Label-finding helper functions to help write tests that are
+ test/Language/Fortran/Analysis/ModFileSpec.hs view
@@ -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")+
+ test/Language/Fortran/Analysis/ModGraphSpec.hs view
@@ -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)
test/Language/Fortran/Analysis/SemanticTypesSpec.hs view
@@ -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)"+
test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs view
@@ -6,13 +6,13 @@ import Test.Hspec import TestUtil -import Language.Fortran.Parser ( f77lIncludes )+import qualified Language.Fortran.Parser as Parser import Language.Fortran.AST import Language.Fortran.Util.Position import qualified Data.ByteString.Char8 as B iParser :: [String] -> String -> IO (ProgramFile A0)-iParser incs = f77lIncludes incs mempty "<unknown>" . B.pack+iParser incs = Parser.f77lInlineIncludes incs mempty "<unknown>" . B.pack makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing)
test/Language/Fortran/Parser/Free/Fortran2003Spec.hs view
@@ -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
test/Language/Fortran/Parser/Free/Fortran90Spec.hs view
@@ -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
test/Language/Fortran/Parser/Free/Fortran95Spec.hs view
@@ -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)
test/Language/Fortran/Parser/Free/LexerSpec.hs view
@@ -8,7 +8,7 @@ import Language.Fortran.Parser ( initParseStateFree ) import Language.Fortran.AST.Literal.Real import Language.Fortran.Version-import Language.Fortran.Util.Position (SrcSpan)+import Language.Fortran.Util.Position (SrcSpan(..), initSrcSpan, initPosition, posPragmaOffset, getSpan) import qualified Data.ByteString.Char8 as B @@ -283,6 +283,45 @@ it "Continuation with inline comment" $ shouldBe' (collectF90 "i = & ! hi \n 42") $ pseudoAssign $ flip TIntegerLiteral "42"++ -- posPragmaOffset is the difference between the given line and the current next line.+ let testPos = initPosition { posPragmaOffset = Just (40 - (2 + 1), "file.f") }+ testSS = SrcSpan testPos testPos+ lpToks = fmap ($initSrcSpan) [ flip TId "i", TOpAssign] +++ fmap ($testSS) [flip TIntegerLiteral "42", TEOF ]+ ppoOf = posPragmaOffset . ssFrom . getSpan++ it "Continuation with line pragma" $+ shouldBe (ppoOf <$> collectF90 "i = &\n #line 40 \"file.f\"\n 42") $+ ppoOf <$> lpToks++ it "Continuation with line pragma (tokens)" $+ shouldBe' (collectF90 "i = &\n #line 40 \"file.f\"\n 42")+ lpToks++ it "Continuation with line pragma (CPP style)" $+ shouldBe (ppoOf <$> collectF90 "i = &\n # 40 \"file.f\"\n 42") $+ ppoOf <$> lpToks++ describe "Line pragma directives" $ do+ -- posPragmaOffset is the difference between the given line and the current next line.+ let testPos = initPosition { posPragmaOffset = Just (40 - (2 + 1), "file.f") }+ testSS = SrcSpan testPos testPos+ lpToks = fmap ($initSrcSpan) [ flip TId "i", TOpAssign, flip TIntegerLiteral "42", TNewline ] +++ fmap ($testSS) [flip TId "j", TOpAssign, flip TIntegerLiteral "42", TEOF ]+ ppoOf = posPragmaOffset . ssFrom . getSpan++ it "Line pragma" $+ shouldBe (ppoOf <$> collectF90 "i = 42\n#line 40 \"file.f\"\n j = 42") $+ ppoOf <$> lpToks++ it "Line pragma (tokens)" $+ shouldBe' (collectF90 "i = 42\n#line 40 \"file.f\"\n j = 42")+ lpToks++ it "Line pragma (CPP style)" $+ shouldBe (ppoOf <$> collectF90 "i = 42\n# 40 \"file.f\"\n j = 42") $+ ppoOf <$> lpToks describe "Comment" $ do it "Full line comment" $
test/Language/Fortran/PrettyPrintSpec.hs view
@@ -548,6 +548,19 @@ <> "&\n &" <> "illy_variable_name = 1" reformatMixedFormInsertContinuations input `shouldBe` expect+ it "correctly handles 72 character long statements" $ do+ let input = " integer*4 :: x, y, z\n"+ <> " x = +(((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+ expect = " integer*4 :: x, y, z\n"+ <> " x = +(((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+ reformatMixedFormInsertContinuations input `shouldBe` expect+ it "correctly handles 73 character long statements" $ do+ let input = " integer*4 :: x, y, z\n"+ <> " x = + (((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+ expect = " integer*4 :: x, y, z\n"+ <> " x = + (((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x))&\n"+ <> " &)"+ reformatMixedFormInsertContinuations input `shouldBe` expect it "does not continuate a long mixed-form comment line" $ do let input = " ! a very long, long comment that ends up"
+ test/Language/Fortran/Repr/EvalSpec.hs view
@@ -0,0 +1,45 @@+module Language.Fortran.Repr.EvalSpec where++import Test.Hspec+import Test.Hspec.QuickCheck ( prop )+import Test.QuickCheck ( NonNegative(..) )++import TestUtil ( u )++import Language.Fortran.AST+import Language.Fortran.Repr+import Language.Fortran.Repr.Eval.Value++import Language.Fortran.Analysis++import Data.Int++spec :: Spec+spec =+ describe "exponentiation" $+ prop "integer exponentation (+ve exponent) (INTEGER(4))" $+ \base (NonNegative (expo :: Int32)) ->+ let expr = expBinary Exponentiation (expValInt base) (expValInt expo)+ in shouldEvalTo (FSVInt (FInt4 (base^expo))) (evalExpr expr)++shouldEvalTo :: FScalarValue -> FEvalValuePure FValue -> Expectation+shouldEvalTo checkVal prog =+ case runEvalFValuePure mempty prog of+ Right (a, _msgs) ->+ case a of+ MkFScalarValue a' -> a' `shouldBe` checkVal+ -- _ -> expectationFailure "not a scalar"+ Left e -> expectationFailure (show e)++expBinary :: BinaryOp -> Expression (Analysis ()) -> Expression (Analysis ()) -> Expression (Analysis ())+expBinary = ExpBinary (analysis0 ()) 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 (Analysis ())+valInteger i = ValInteger (show i) Nothing++expValInt :: (Integral a, Show a) => a -> Expression (Analysis ())+expValInt = expValue . valInteger
test/Language/Fortran/RewriterSpec.hs view
@@ -300,6 +300,26 @@ , "006_linewrap_heuristic.f" ] #endif+ it "implicit comment removal" $ do+ base <- getCurrentDirectory+ let+ body workDir = processReplacements $ M.fromList+ [ ( workDir ++ "001_foo.f"+ , [ Replacement+ (SourceRange (SourceLocation 1 0) (SourceLocation 3 0))+ $ unlines [ " ! This is a long comment that goes over the 72 columns"+ , " integer*4 hello"+ , " integer*2 hello2"+ ]+ ]+ )+ ]+ wrapReplacementsMapInvocationTestHelper+ body+ base+ Nothing+ "replacementsmap-padimplicitcomment"+ [ "001_foo.f" ] describe "Filtering overlapping replacements" $ do it "Simple overlap" $ do