Free form legacy support (Fortran90Legacy mode).

src/Language/Fortran/Parser/Free/Fortran90.y

@@ -21,6 +21,7 @@ import Language.Fortran.AST
 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 )
 
 }
 
@@ -87,6 +88,14 @@ import qualified Data.List as List
   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 _ }
@@ -528,6 +537,43 @@ NONEXECUTABLE_STATEMENT :: { Statement A0 }
 -- 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/Lexer.x

@@ -146,6 +146,14 @@ tokens :-
 <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 }
@@ -643,6 +651,9 @@ fillConstr = toConstr . ($ undefined)
 -- 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
@@ -1261,6 +1272,14 @@ data Token =
   | 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/PrettyPrint.hs

@@ -480,7 +480,7 @@ instance Pretty (Statement a) where
       | 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
@@ -545,11 +545,11 @@ instance Pretty (Statement a) where
       | otherwise = "data" <+> hsep (map (pprint' v) dataGroups)
 
     pprint' v (StAutomatic _ _ decls) =
-        continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Automatic statement" v $
+        continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Automatic statement" v $
             "automatic" <+> pprint' v decls
 
     pprint' v (StStatic _ _ decls) =
-        continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Static statement" v $
+        continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Static statement" v $
             "static" <+> pprint' v decls
 
     pprint' v (StNamelist _ _ namelist)

src/Language/Fortran/Util/Files.hs

@@ -12,7 +12,7 @@
 import qualified Data.Text.Encoding.Error   as T
 import qualified Data.ByteString.Char8      as B
 import           System.Directory (listDirectory, canonicalizePath,
-                                   doesDirectoryExist, getDirectoryContents)
+                                   doesDirectoryExist, getDirectoryContents, doesFileExist)
 import           System.FilePath  ((</>), takeExtension)
 import           System.IO.Temp   (withSystemTempDirectory)
 import           System.Process   (callProcess)

src/Language/Fortran/Version.hs

@@ -24,6 +24,7 @@ data FortranVersion = Fortran66
                     | Fortran77Extended -- ^ F77 with some extensions
                     | Fortran77Legacy   -- ^ F77 with most extensions
                     | Fortran90
+                    | Fortran90Legacy -- ^ F90 with legacy extensions
                     | Fortran95
                     | Fortran2003
                     | Fortran2008
@@ -35,6 +36,7 @@ instance Show FortranVersion where
   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 @@ fortranVersionAliases = [ ("66" , Fortran66)
                         , ("77l", Fortran77Legacy)
                         , ("77" , Fortran77)
                         , ("90" , Fortran90)
+                        , ("90l", Fortran90Legacy)
                         , ("95" , Fortran95)
                         , ("03" , Fortran2003)
                         , ("08" , Fortran2008) ]

test/Language/Fortran/Parser/Free/Fortran90Spec.hs

@@ -17,21 +17,24 @@ import qualified Language.Fortran.Parser.Free.Lexer     as Free
 --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 @@ spec =
       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