From bd27ae8161860f9a40c3953e20001af1f450d5f4 Mon Sep 17 00:00:00 2001
From: Brad Richardson <everythingfunctional@protonmail.com>
Date: Thu, 15 Oct 2020 11:07:47 -0500
Subject: Add test for whether a module produces a .smod file

---
 bootstrap/src/BuildModel.hs | 43 +++++++++++++++++++++++++++++++++++++------
 1 file changed, 37 insertions(+), 6 deletions(-)

(limited to 'bootstrap/src/BuildModel.hs')

diff --git a/bootstrap/src/BuildModel.hs b/bootstrap/src/BuildModel.hs
index baefda9..dc57f81 100644
--- a/bootstrap/src/BuildModel.hs
+++ b/bootstrap/src/BuildModel.hs
@@ -29,6 +29,7 @@ data LineContents =
     ProgramDeclaration
   | ModuleDeclaration String
   | ModuleUsed String
+  | ModuleSubprogramDeclaration
   | Other
 
 data RawSource = RawSource {
@@ -47,6 +48,7 @@ data Source =
     , moduleObjectFileName :: FilePath -> FilePath
     , moduleModulesUsed :: [String]
     , moduleName :: String
+    , moduleProducesSmod :: Bool
     }
 
 processRawSource :: RawSource -> Source
@@ -62,11 +64,13 @@ processRawSource rawSource =
                      , programModulesUsed    = modulesUsed
                      }
         else if hasModuleDeclaration parsedContents
-          then Module { moduleSourceFileName = sourceFileName
-                      , moduleObjectFileName = objectFileName
-                      , moduleModulesUsed    = modulesUsed
-                      , moduleName           = getModuleName parsedContents
-                      }
+          then Module
+            { moduleSourceFileName = sourceFileName
+            , moduleObjectFileName = objectFileName
+            , moduleModulesUsed    = modulesUsed
+            , moduleName           = getModuleName parsedContents
+            , moduleProducesSmod = hasModuleSubprogramDeclaration parsedContents
+            }
           else undefined
 
 pathSeparatorsToUnderscores :: FilePath -> FilePath
@@ -96,6 +100,15 @@ hasModuleDeclaration parsedContents = case filter f parsedContents of
     ModuleDeclaration{} -> True
     _                   -> False
 
+hasModuleSubprogramDeclaration :: [LineContents] -> Bool
+hasModuleSubprogramDeclaration parsedContents = case filter f parsedContents of
+  x : _ -> True
+  _     -> False
+ where
+  f lc = case lc of
+    ModuleSubprogramDeclaration -> True
+    _                           -> False
+
 getModulesUsed :: [LineContents] -> [String]
 getModulesUsed = mapMaybe contentToMaybeModuleName
  where
@@ -130,7 +143,10 @@ doFortranLineParse = option Other fortranUsefulContents
 
 fortranUsefulContents :: ReadP LineContents
 fortranUsefulContents =
-  programDeclaration <|> moduleDeclaration <|> useStatement
+  programDeclaration
+    <|> moduleSubprogramDeclaration
+    <|> moduleDeclaration
+    <|> useStatement
 
 programDeclaration :: ReadP LineContents
 programDeclaration = do
@@ -158,6 +174,16 @@ useStatement = do
   skipSpaceCommaOrEnd
   return $ ModuleUsed modName
 
+moduleSubprogramDeclaration :: ReadP LineContents
+moduleSubprogramDeclaration = do
+  skipAnything
+  _ <- string "module"
+  skipAtLeastOneWhiteSpace
+  skipAnything
+  _ <- string "function" <|> string "subroutine"
+  skipAtLeastOneWhiteSpace
+  return $ ModuleSubprogramDeclaration
+
 skipAtLeastOneWhiteSpace :: ReadP ()
 skipAtLeastOneWhiteSpace = do
   _ <- many1 whiteSpace
@@ -182,6 +208,11 @@ skipComment = do
   _ <- char '!'
   return ()
 
+skipAnything :: ReadP ()
+skipAnything = do
+  _ <- many (satisfy (const True))
+  return ()
+
 whiteSpace :: ReadP Char
 whiteSpace = satisfy (`elem` " \t")
 
-- 
cgit v1.2.3