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 @@ programUnit (PUFunction a s ty rec name args res blocks m_contains) = do
   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 @@ programUnit (PUSubroutine a s rec name args blocks m_contains) = do
   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 @@ initialEnv blocks = do
   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 @@ initialEnv blocks = do
 
   -- 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 :: String -> Renamer (Maybe String)
 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 @@ renameSubPUs (Just pus) = skimProgramUnits pus >> Just <$> mapM programUnit pus
 -- 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 @@ renameGenericDecls = trans renameExpDecl
 -- 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 @@ renameInterfaces = trans interface
 
 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,11 @@ decodeModFiles' = fmap (map snd) . decodeModFiles
 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
@@ -244,13 +249,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

@@ -1,7 +1,7 @@
 module Language.Fortran.Analysis.ModGraphSpec (spec) where
 
 import Test.Hspec
 import TestUtil
 
 import Language.Fortran.Analysis.ModGraph
 import Language.Fortran.Util.Files (expandDirs)
@@ -17,10 +17,14 @@
 -- 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
-    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)