Localise module maps

CHANGELOG.md

@@ -1,3 +1,8 @@
+### 0.16.0 (2024)
+ * Added `--show-make-list` 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
 

app/Main.hs

@@ -50,11 +50,16 @@ import qualified Language.Fortran.Parser.Free.Lexer as Free
 programName :: String
 programName = "fortran-src"
 
+showVersion :: String
+showVersion = "0.16.0"
+
 main :: IO ()
 main = do
  args <- getArgs
  (opts, parsedArgs) <- compileArgs args
  case (parsedArgs, action opts) of
+ (paths, ShowMyVersion) -> do
+ putStrLn $ "fortran-src version: " ++ showVersion
  (paths, ShowMakeGraph) -> do
  paths' <- expandDirs paths
  mg <- genModGraph (fortranVersion opts) (includeDirs opts) (cppOptions opts) paths'
@@ -217,8 +222,12 @@ compileFileToMod mvers mods path moutfile = do
  mmap = combinedModuleMap mods
  tenv = 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
@@ -301,6 +310,7 @@ printTypeErrors = putStrLn . showTypeErrors
 data Action
  = Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile | Compile
  | ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) | ShowMakeGraph | ShowMakeList | Make
+ | ShowMyVersion
  deriving Eq
 
 instance Read Action where
@@ -329,7 +339,11 @@ 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-src.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
 name: fortran-src
-version: 0.15.1
+version: 0.16.0
 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
@@ -280,6 +280,7 @@ test-suite spec
  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

package.yaml

@@ -1,5 +1,5 @@
 name: fortran-src
-version: '0.15.1'
+version: '0.16.0'
 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

src/Language/Fortran/Analysis.hs

@@ -6,7 +6,8 @@ module Language.Fortran.Analysis
  ( initAnalysis, stripAnalysis, Analysis(..)
  , varName, srcName, lvVarName, lvSrcName, isNamedExpression
  , genVar, puName, puSrcName, blockRhsExprs, rhsExprs
- , ModEnv, NameType(..), IDType(..), ConstructType(..)
+ , ModEnv, NameType(..), Locality(..), markAsImported, isImported
+ , IDType(..), ConstructType(..)
  , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars
  , blockVarUses, blockVarDefs
  , BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty
@@ -77,10 +78,31 @@ type TransFunc f g a = (f (Analysis a) -> f (Analysis a)) -> g (Analysis a) -> g
 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)

src/Language/Fortran/Analysis/ModGraph.hs

@@ -16,7 +16,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
 
 --------------------------------------------------

src/Language/Fortran/Analysis/Renaming.hs

@@ -120,7 +120,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 +133,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 +230,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 +259,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 +331,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 +378,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 +400,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 +414,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/Repr/Value/Machine.hs

@@ -2,6 +2,8 @@
 
 module Language.Fortran.Repr.Value.Machine where
 
+import Language.Fortran.Repr.Value.Scalar.Real
+import Language.Fortran.Repr.Value.Scalar.Int.Machine
 import Language.Fortran.Repr.Value.Scalar.Machine
 import Language.Fortran.Repr.Type
 
@@ -18,3 +20,15 @@ data FValue = MkFScalarValue FScalarValue
 fValueType :: FValue -> FType
 fValueType = \case
  MkFScalarValue a -> MkFScalarType $ fScalarValueType a
+
+fromConstInt :: FValue -> Maybe Integer
+fromConstInt (MkFScalarValue (FSVInt a)) = Just $ withFInt a
+fromConstInt _ = Nothing
+
+fromConstReal :: FValue -> Maybe Double
+fromConstReal (MkFScalarValue (FSVReal (FReal4 a))) = Just $ floatToDouble a
+ where
+ floatToDouble :: Float -> Double
+ floatToDouble = realToFrac
+fromConstReal (MkFScalarValue (FSVReal (FReal8 a))) = Just $ a
+fromConstReal _ = Nothing

src/Language/Fortran/Repr/Value/Scalar/Machine.hs

@@ -55,4 +55,4 @@ fScalarValueType = \case
  FSVReal a -> FSTReal $ fKind a
  FSVComplex a -> FSTComplex $ fKind a
  FSVLogical a -> FSTLogical $ fKind a
- FSVString a -> FSTString $ fromIntegral $ Text.length a
+ FSVString a -> FSTString $ fromIntegral $ Text.length a

src/Language/Fortran/Util/ModFile.hs

@@ -55,7 +55,7 @@ module Language.Fortran.Util.ModFile
  , moduleFilename
  , StringMap, extractStringMap, combinedStringMap
  , DeclContext(..), DeclMap, extractDeclMap, combinedDeclMap
- , extractModuleMap, combinedModuleMap, combinedTypeEnv
+ , extractModuleMap, combinedModuleMap, localisedModuleMap, combinedTypeEnv
  , ParamVarMap, extractParamVarMap, combinedParamVarMap
  , genUniqNameToFilenameMap
  , TimestampStatus(..), checkTimestamps
@@ -217,6 +217,9 @@ decodeModFiles' = fmap (map snd) . decodeModFiles
 combinedModuleMap :: ModFiles -> FAR.ModuleMap
 combinedModuleMap = M.unions . map mfModuleMap
 
+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
@@ -244,13 +247,16 @@ moduleFilename = mfFilename
 --------------------------------------------------
 
 -- | Create a map that links all unique variable/function names in the
--- ModFiles to their corresponding filename.
+-- ModFiles to their corresponding *originating* filename (i.e., where they are declared)
 genUniqNameToFilenameMap :: ModFiles -> M.Map F.Name String
 genUniqNameToFilenameMap = M.unions . map perMF
  where
- perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems (mfModuleMap mf)
+ perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems localModuleMap
  , (n, _) <- M.elems modEnv ]
  where
+ -- Make sure that we remove imported declarations so we can
+ -- properly localise declarations to the originator file.
+ localModuleMap = localisedModuleMap $ mfModuleMap mf
  fname = mfFilename mf
 
 --------------------------------------------------

test/Language/Fortran/Analysis/ModFileSpec.hs

@@ -0,0 +1,46 @@
+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
+ paths <- expandDirs ["test-data" </> "module"]
+ -- 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

@@ -21,6 +21,10 @@ testDependencyList = do
  paths' <- expandDirs ["test-data" </> "module"]
  mg <- genModGraph (Just Fortran90) ["."] Nothing paths'
  let list = modGraphToList mg
- let files = ["leaf.f90", "mid1.f90", "mid2.f90", "top.f90"]
- let filesWithPaths = map (("test-data" </> "module") </>) files
- list `shouldBe` filesWithPaths
+ -- 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)