fortran-src 0.5.0 → 0.6.0

raw patch · 30 files changed

+1147/−813 lines, 30 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• fortran-src.cabal +1/−1
• src/Language/Fortran/AST.hs +57/−61
• src/Language/Fortran/AST/AList.hs +12/−0
• src/Language/Fortran/Analysis/BBlocks.hs +0/−2
• src/Language/Fortran/Analysis/SemanticTypes.hs +7/−7
• src/Language/Fortran/Analysis/Types.hs +71/−16
• src/Language/Fortran/Lexer/FreeForm.x +16/−4
• src/Language/Fortran/Parser/Fortran2003.y +194/−72
• src/Language/Fortran/Parser/Fortran66.y +6/−5
• src/Language/Fortran/Parser/Fortran77.y +92/−159
• src/Language/Fortran/Parser/Fortran90.y +111/−41
• src/Language/Fortran/Parser/Fortran95.y +117/−43
• src/Language/Fortran/PrettyPrint.hs +40/−42
• src/Language/Fortran/Transformation/Grouping.hs +18/−190
• src/Language/Fortran/Transformer.hs +12/−7
• src/Language/Fortran/Version.hs +4/−0
• src/Main.hs +1/−1
• test/Language/Fortran/Analysis/TypesSpec.hs +87/−0
• test/Language/Fortran/Parser/Fortran2003Spec.hs +35/−14
• test/Language/Fortran/Parser/Fortran66Spec.hs +3/−3
• test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs +8/−6
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +28/−0
• test/Language/Fortran/Parser/Fortran90Spec.hs +70/−35
• test/Language/Fortran/Parser/Fortran95Spec.hs +70/−35
• test/Language/Fortran/Parser/UtilsSpec.hs +1/−1
• test/Language/Fortran/PrettyPrintSpec.hs +40/−7
• test/Language/Fortran/RewriterSpec.hs +31/−1
• test/Language/Fortran/Transformation/GroupingSpec.hs +0/−60
• test/TestUtil.hs +3/−0

@@ -1,3 +1,15 @@+### 0.6.0 (Sep 03, 2021)+  * IF and CASE block constructs are now parsed as blocks at parsing instead of+    as a post-parse transformation (no intermediate statement representation)+    #154+  * add ASSOCIATE block construct (Fortran 2003 parser only) #165+  * `CommonGroup` AST nodes now store `Declarator`s instead of `Expression`s+    #173+    * various bug fixes related to their typing as a result+  * CI now building on Windows, and save Linux & Windows executables for each+    build+  * various bugfixes (#34, #155)+ ### 0.5.0 (Jun 30, 2021)   * Introduce a second-stage type representation including kind info alongside     types, and resolving some types to semantic type with preset kinds (e.g.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.5.0+version:        0.6.0 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90 and 95. description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. category:       Language

@@ -91,7 +91,6 @@   , A0   , Annotated(..)   , Labeled(..)-  , Conditioned(..)   , Named(..)    -- * Helpers@@ -185,8 +184,9 @@ -- guarantees that it will be Nothing. For CHARACTER types, both maybe or may -- not be present. data Selector a =---                   Maybe length         | Maybe kind-  Selector a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))+  Selector a SrcSpan+    (Maybe (Expression a)) -- ^ length (if present)+    (Maybe (Expression a)) -- ^ kind (if present)   deriving (Eq, Show, Data, Typeable, Generic, Functor)  type Kind = Int@@ -303,52 +303,61 @@  data Block a =     BlStatement a SrcSpan-                (Maybe (Expression a))       -- Label-                (Statement a)                -- Statement+                (Maybe (Expression a))       -- ^ Label+                (Statement a)                -- ^ Statement    | BlForall    a SrcSpan-                (Maybe (Expression a))       -- Label-                (Maybe String)               -- Construct name-                (ForallHeader a)             -- Header information-                [ Block a ]                  -- Body-                (Maybe (Expression a))       -- Label to END DO+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                (ForallHeader a)             -- ^ Header information+                [ Block a ]                  -- ^ Body+                (Maybe (Expression a))       -- ^ Label to END DO    | BlIf        a SrcSpan-                (Maybe (Expression a))       -- Label-                (Maybe String)               -- Construct name-                [ Maybe (Expression a) ]     -- Conditions-                [ [ Block a ] ]              -- Bodies-                (Maybe (Expression a))       -- Label to END IF+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                [ Maybe (Expression a) ]     -- ^ Conditions+                [ [ Block a ] ]              -- ^ Bodies+                (Maybe (Expression a))       -- ^ Label to END IF    | BlCase      a SrcSpan-                (Maybe (Expression a))       -- Label-                (Maybe String)               -- Construct name-                (Expression a)               -- Scrutinee-                [ Maybe (AList Index a) ]    -- Case ranges-                [ [ Block a ] ]              -- Bodies-                (Maybe (Expression a))       -- Label to END SELECT+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                (Expression a)               -- ^ Scrutinee+                [ Maybe (AList Index a) ]    -- ^ Case ranges+                [ [ Block a ] ]              -- ^ Bodies+                (Maybe (Expression a))       -- ^ Label to END SELECT    | BlDo        a SrcSpan-                (Maybe (Expression a))       -- Label-                (Maybe String)               -- Construct name-                (Maybe (Expression a))       -- Target label-                (Maybe (DoSpecification a))  -- Do Specification-                [ Block a ]                  -- Body-                (Maybe (Expression a))       -- Label to END DO+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                (Maybe (Expression a))       -- ^ Target label+                (Maybe (DoSpecification a))  -- ^ Do Specification+                [ Block a ]                  -- ^ Body+                (Maybe (Expression a))       -- ^ Label to END DO    | BlDoWhile   a SrcSpan+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                (Maybe (Expression a))       -- ^ Target label+                (Expression a)               -- ^ Condition+                [ Block a ]                  -- ^ Body+                (Maybe (Expression a))       -- ^ Label to END DO++  | BlAssociate a SrcSpan                 (Maybe (Expression a))       -- Label                 (Maybe String)               -- Construct name-                (Maybe (Expression a))       -- Target label-                (Expression a)               -- Condition+                (AList (ATuple Expression Expression) a) -- Expression abbreviations                 [ Block a ]                  -- Body-                (Maybe (Expression a))       -- Label to END DO+                (Maybe (Expression a))       -- Label to END IF+  -- ^ The first 'Expression' in the abbreviation tuple is always an+  --   @ExpValue _ _ (ValVariable id)@. Also guaranteed nonempty.    | BlInterface a SrcSpan-                (Maybe (Expression a))       -- label-                Bool                         -- abstract?-                [ ProgramUnit a ]            -- Routine decls. in the interface-                [ Block a ]                  -- Module procedures+                (Maybe (Expression a))       -- ^ label+                Bool                         -- ^ abstract?+                [ ProgramUnit a ]            -- ^ Routine decls. in the interface+                [ Block a ]                  -- ^ Module procedures    | BlComment a SrcSpan (Comment a)   deriving (Eq, Show, Data, Typeable, Generic, Functor)@@ -377,6 +386,7 @@   | StExternal            a SrcSpan (AList Expression a)   | StIntrinsic           a SrcSpan (AList Expression a)   | StCommon              a SrcSpan (AList CommonGroup a)+  -- ^ A COMMON statement, defining a list of common blocks.   | StEquivalence         a SrcSpan (AList (AList Expression) a)   | StFormat              a SrcSpan (AList FormatItem a)   | StImplicit            a SrcSpan (Maybe (AList ImpList a))@@ -393,10 +403,6 @@   | StExit                a SrcSpan (Maybe (Expression a))   | StIfLogical           a SrcSpan (Expression a) (Statement a) -- Statement should not further recurse   | StIfArithmetic        a SrcSpan (Expression a) (Expression a) (Expression a) (Expression a)-  | StIfThen              a SrcSpan (Maybe String) (Expression a)-  | StElse                a SrcSpan (Maybe String)-  | StElsif               a SrcSpan (Maybe String) (Expression a)-  | StEndif               a SrcSpan (Maybe String)   | StSelectCase          a SrcSpan (Maybe String) (Expression a)   | StCase                a SrcSpan (Maybe String) (Maybe (AList Index a))   | StEndcase             a SrcSpan (Maybe String)@@ -522,8 +528,10 @@   | ImpRange        a SrcSpan String String   deriving (Eq, Show, Data, Typeable, Generic, Functor) +-- | Note that the 'Declarator's in common group definitions do not contain+--   initializing expressions. data CommonGroup a =-  CommonGroup a SrcSpan (Maybe (Expression a)) (AList Expression a)+  CommonGroup a SrcSpan (Maybe (Expression a)) (AList Declarator a)   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data Namelist a =@@ -572,7 +580,7 @@   | ExpBinary        a SrcSpan BinaryOp (Expression a) (Expression a)   -- ^ A binary operator applied to two expressions.   | ExpUnary         a SrcSpan UnaryOp (Expression a)-  -- ^ A unary operator applied to two expressions.+  -- ^ A unary operator applied to one expression.   | ExpSubscript     a SrcSpan (Expression a) (AList Index a)   -- ^ Array indexing   | ExpDataRef       a SrcSpan (Expression a) (Expression a)@@ -590,9 +598,9 @@ data Index a =     IxSingle a SrcSpan (Maybe String) (Expression a)   | IxRange a SrcSpan-            (Maybe (Expression a)) -- Lower index-            (Maybe (Expression a)) -- Upper index-            (Maybe (Expression a)) -- Stride+            (Maybe (Expression a)) -- ^ Lower index+            (Maybe (Expression a)) -- ^ Upper index+            (Maybe (Expression a)) -- ^ Stride   deriving (Eq, Show, Data, Typeable, Generic, Functor)  -- All recursive Values@@ -653,14 +661,14 @@ -- not enforced by the AST or parser, so be warned. data Declarator a =     DeclVariable a SrcSpan-                 (Expression a) -- ^ Variable-                 (Maybe (Expression a)) -- ^ Length (character)-                 (Maybe (Expression a)) -- ^ Initial value+                 (Expression a)             -- ^ Variable+                 (Maybe (Expression a))     -- ^ Length (character)+                 (Maybe (Expression a))     -- ^ Initial value   | DeclArray a SrcSpan-              (Expression a) -- ^ Array+              (Expression a)                -- ^ Array               (AList DimensionDeclarator a) -- ^ Dimensions-              (Maybe (Expression a)) -- ^ Length (character)-              (Maybe (Expression a)) -- ^ Initial value+              (Maybe (Expression a))        -- ^ Length (character)+              (Maybe (Expression a))        -- ^ Initial value   deriving (Eq, Show, Data, Typeable, Generic, Functor)  setInitialisation :: Declarator a -> Expression a -> Declarator a@@ -869,18 +877,6 @@   setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el   setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el   setLabel b _ = b--class Conditioned f where-  getCondition :: f a -> Maybe (Expression a)--instance Conditioned Block where-  getCondition (BlStatement _ _ _ s) = getCondition s-  getCondition _ = Nothing--instance Conditioned Statement where-  getCondition (StIfThen _ _ _ c) = Just c-  getCondition (StElsif _ _ _ c) = Just c-  getCondition _ = Nothing  data ProgramUnitName =     Named String

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}  module Language.Fortran.AST.AList where @@ -63,3 +64,14 @@  aMap :: (t a -> r a) -> AList t a -> AList r a aMap f (AList a s xs) = AList a s (map f xs)++--------------------------------------------------------------------------------++data ATuple t1 t2 a = ATuple a SrcSpan (t1 a) (t2 a)+    deriving (Eq, Show, Data, Typeable, Generic, Functor)++instance FirstParameter (ATuple t1 t2 a) a+instance SecondParameter (ATuple t1 t2 a) SrcSpan+instance Spanned (ATuple t1 t2 a)+instance (Out a, Out (t1 a), Out (t2 a)) => Out (ATuple t1 t2 a)+instance (NFData a, NFData (t1 a), NFData (t2 a)) => NFData (ATuple t1 t2 a)

@@ -559,8 +559,6 @@ stripNestedBlocks (BlDoWhile a s l tl n e _ el)  = BlDoWhile a s l tl n e [] el stripNestedBlocks (BlIf a s l mn exps _ el)      = BlIf a s l mn exps [] el stripNestedBlocks (BlCase a s l mn sc inds _ el) = BlCase a s l mn sc inds [] el-stripNestedBlocks (BlStatement a s l-                   (StIfLogical a' s' e _))      = BlStatement a s l (StIfLogical a' s' e (StEndif a' s' Nothing)) stripNestedBlocks b                              = b  -- Flatten out function calls within the expression, returning an

@@ -49,13 +49,13 @@ -- TypeSpec? instance Pretty SemType where   pprint' v = \case-    TInteger k -> "integer"-    TReal k    -> "real"-    TComplex k -> "complex"-    TLogical k -> "logical"-    TByte k    -> "byte"-    TCharacter len k -> "character"-    TArray st dims -> pprint' v st <+> parens "(A)"+    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)  -- | The declared dimensions of a staticically typed array variable

@@ -21,7 +21,7 @@ import Data.Map (insert) import qualified Data.Map as M import Data.Maybe (maybeToList)-import Data.List (find)+import Data.List (find, foldl') import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data@@ -41,6 +41,10 @@ -- | Information about a detected type error. type TypeError = (String, SrcSpan) +-- | Mapping of structures to field types+type StructTypeEnv = M.Map Name StructMemberTypeEnv+type StructMemberTypeEnv = M.Map Name IDType+ --------------------------------------------------  -- Monad for type inference work@@ -48,6 +52,7 @@ data InferState = InferState { langVersion :: FortranVersion                              , intrinsics  :: IntrinsicsTable                              , environ     :: TypeEnv+                             , structs     :: StructTypeEnv                              , entryPoints :: M.Map Name (Name, Maybe Name)                              , typeErrors  :: [TypeError] }   deriving Show@@ -167,41 +172,68 @@                                    , let ub = do ExpValue _ _ (ValInteger i) <- ubExp                                                  return $ read i ] -statement :: Data a => InferFunc (Statement (Analysis a))--statement (StDeclaration _ stmtSs ts@(TypeSpec _ _ _ _) mAttrAList declAList)+-- | Auxiliary function for getting semantic and construct type of a declaration.+-- Used in standard declarations and structures+handleDeclaration :: Data a => TypeEnv -> SrcSpan -> TypeSpec (Analysis a)+  -> Maybe (AList Attribute (Analysis a))+  -> AList Declarator (Analysis a)+  -> Infer [(Name, SemType, ConstructType)]+handleDeclaration env stmtSs ts mAttrAList declAList   | mAttrs  <- maybe [] aStrip mAttrAList   , attrDim <- find isAttrDimension mAttrs   , isParam <- any isAttrParameter mAttrs   , isExtrn <- any isAttrExternal mAttrs-  , decls   <- aStrip declAList = do-    env <- gets environ+  , decls   <- aStrip declAList =     let cType n | isExtrn                                     = CTExternal                 | Just (AttrDimension _ _ ddAList) <- attrDim = CTArray (dimDeclarator ddAList)                 | isParam                                     = CTParameter                 | Just (IDType _ (Just ct)) <- M.lookup n env                 , ct /= CTIntrinsic                           = ct                 | otherwise                                   = CTVariable-    forM_ decls $ \ decl -> case decl of-        DeclArray _ declSs v ddAList mLenExpr _ -> do-            let ct = CTArray $ dimDeclarator ddAList+        handler rs = \case+          DeclArray _ declSs v ddAList mLenExpr _ -> do             st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr-            recordType st ct (varName v)-        DeclVariable _ declSs v mLenExpr _      -> do+            pure $ (varName v, st, CTArray  $ dimDeclarator ddAList) : rs+          DeclVariable _ declSs v mLenExpr _ -> do             st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr-            recordType st (cType n) n where n = varName v+            let n = varName v+            pure $ (n, st, cType n) : rs+    in foldM handler [] decls +handleStructureItem :: Data a => StructMemberTypeEnv -> StructureItem (Analysis a) -> Infer StructMemberTypeEnv+handleStructureItem mt (StructFields _ src ts mAttrAList declAList) = do+  env <- gets environ+  ds <- handleDeclaration env src ts mAttrAList declAList+  pure $ foldl' (\m (n, s, c) -> M.insert n (IDType (Just s) (Just c)) m) mt ds+-- TODO: These should eventually be implemented+handleStructureItem mt StructUnion{} = pure mt+handleStructureItem mt StructStructure{} = pure mt++-- | Create a structure env from the list of fields and add it to the InferState+handleStructure ::Data a => Maybe String -> AList StructureItem (Analysis a) -> Infer ()+handleStructure mName itemAList = do+  case mName of+    Just n -> do+      structEnv <- foldM handleStructureItem M.empty (aStrip itemAList)+      recordStruct structEnv n+    Nothing -> pure ()++statement :: Data a => InferFunc (Statement (Analysis a))++statement (StDeclaration _ stmtSs ts mAttrAList declAList) = do+  env <- gets environ+  decls <- handleDeclaration env stmtSs ts mAttrAList declAList+  forM_ decls $ \(n, b, c) -> recordType b c n statement (StExternal _ _ varAList) = do   let vars = aStrip varAList   mapM_ (recordCType CTExternal . varName) vars statement (StExpressionAssign _ _ (ExpSubscript _ _ v ixAList) _)   --  | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v)  -- it's an array (or a string?) FIXME   | all isIxSingle (aStrip ixAList) = do-    let n = varName v-    mIDType <- getRecordedType n+    mIDType <- getExprRecordedType v     case mIDType of       Just (IDType _ (Just CTArray{})) -> return ()                -- do nothing, it's already known to be an array-      _                                -> recordCType CTFunction n -- assume it's a function statement+      _                                -> recordCType CTFunction (varName v) -- assume it's a function statement  -- FIXME: if StFunctions can only be identified after types analysis -- is complete and disambiguation is performed, then how do we get@@ -216,6 +248,8 @@     DeclArray _ _ v ddAList _ _ -> recordCType (CTArray $ dimDeclarator ddAList) (varName v)     _                           -> return () +statement (StStructure _ _ mName itemAList) = handleStructure mName itemAList+ statement _ = return ()  annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))@@ -417,7 +451,7 @@ -- Monadic helper combinators.  inferState0 :: FortranVersion -> InferState-inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v+inferState0 v = InferState { environ = M.empty, structs = M.empty, entryPoints = M.empty, langVersion = v                            , intrinsics = getVersionIntrinsics v, typeErrors = [] } runInfer :: FortranVersion -> TypeEnv -> State InferState a -> (a, InferState) runInfer v env = flip runState ((inferState0 v) { environ = env })@@ -432,6 +466,9 @@ recordType :: SemType -> ConstructType -> Name -> Infer () recordType st ct n = modify $ \ s -> s { environ = insert n (IDType (Just st) (Just ct)) (environ s) } +recordStruct :: StructMemberTypeEnv -> Name -> Infer ()+recordStruct mt n = modify $ \s -> s { structs = insert n mt (structs s) }+ -- Record the type (maybe) of the given name. recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer () recordMType st ct n = modify $ \ s -> s { environ = insert n (IDType st ct) (environ s) }@@ -451,6 +488,24 @@  getRecordedType :: Name -> Infer (Maybe IDType) getRecordedType n = gets (M.lookup n . environ)++getExprRecordedType :: Data a => Expression (Analysis a) -> Infer (Maybe IDType)+getExprRecordedType e@(ExpValue _ _ (ValVariable _)) = getRecordedType $ varName e+getExprRecordedType (ExpSubscript _ _ base _) = do+  mTy <- getExprRecordedType base+  case mTy of+    Just (IDType semTy (Just CTArray{})) -> pure . Just $ IDType semTy (Just CTVariable)+    _ -> pure Nothing+getExprRecordedType (ExpDataRef _ _ base ref) = do+  mTy <- getExprRecordedType base+  case mTy of+    Just (IDType (Just (TCustom n)) _) -> do+      mStructEnv <- gets (M.lookup n . structs)+      case mStructEnv of+        Nothing -> pure Nothing+        Just env -> pure $ M.lookup (varName ref) env+    x -> pure x+getExprRecordedType _ = pure Nothing  -- Set the idType annotation setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a)

@@ -222,7 +222,7 @@ <0> "do"                                          { addSpan TDo } <scN> "do" / { followsColonP }                    { addSpan TDo } <0> "end"\ *"do"                                  { addSpan TEndDo }-<scN> "while" / { followsDoP }                    { addSpan TWhile }+<scN> "while" / { followsDoWithOptLabelP }        { addSpan TWhile } <0> "if"                                          { addSpan TIf } <scN> "if" / { followsColonP }                    { addSpan TIf } <scI> "then"                                      { addSpan TThen }@@ -244,6 +244,9 @@ <0,scI> "pause"                                   { addSpan TPause } <0> "forall"                                      { addSpan TForall } <0> "end"\ *"forall"                              { addSpan TEndForall }+<0> "associate"                                   { addSpan TAssociate }+<scN> "associate" / { followsColonP }             { addSpan TAssociate }+<0> "end"\ *"associate"                           { addSpan TEndAssociate }   -- Where construct@@ -334,10 +337,17 @@   | Just TFormat{} <- aiPreviousToken ai = True   | otherwise = False -followsDoP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsDoP _ _ _ ai-  | Just TDo {} <- aiPreviousToken ai = True+followsDoWithOptLabelP :: User -> AlexInput -> Int -> AlexInput -> Bool+followsDoWithOptLabelP _ _ _ ai+  -- DO ...+  | Just TDo {} <- aiPreviousToken ai        = True++  -- DO 10 ...+  | TDo{}:TIntegerLiteral{}:[] <- prevTokens = True+   | otherwise = False+  where+    prevTokens = reverse . aiPreviousTokensInLine $ ai  followsColonP :: User -> AlexInput -> Int -> AlexInput -> Bool followsColonP _ _ _ ai@@ -1276,6 +1286,8 @@   | TExit               SrcSpan   | TForall             SrcSpan   | TEndForall          SrcSpan+  | TAssociate          SrcSpan+  | TEndAssociate       SrcSpan   -- Where construct   | TWhere              SrcSpan   | TElsewhere          SrcSpan

@@ -1,8 +1,10 @@ -- -*- Mode: Haskell -*-+-- vim: ft=haskell { -- Incomplete work-in-progress. module Language.Fortran.Parser.Fortran2003 ( functionParser                                            , statementParser+                                           , blockParser                                            , fortran2003Parser                                            , fortran2003ParserWithTransforms                                            , fortran2003ParserWithModFiles@@ -32,9 +34,10 @@  } -%name programParser PROGRAM+%name programParser   PROGRAM+%name functionParser  SUBPROGRAM_UNIT+%name blockParser     BLOCK %name statementParser STATEMENT-%name functionParser SUBPROGRAM_UNIT %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token }@@ -158,6 +161,8 @@   case                        { TCase _ }   selectcase                  { TSelectCase _ }   endselect                   { TEndSelect _ }+  associate                   { TAssociate _ }+  endassociate                { TEndAssociate _ }   default                     { TDefault _ }   cycle                       { TCycle _ }   exit                        { TExit _ }@@ -231,6 +236,10 @@  %% +maybe(p)+: p           { Just $1 }+| {- empty -} { Nothing }+ -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 } : NEWLINE PROGRAM_INNER { $2 }@@ -346,13 +355,16 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name }  IMPORT_NAME_LIST :: { [Expression A0] }-: IMPORT_NAME_LIST ',' VARIABLE { $3:$1 }-| VARIABLE { [$1] }+: IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 }+| VARIABLE { [ $1 ] }  BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| ASSOCIATE_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } | ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE@@ -361,6 +373,144 @@   { BlInterface () (getTransSpan $2 $9) $3 $1 [ ] (reverse $6) } | COMMENT_BLOCK { $1 } +IF_BLOCK :: { Block A0 }+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          (endSpan, conds, blocks, endLabel) = $9;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { TId startSpan startName = $1;+          (endSpan, conds, blocks, endLabel) = $11;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          (endSpan, conds, blocks, endLabel) = $10;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          TId _ startName = $2;+          (endSpan, conds, blocks, endLabel) = $12;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }++ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let (endSpan, conds, blocks, endLabel) = $10+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF+  { let (endSpan, endLabel) = $6+    in (endSpan, [Nothing], [reverse $5], endLabel) }+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }++END_IF :: { (SrcSpan, Maybe (Expression A0)) }+: endif { (getSpan $1, Nothing) }+| endif id { (getSpan $2, Nothing) }+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }++CASE_BLOCK :: { Block A0 }+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+          span = getTransSpan $1 endSpan }+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+          span = getTransSpan $1 endSpan }+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+          TId s startName = $1;+          span = getTransSpan s endSpan }+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+          TId s startName = $2;+          span = getTransSpan s endSpan }+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }++-- We store line comments as statements, but this raises an issue: we have+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop+-- them. The inner CASES_ rule does /not/ use this, because comments can always+-- be parsed as belonging to to the above CASE block.+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: COMMENT_BLOCK CASES_ { $2 }+|               CASES_ { $1 }++CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_+  { let (scrutinees, blocks, endLabel, endSpan) = $9+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT+  { let (endLabel, endSpan) = $7+    in ([Nothing], [$6], endLabel, endSpan) }+| END_SELECT+  { let (endLabel, endSpan) = $1+    in ([], [], endLabel, endSpan) }++END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) endselect maybe(id)+  { ($1, maybe (getSpan $2) getSpan $3) }++ASSOCIATE_BLOCK :: { Block A0 }+: INTEGER_LITERAL id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE+  { let { startSpan  = getSpan $1;+          mLabel     = Just $1;+          TId _ name = $2;+          mName      = Just name;+          abbrevs    = fromReverseList $6;+          body       = reverse $10;+          (endSpan, mEndLabel) = $11;+          span       = getTransSpan startSpan endSpan }+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }+| INTEGER_LITERAL        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE+  { let { startSpan  = getSpan $1;+          mLabel     = Just $1;+          mName      = Nothing;+          abbrevs    = fromReverseList $4;+          body       = reverse $8;+          (endSpan, mEndLabel) = $9;+          span       = getTransSpan startSpan endSpan }+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }+|                 id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE+  { let { startSpan  = getSpan $1;+          TId _ name = $1;+          mLabel     = Nothing;+          mName      = Just name;+          abbrevs    = fromReverseList $5;+          body       = reverse $9;+          (endSpan, mEndLabel) = $10;+          span       = getTransSpan startSpan endSpan }+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }+|                        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE+  { let { startSpan  = getSpan $1;+          mLabel     = Nothing;+          mName      = Nothing;+          abbrevs    = fromReverseList $3;+          body       = reverse $7;+          (endSpan, mEndLabel) = $8;+          span       = getTransSpan startSpan endSpan }+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }++-- TODO: Copied verbatim from END_IF. Should attempt to functionalise.+END_ASSOCIATE :: { (SrcSpan, Maybe (Expression A0)) }+: endassociate { (getSpan $1, Nothing) }+| endassociate id { (getSpan $2, Nothing) }+| INTEGER_LITERAL endassociate { (getSpan $2, Just $1) }+| INTEGER_LITERAL endassociate id { (getSpan $3, Just $1) }++-- (var (ExpValue (ValVariable)), assoc. expr)+ABBREVIATIONS :: { [(ATuple Expression Expression A0)] }+: ABBREVIATIONS ',' ABBREVIATION { $3 : $1 }+| ABBREVIATION { [ $1 ] }++ABBREVIATION :: { ATuple Expression Expression A0 }+: VARIABLE '=>' EXPRESSION { ATuple () (getTransSpan $1 $3) $1 $3 }+ ABSTRACTP :: { Bool } : abstract { True } | {- EMPTY -} { False }@@ -435,25 +585,25 @@ | procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_DCOLON PROC_DECLS   { let declAList = fromReverseList $6     in StProcedure () (getTransSpan $1 $6) $3 Nothing declAList }-| dimension MAYBE_DCOLON DECLARATOR_LIST+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StDimension () (getTransSpan $1 declAList) declAList }-| allocatable MAYBE_DCOLON DECLARATOR_LIST+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StAllocatable () (getTransSpan $1 declAList) declAList }-| asynchronous MAYBE_DCOLON DECLARATOR_LIST+| asynchronous MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StAsynchronous () (getTransSpan $1 declAList) declAList }-| pointer MAYBE_DCOLON DECLARATOR_LIST+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StPointer () (getTransSpan $1 declAList) declAList }-| target MAYBE_DCOLON DECLARATOR_LIST+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StTarget () (getTransSpan $1 declAList) declAList }-| value MAYBE_DCOLON DECLARATOR_LIST+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StValue () (getTransSpan $1 declAList) declAList }-| volatile MAYBE_DCOLON DECLARATOR_LIST+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StVolatile () (getTransSpan $1 declAList) declAList } | data cDATA DATA_GROUPS cPOP@@ -565,16 +715,6 @@ | endwhere { StEndWhere () (getSpan $1) Nothing } | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }-| id ':' if '(' EXPRESSION ')' then-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }-| elsif '(' EXPRESSION ')' then id-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }-| else { StElse () (getSpan $1) Nothing }-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }-| endif { StEndif () (getSpan $1) Nothing }-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) } | do { StDo () (getSpan $1) Nothing Nothing Nothing } | id ':' do   { let TId s id = $1@@ -607,21 +747,6 @@ | continue { StContinue () (getSpan $1) } | stop { StStop () (getSpan $1) Nothing } | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }-| selectcase '(' EXPRESSION ')'-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }-| id ':' selectcase '(' EXPRESSION ')'-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }-| case default id-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }-| case '(' INDICIES ')'-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }-| case '(' INDICIES ')' id-  { let TId s id = $5-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }-| endselect { StEndcase () (getSpan $1) Nothing }-| endselect id-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT   { StIfLogical () (getTransSpan $1 $5) $3 $5 } | read CILIST IN_IOLIST@@ -819,21 +944,21 @@ | INIT_COMMON_GROUP { [ $1 ] }  COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }  INIT_COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }-| PART_REFS+| UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $1     in CommonGroup () (getSpan alist) Nothing alist } @@ -895,11 +1020,11 @@   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }  DECLARATION_STATEMENT :: { Statement A0 }-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;           declAList = fromReverseList $4 }     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }-| TYPE_SPEC DECLARATOR_LIST+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST   { let { declAList = fromReverseList $2 }     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } @@ -956,11 +1081,15 @@ COMMON_NAME :: { Expression A0 } : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 } -DECLARATOR_LIST :: { [ Declarator A0 ] }-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }-| INITIALISED_DECLARATOR { [ $1 ] }+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }+| INITIALIZED_DECLARATOR { [ $1 ] } -INITIALISED_DECLARATOR :: { Declarator A0 }+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }+| DECLARATOR { [ $1 ] }++INITIALIZED_DECLARATOR :: { Declarator A0 } : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR { $1 }@@ -1194,45 +1323,38 @@   StForallStatement () (getTransSpan $1 $3) h $3 } -FORALL_HEADER-  :: { (ForallHeader A0, SrcSpan) }-FORALL_HEADER :-  -- Standard simple forall header-    '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }-  -- forall header with scale expression-  | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'-                                  { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }-  -- multi forall header-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'-                                  { (ForallHeader $2 Nothing, getTransSpan $1 $3) }-  -- multi forall header with scale-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'-                                  { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }+FORALL_HEADER :: { (ForallHeader A0, SrcSpan) }+-- Standard simple forall header+: '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }+-- forall header with scale expression+| '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'+                              { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }+-- multi forall header+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'+                              { (ForallHeader $2 Nothing, getTransSpan $1 $3) }+-- multi forall header with scale+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'+                              { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }  FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE   :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE : '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 } | {- empty -}                                                          { [] }  FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }-FORALL_TRIPLET_SPEC : NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) } | NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }  FORALL_ASSIGNMENT_STMT :: { Statement A0 }-FORALL_ASSIGNMENT_STMT :-    EXPRESSION_ASSIGNMENT_STATEMENT { $1 }-  | POINTER_ASSIGNMENT_STMT { $1 }+: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }+| POINTER_ASSIGNMENT_STMT { $1 }  POINTER_ASSIGNMENT_STMT :: { Statement A0 }-POINTER_ASSIGNMENT_STMT :- DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }+: DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }  END_FORALL :: { Statement A0 }-END_FORALL :-   endforall    { StEndForall () (getSpan $1) Nothing }- | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}+: endforall    { StEndForall () (getSpan $1) Nothing }+| endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}  EXPRESSION_LIST :: { [ Expression A0 ] } : EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }

@@ -288,16 +288,16 @@  COMMON_GROUP :: { CommonGroup A0 } COMMON_GROUP-: COMMON_NAME NAME_LIST+: COMMON_NAME DECLARATORS   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }  INIT_COMMON_GROUP :: { CommonGroup A0 } INIT_COMMON_GROUP-: COMMON_NAME NAME_LIST+: COMMON_NAME DECLARATORS   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }-| NAME_LIST { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+| DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }  COMMON_NAME :: { Expression A0 } COMMON_NAME : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }@@ -309,6 +309,7 @@  NAME_LIST_ELEMENT :: { Expression A0 } : VARIABLE { $1 } | SUBSCRIPT { $1 } +-- Note that declarator lists in the F66 parser don't have initializers. DECLARATORS :: { AList Declarator A0 } DECLARATORS : DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }

@@ -1,8 +1,11 @@ -- -*- Mode: Haskell -*-+-- vim: ft=haskell {+{-# LANGUAGE TupleSections #-} module Language.Fortran.Parser.Fortran77   ( expressionParser   , statementParser+  , blockParser   , fortran77Parser   , fortran77ParserWithTransforms   , fortran77ParserWithModFiles@@ -44,6 +47,7 @@  %name programParser PROGRAM %name includesParser INCLUDES+%name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION %monad { LexAction }@@ -200,22 +204,18 @@  -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 }-PROGRAM : NEWLINE PROGRAM_INNER { $2 } | PROGRAM_INNER { $1 }  PROGRAM_INNER :: { ProgramFile A0 }-PROGRAM_INNER : PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) (reverse $1) } | {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) [] }  PROGRAM_UNITS :: { [ ProgramUnit A0 ] }-PROGRAM_UNITS : PROGRAM_UNITS maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { $3 : $1 } | maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }  PROGRAM_UNIT :: { ProgramUnit A0 }-PROGRAM_UNIT : program NAME NEWLINE BLOCKS ENDPROG   { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing } | TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN@@ -229,24 +229,20 @@ | comment { let (TComment s c) = $1 in PUComment () s (Comment c) }  END :: { Token }-END : end                  { $1 } | LABEL_IN_6COLUMN end { $2 }  ENDPROG :: { Token }-ENDPROG : END                         { $1 } | endprogram MAYBE_ID       { $1 } | LABEL_IN_6COLUMN endprogram MAYBE_ID { $2 }  ENDFUN :: { Token }-ENDFUN : END                          { $1 } | endfunction MAYBE_ID       { $1 } | LABEL_IN_6COLUMN endfunction MAYBE_ID { $2 }  ENDSUB :: { Token }-ENDSUB : END                            { $1 } | endsubroutine MAYBE_ID       { $1 } | LABEL_IN_6COLUMN endsubroutine MAYBE_ID { $2 }@@ -262,61 +258,67 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name }  INCLUDES :: { [ Block A0 ] }-INCLUDES : maybe(NEWLINE) list(BLOCK) { $2 }  BLOCKS :: { [ Block A0 ] }-BLOCKS : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-BLOCK-: LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }+: IF_BLOCK NEWLINE { $1 }+| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } | COMMENT_BLOCK { $1 } +IF_BLOCK :: { Block A0 }+: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {+    let (endSpan, endLabel, conds, blocks) = $8+    in BlIf () (getTransSpan $1 endSpan) Nothing Nothing ((Just $3):conds) ((reverse $7):blocks) endLabel+  }+| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {+    let (endSpan, endLabel, conds, blocks) = $9+    in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing ((Just $4):conds) ((reverse $8):blocks) endLabel+  }++ELSE_BLOCKS :: { (SrcSpan, Maybe (Expression A0), [Maybe (Expression A0)], [[Block A0]]) }+: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS+  { let (endSpan, endLabel, conds, blocks) = $9+    in (endSpan, endLabel, Just $4 : conds, reverse $8 : blocks) }+| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif+  { (getSpan $6, $5, [Nothing], [reverse $4]) }+| maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) }+ COMMENT_BLOCK :: { Block A0 }-COMMENT_BLOCK : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }  NEWLINE :: { Token }-NEWLINE : NEWLINE newline { $1 } | newline { $1 }  STATEMENT :: { Statement A0 }-STATEMENT : LOGICAL_IF_STATEMENT { $1 } | DO_STATEMENT { $1 } | EXECUTABLE_STATEMENT { $1 } | NONEXECUTABLE_STATEMENT { $1 }  LOGICAL_IF_STATEMENT :: { Statement A0 }-LOGICAL_IF_STATEMENT : if '(' EXPRESSION ')' EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }+: if '(' EXPRESSION ')' EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }  DO_STATEMENT :: { Statement A0 }-DO_STATEMENT : do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) } | do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) } | do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) } | do { StDo () (getSpan $1) Nothing Nothing Nothing }  DO_SPECIFICATION :: { DoSpecification A0 }-DO_SPECIFICATION : EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) } | EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION                { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }  EXECUTABLE_STATEMENT :: { Statement A0 }-EXECUTABLE_STATEMENT : EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 } | GOTO_STATEMENT { $1 } | if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }-| else { StElse () (getSpan $1) Nothing }-| endif { StEndif () (getSpan $1) Nothing } | doWhile '(' EXPRESSION ')'   { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 } | do LABEL_IN_STATEMENT while '(' EXPRESSION ')'@@ -372,7 +374,6 @@ | backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }  FORMAT_ID :: { Expression A0 }-FORMAT_ID : FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } | INTEGER_LITERAL               { $1 } -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,@@ -381,7 +382,6 @@ | '*' { ExpValue () (getSpan $1) ValStar }  UNIT :: { Expression A0 }-UNIT : INTEGER_LITERAL { $1 } | SUBSCRIPT { $1 } | '*' { ExpValue () (getSpan $1) ValStar }@@ -389,7 +389,6 @@ -- A crude approximation that makes parsing easy. Individual key value pairs -- should be checket later on. CILIST :: { AList ControlPair A0 }-CILIST : '(' UNIT ',' FORMAT_ID ',' CILIST_PAIRS ')' {   let { cp1 = ControlPair () (getSpan $2) Nothing $2;         cp2 = ControlPair () (getSpan $4) Nothing $4 }@@ -411,20 +410,17 @@ | '(' CILIST_PAIRS ')' { setSpan (getTransSpan $1 $3) $ aReverse $2 }  CILIST_PAIRS :: { AList ControlPair A0 }-CILIST_PAIRS : CILIST_PAIRS ',' CILIST_PAIR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | CILIST_PAIR { AList () (getSpan $1) [ $1 ] }  CILIST_PAIR :: { ControlPair A0 }-CILIST_PAIR : id '=' CILIST_ELEMENT { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }+: id '=' CILIST_ELEMENT { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }  CILIST_ELEMENT :: { Expression A0 }-CILIST_ELEMENT : CI_EXPRESSION { $1 } | '*' { ExpValue () (getSpan $1) ValStar }  CI_EXPRESSION :: { Expression A0 }-CI_EXPRESSION : CI_EXPRESSION '+' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } | CI_EXPRESSION '-' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } | CI_EXPRESSION '*' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }@@ -452,37 +448,31 @@ -- rule separation.  IN_IOLIST :: { AList Expression A0 }-IN_IOLIST : IN_IOLIST ',' IN_IO_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} | IN_IO_ELEMENT { AList () (getSpan $1) [ $1 ] }  IN_IO_ELEMENT :: { Expression A0 }-IN_IO_ELEMENT : SUBSCRIPT { $1 } | '(' IN_IOLIST ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) (aReverse $2) $4 }  OUT_IOLIST :: { AList Expression A0 }-OUT_IOLIST : OUT_IOLIST ',' EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} | EXPRESSION { AList () (getSpan $1) [ $1 ] }  SAVE_ARGS :: { Maybe (AList Expression A0) }-SAVE_ARGS : SAVE_ARGS_LEVEL1 { Just $ fromReverseList $1 } | {-EMPTY-} { Nothing }  SAVE_ARGS_LEVEL1 :: { [ Expression A0 ] }-SAVE_ARGS_LEVEL1 : SAVE_ARGS_LEVEL1 ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }  SAVE_ARG :: { Expression A0 }-SAVE_ARG : COMMON_NAME { $1 } | VARIABLE { $1 }+: COMMON_NAME { $1 } | VARIABLE { $1 }  INTEGER_OR_STRING :: { Expression A0 } : STRING { $1 } | INTEGER_LITERAL { $1 }  GOTO_STATEMENT :: { Statement A0 }-GOTO_STATEMENT : goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 } | goto VARIABLE { StGotoAssigned () (getTransSpan $1 $2) $2 Nothing } | goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) }@@ -491,19 +481,18 @@ | goto LABELS_IN_STATEMENT ',' EXPRESSION { StGotoComputed () (getTransSpan $1 $4) $2 $4 }  EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }-EXPRESSION_ASSIGNMENT_STATEMENT : ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }+: ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }  NONEXECUTABLE_STATEMENT :: { Statement A0 }-NONEXECUTABLE_STATEMENT : external FUNCTION_NAMES { StExternal () (getTransSpan $1 $2) (aReverse $2) } | intrinsic FUNCTION_NAMES { StIntrinsic () (getTransSpan $1 $2) (aReverse $2) }-| dimension ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) }+| 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) }-| automatic DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) }-| static DECLARATORS { StStatic () (getTransSpan $1 $2) (aReverse $2) }+| 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. -- Must be fixed in the future. TODO | format blob@@ -520,18 +509,15 @@   { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) }  MAYBE_NAME :: { Maybe Name }-MAYBE_NAME : '/' NAME '/' { Just $2 } | {- empty -}  { Nothing }  STRUCTURE_DECLARATIONS :: { [StructureItem A0] }-STRUCTURE_DECLARATIONS : 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) }-STRUCTURE_DECLARATION_STATEMENT : DECLARATION_STATEMENT NEWLINE   { let StDeclaration () s t attrs decls = $1     in Just $ StructFields () s t attrs decls }@@ -542,62 +528,51 @@ | comment NEWLINE { Nothing }  UNION_MAPS :: { [ UnionMap A0 ] }-UNION_MAPS : 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) }-UNION_MAP : map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE   { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } | comment NEWLINE { Nothing }  ENTRY_ARGS :: { AList Expression A0 }-ENTRY_ARGS : ENTRY_ARGS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }  ENTRY_ARGS_LEVEL1 :: { AList Expression A0 }-ENTRY_ARGS_LEVEL1 : ENTRY_ARGS_LEVEL1 ',' ENTRY_ARG { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | '(' ENTRY_ARG { AList () (getTransSpan $1 $2) [ $2 ] } | '(' { AList () (getSpan $1) [ ] }  ENTRY_ARG :: { Expression A0 }-ENTRY_ARG : VARIABLE { $1 } | '*' { ExpValue () (getSpan $1) ValStar }  PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }-PARAMETER_ASSIGNMENTS : PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 } | PARAMETER_ASSIGNMENT { [ $1 ] }  PARAMETER_ASSIGNMENT :: { Declarator A0 }-PARAMETER_ASSIGNMENT : VARIABLE '=' CONSTANT_EXPRESSION   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }  DECLARATION_STATEMENT :: { Statement A0 }-DECLARATION_STATEMENT-: TYPE_SPEC maybe(',') DECLARATORS { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }+: TYPE_SPEC maybe(',') INITIALIZED_DECLARATORS+  { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }  IMP_LISTS :: { AList ImpList A0 }-IMP_LISTS : IMP_LISTS ',' IMP_LIST { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | IMP_LIST { AList () (getSpan $1) [ $1 ] }  IMP_LIST :: { ImpList A0 }-IMP_LIST : IMP_TYPE_SPEC '(' IMP_ELEMENTS ')'   { ImpList () (getTransSpan $1 $4) $1 $ aReverse $3 }  IMP_ELEMENTS :: { AList ImpElement A0 }-IMP_ELEMENTS : IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | IMP_ELEMENT { AList () (getSpan $1) [ $1 ] }  IMP_ELEMENT :: { ImpElement A0 }-IMP_ELEMENT : id {% do       let (TId s id) = $1       if length id /= 1@@ -613,38 +588,31 @@              }  ELEMENT :: { Expression A0 }-ELEMENT : SUBSCRIPT { $1 }  DATA_GROUPS :: { [DataGroup A0] }-DATA_GROUPS : DATA_GROUPS ',' DATA_GROUP { $3 : $1 } | DATA_GROUPS DATA_GROUP     { $2 : $1 } | DATA_GROUP                 { [$1] }  DATA_GROUP :: { DataGroup A0 }-DATA_GROUP : DATA_NAMES  '/' DATA_ITEMS '/' { DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) }  DATA_NAMES :: { AList Expression A0 }-DATA_NAMES : NAME_LIST  { $1 } | IMPLIED_DO { fromList () [ $1 ] }  DATA_ITEMS :: { AList Expression A0 }-DATA_ITEMS : DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} | DATA_ITEM { AList () (getSpan $1) [ $1 ] }  DATA_ITEM :: { Expression A0 }-DATA_ITEM : INTEGER_CONSTANT '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | DATA_ITEM_LEVEL1 { $1 }  DATA_ITEM_LEVEL1 :: { Expression A0 }-DATA_ITEM_LEVEL1 : SIGNED_NUMERIC_LITERAL  { $1 }---| COMPLEX_LITERAL         { $1 }+-- | COMPLEX_LITERAL         { $1 } | VARIABLE                { $1 } | '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | LOGICAL_LITERAL         { $1 }@@ -652,94 +620,102 @@ | HOLLERITH               { $1 }  EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 }-EQUIVALENCE_GROUPS : EQUIVALENCE_GROUPS ','  '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 } | '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] }  POINTER_LIST :: { [ Declarator A0 ] }-POINTER_LIST-: POINTER_LIST ',' POINTER-  { $3 : $1 }-| POINTER-  { [ $1 ] }+: POINTER_LIST ',' POINTER { $3 : $1 }+| POINTER                  { [ $1 ] }  POINTER :: { Declarator A0 } : '(' VARIABLE ',' VARIABLE ')'   { DeclVariable () (getTransSpan $1 $5) $2 Nothing (Just $4) }  COMMON_GROUPS :: { AList CommonGroup A0 }-COMMON_GROUPS : COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 } | INIT_COMMON_GROUP { AList () (getSpan $1) [ $1 ] }  COMMON_GROUP :: { CommonGroup A0 }-COMMON_GROUP-: COMMON_NAME NAME_LIST { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }  INIT_COMMON_GROUP :: { CommonGroup A0 }-INIT_COMMON_GROUP-: COMMON_NAME NAME_LIST { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }-| NAME_LIST { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+| UNINITIALIZED_DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }  COMMON_NAME :: { Expression A0 }-COMMON_NAME : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }  NAME_LIST :: { AList Expression A0 }-NAME_LIST : NAME_LIST ',' ELEMENT   { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | ELEMENT { AList () (getSpan $1) [ $1 ] } -DECLARATORS :: { AList Declarator A0 }-DECLARATORS-: DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }-| DECLARATOR { AList () (getSpan $1) [ $1 ] }--DECLARATOR :: { Declarator A0 }-DECLARATOR-: ARRAY_DECLARATOR { $1 }-| VARIABLE_DECLARATOR { $1 }+UNINITIALIZED_DECLARATORS :: { AList Declarator A0 }+: UNINITIALIZED_DECLARATORS ',' UNINITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| UNINITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] } -ARRAY_DECLARATORS :: { AList Declarator A0 }-ARRAY_DECLARATORS-: ARRAY_DECLARATORS ',' ARRAY_DECLARATOR-  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }-| ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }+UNINITIALIZED_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_ARRAY_DECLARATOR { $1 }+| UNINITIALIZED_VARIABLE_DECLARATOR { $1 } -ARRAY_DECLARATOR :: { Declarator A0 }-ARRAY_DECLARATOR+UNINITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 } : VARIABLE '(' DIMENSION_DECLARATORS ')'   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing }+| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')'+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }++UNINITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }+: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }+| VARIABLE '*' SIMPLE_EXPRESSION+  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }++INITIALIZED_DECLARATORS :: { AList Declarator A0 }+: INITIALIZED_DECLARATORS ',' INITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| INITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] }++INITIALIZED_DECLARATOR :: { Declarator A0 }+: INITIALIZED_ARRAY_DECLARATOR { $1 }+| INITIALIZED_VARIABLE_DECLARATOR { $1 }++INITIALIZED_ARRAY_DECLARATORS :: { AList Declarator A0 }+: INITIALIZED_ARRAY_DECLARATORS ',' INITIALIZED_ARRAY_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| INITIALIZED_ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }++INITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_ARRAY_DECLARATOR { $1 } | VARIABLE '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'   { DeclArray () (getTransSpan $1 $7) $1 (aReverse $3) Nothing     (Just (ExpInitialisation () (getSpan $6) (fromReverseList $6))) }-| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')'-  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing } | VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'   { DeclArray () (getTransSpan $1 $9) $1 (aReverse $5) (Just $3)     (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) }-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION-  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION_LIST '/'   { DeclArray () (getTransSpan $1 $9) $1 (aReverse $3) (Just $6)     (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) } +INITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_VARIABLE_DECLARATOR { $1 }+| VARIABLE '/' SIMPLE_EXPRESSION '/'+  { DeclVariable () (getTransSpan $1 $4) $1 Nothing (Just $3) }+| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/'+  { DeclVariable () (getTransSpan $1 $6) $1 (Just $3) (Just $5) }+ SIMPLE_EXPRESSION_LIST :: { [Expression A0] }-SIMPLE_EXPRESSION_LIST : SIMPLE_EXPRESSION_LIST ',' SIMPLE_EXPRESSION  { $3 : $1 } | SIMPLE_EXPRESSION { [ $1 ] }  SIMPLE_EXPRESSION :: { Expression A0 }-SIMPLE_EXPRESSION : INTEGER_CONSTANT '*' CONSTANT  { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | CONSTANT { $1 } | '(' '*' ')' { ExpValue () (getSpan $2) ValStar } | '(' EXPRESSION ')' { $2 }  CONSTANT :: { Expression A0 }-CONSTANT : VARIABLE { $1 } | SIGNED_NUMERIC_LITERAL { $1 } | LOGICAL_LITERAL { $1 }@@ -747,28 +723,15 @@ | HOLLERITH { $1 }  INTEGER_CONSTANT :: { Expression A0 }-INTEGER_CONSTANT : VARIABLE { $1 } | SIGNED_NUMERIC_LITERAL { $1 } -VARIABLE_DECLARATOR :: { Declarator A0 }-VARIABLE_DECLARATOR-: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }-| VARIABLE '*' SIMPLE_EXPRESSION-  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }-| VARIABLE '/' SIMPLE_EXPRESSION '/'-  { DeclVariable () (getTransSpan $1 $4) $1 Nothing (Just $3) }-| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/'-  { DeclVariable () (getTransSpan $1 $6) $1 (Just $3) (Just $5) }- DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }-DIMENSION_DECLARATORS : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR   { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | DIMENSION_DECLARATOR { AList () (getSpan $1) [ $1 ] }  DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }-DIMENSION_DECLARATOR : EXPRESSION ':' EXPRESSION { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) } | EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) } | EXPRESSION ':' '*' { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $ ExpValue () (getSpan $3) ValStar) }@@ -778,23 +741,19 @@ -- since they are syntactically identical at this stage subroutine names -- are also emitted as function names. FUNCTION_NAMES :: { AList Expression A0 }-FUNCTION_NAMES : FUNCTION_NAMES ',' VARIABLE { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | VARIABLE { AList () (getSpan $1) [ $1 ] }  ARGUMENTS :: { AList Argument A0 }-ARGUMENTS : ARGUMENTS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }  ARGUMENTS_LEVEL1 :: { AList Argument A0 }-ARGUMENTS_LEVEL1 : ARGUMENTS_LEVEL1 ',' CALLABLE_EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | '(' CALLABLE_EXPRESSION { AList () (getTransSpan $1 $2) [ $2 ] } | '(' { AList () (getSpan $1) [ ] }  -- Expression all by itself subsumes all other callable expressions. CALLABLE_EXPRESSION :: { Argument A0 }-CALLABLE_EXPRESSION -- Explicitly parse special intrinsics for argument passing types : '%' id '(' EXPRESSION ')'   { let { args = AList () (getSpan $4) $ [Argument () (getSpan $4) Nothing $4];@@ -809,7 +768,6 @@ | EXPRESSION  { Argument () (getSpan $1) Nothing $1 }  EXPRESSION :: { Expression A0 }-EXPRESSION : EXPRESSION '+' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } | EXPRESSION '-' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } | EXPRESSION '*' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }@@ -842,7 +800,6 @@ | '&' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }  IMPLIED_DO :: { Expression A0 }-IMPLIED_DO : '(' EXPRESSION ',' DO_SPECIFICATION ')' {     let expList = AList () (getSpan $2) [ $2 ]           in ExpImpliedDo () (getTransSpan $1 $5) expList $4@@ -858,14 +815,12 @@          }  EXPRESSION_LIST :: { [ Expression A0 ] }-EXPRESSION_LIST : EXPRESSION_LIST ',' EXPRESSION { $3 : $1 } | EXPRESSION { [ $1 ] }  STRING :: { Expression A0 } : string { let (TString s cs) = $1 in ExpValue () s (ValString cs) }  CONSTANT_EXPRESSION :: { Expression A0 }-CONSTANT_EXPRESSION : CONSTANT_EXPRESSION '+' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } | CONSTANT_EXPRESSION '-' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } | CONSTANT_EXPRESSION '*' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }@@ -891,7 +846,6 @@           }  ARITHMETIC_CONSTANT_EXPRESSION :: { Expression A0 }-ARITHMETIC_CONSTANT_EXPRESSION : ARITHMETIC_CONSTANT_EXPRESSION '+' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } | ARITHMETIC_CONSTANT_EXPRESSION '-' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } | ARITHMETIC_CONSTANT_EXPRESSION '*' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }@@ -905,7 +859,6 @@ | SUBSCRIPT                    { $1 }  RELATIONAL_OPERATOR :: { BinaryOp }-RELATIONAL_OPERATOR : '=='  { EQ } | '!='  { NE } | '>'   { GT }@@ -914,7 +867,6 @@ | '<='  { LTE }  SUBSCRIPT :: { Expression A0 }-SUBSCRIPT : SUBSCRIPT '.' VARIABLE   { ExpDataRef () (getTransSpan $1 $3) $1 $3 } | SUBSCRIPT '%' VARIABLE@@ -942,7 +894,6 @@   { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }  ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }-ARITHMETIC_SIGN : '-' { (getSpan $1, Minus) } | '+' { (getSpan $1, Plus) } @@ -950,12 +901,10 @@ : VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }  VARIABLES :: { [ Expression A0 ] }-VARIABLES : VARIABLES ',' VARIABLE_OR_STAR { $3 : $1 } | VARIABLE_OR_STAR { [ $1 ] }  VARIABLE_OR_STAR :: { Expression A0 }-VARIABLE_OR_STAR : VARIABLE { $1 } | '*' { ExpValue () (getSpan $1) ValStar } | '&' { ExpValue () (getSpan $1) ValStar }@@ -965,7 +914,6 @@ -- this stage. -- This at least reduces reduce/reduce conflicts. VARIABLE :: { Expression A0 }-VARIABLE : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }  INTEGER_LITERAL :: { Expression A0 }@@ -973,42 +921,35 @@ | boz { let TBozInt s i = $1 in ExpValue () s $ ValInteger i }  REAL_LITERAL :: { Expression A0 }-REAL_LITERAL : int EXPONENT { makeReal (Just $1) Nothing Nothing (Just $2) } | int '.' MAYBE_EXPONENT { makeReal (Just $1) (Just $2) Nothing $3 } | '.' int MAYBE_EXPONENT { makeReal Nothing (Just $1) (Just $2) $3 } | int '.' int MAYBE_EXPONENT { makeReal (Just $1) (Just $2) (Just $3) $4 }  MAYBE_EXPONENT :: { Maybe (SrcSpan, String) }-MAYBE_EXPONENT : EXPONENT { Just $1 } | {-EMPTY-} { Nothing }  EXPONENT :: { (SrcSpan, String) }-EXPONENT : exponent { let (TExponent s exp) = $1 in (s, exp) }  SIGNED_NUMERIC_LITERAL :: { Expression A0 }-SIGNED_NUMERIC_LITERAL : ARITHMETIC_SIGN NUMERIC_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) Minus $2 } | NUMERIC_LITERAL { $1 }  NUMERIC_LITERAL :: { Expression A0 }-NUMERIC_LITERAL : INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }  LOGICAL_LITERAL :: { Expression A0 }-LOGICAL_LITERAL : bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }  HOLLERITH :: { Expression A0 } : hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }  LABELS_IN_STATEMENT :: { AList Expression A0 }-LABELS_IN_STATEMENT : LABELS_IN_STATEMENT_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }  LABELS_IN_STATEMENT_LEVEL1 :: { AList Expression A0 }-LABELS_IN_STATEMENT_LEVEL1 : LABELS_IN_STATEMENT_LEVEL1 ',' LABEL_IN_STATEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] } @@ -1019,7 +960,6 @@ LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l) }  TYPE_SPEC :: { TypeSpec A0 }-TYPE_SPEC : integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 } | real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  } | doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing}@@ -1031,33 +971,25 @@ | record    '/' NAME '/'  { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }  KIND_SELECTOR :: { Maybe (Selector A0) }-KIND_SELECTOR-: KIND_SELECTOR1-  { Just $1 }-| {- EMPTY -}-  { Nothing }+: KIND_SELECTOR1 { Just $1 }+| {- EMPTY -}    { Nothing }  KIND_SELECTOR1 :: { Selector A0 }-KIND_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION   { Selector () (getTransSpan $1 $2) Nothing (Just $2) } | '*' '(' STAR ')' { Selector () (getTransSpan $1 $4) Nothing (Just $3) }  CHAR_SELECTOR :: { Maybe (Selector A0) }-: CHAR_SELECTOR1-  { Just $1 }-| {- EMPTY -}-  { Nothing }+: CHAR_SELECTOR1 { Just $1 }+| {- EMPTY -}    { Nothing }  CHAR_SELECTOR1 :: { Selector A0 }-CHAR_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION   { Selector () (getTransSpan $1 $2) (Just $2) Nothing } | '*' '(' STAR ')'   { Selector () (getTransSpan $1 $4) (Just $3) Nothing }  IMP_TYPE_SPEC :: { TypeSpec A0 }-IMP_TYPE_SPEC : TYPE_SPEC  { $1 }  STAR :: { Expression A0 }@@ -1194,8 +1126,8 @@       case M.lookup path incMap of         Just blocks' -> pure $ StInclude a s e (Just blocks')         Nothing -> do-          inc <- liftIO $ readInDirs dirs path-          case includeParser fv inc path of+          (fullPath, inc) <- liftIO $ readInDirs dirs path+          case includeParser fv inc fullPath of             ParseOk blocks _ -> do               blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks               modify (M.insert path blocks')@@ -1204,12 +1136,13 @@     else return st   _ -> return st -readInDirs :: [String] -> String -> IO B.ByteString+readInDirs :: [String] -> String -> IO (String, B.ByteString) readInDirs [] f = fail $ "cannot find file: " ++ f readInDirs (d:ds) f = do-  b <- doesFileExist (d</>f)+  let path = d</>f+  b <- doesFileExist path   if b then-    B.readFile (d</>f)+    (path,) <$> B.readFile path   else     readInDirs ds f 

@@ -2,6 +2,7 @@ { module Language.Fortran.Parser.Fortran90 ( statementParser                                          , functionParser+                                         , blockParser                                          , fortran90Parser                                          , fortran90ParserWithTransforms                                          , fortran90ParserWithModFiles@@ -33,6 +34,7 @@ %name programParser PROGRAM %name functionParser SUBPROGRAM_UNIT %name statementParser STATEMENT+%name blockParser BLOCK %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token }@@ -206,6 +208,10 @@  %% +maybe(p)+: p           { Just $1 }+| {- empty -} { Nothing }+ -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 } : NEWLINE PROGRAM_INNER { $2 }@@ -299,7 +305,9 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE@@ -308,6 +316,89 @@   { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) } | COMMENT_BLOCK { $1 } +IF_BLOCK :: { Block A0 }+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          (endSpan, conds, blocks, endLabel) = $9;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { TId startSpan startName = $1;+          (endSpan, conds, blocks, endLabel) = $11;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          (endSpan, conds, blocks, endLabel) = $10;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          TId _ startName = $2;+          (endSpan, conds, blocks, endLabel) = $12;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }++ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let (endSpan, conds, blocks, endLabel) = $10+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF+  { let (endSpan, endLabel) = $6+    in (endSpan, [Nothing], [reverse $5], endLabel) }+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }++END_IF :: { (SrcSpan, Maybe (Expression A0)) }+: endif { (getSpan $1, Nothing) }+| endif id { (getSpan $2, Nothing) }+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }++CASE_BLOCK :: { Block A0 }+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+          span = getTransSpan $1 endSpan }+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+          span = getTransSpan $1 endSpan }+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+          TId s startName = $1;+          span = getTransSpan s endSpan }+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+          TId s startName = $2;+          span = getTransSpan s endSpan }+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }++-- We store line comments as statements, but this raises an issue: we have+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop+-- them. The inner CASES_ rule does /not/ use this, because comments can always+-- be parsed as belonging to to the above CASE block.+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: COMMENT_BLOCK CASES_ { $2 }+|               CASES_ { $1 }++CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_+  { let (scrutinees, blocks, endLabel, endSpan) = $9+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT+  { let (endLabel, endSpan) = $7+    in ([Nothing], [$6], endLabel, endSpan) }+| END_SELECT+  { let (endLabel, endSpan) = $1+    in ([], [], endLabel, endSpan) }++END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) endselect maybe(id)+  { ($1, maybe (getSpan $2) getSpan $3) }+ MAYBE_EXPRESSION :: { Maybe (Expression A0) } : EXPRESSION { Just $1 } | {- EMPTY -} { Nothing }@@ -368,16 +459,16 @@   { let saveAList = (fromReverseList $3)     in StSave () (getTransSpan $1 saveAList) (Just saveAList) } | save { StSave () (getSpan $1) Nothing }-| dimension MAYBE_DCOLON DECLARATOR_LIST+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StDimension () (getTransSpan $1 declAList) declAList }-| allocatable MAYBE_DCOLON DECLARATOR_LIST+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StAllocatable () (getTransSpan $1 declAList) declAList }-| pointer MAYBE_DCOLON DECLARATOR_LIST+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StPointer () (getTransSpan $1 declAList) declAList }-| target MAYBE_DCOLON DECLARATOR_LIST+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StTarget () (getTransSpan $1 declAList) declAList } | data cDATA DATA_GROUPS cPOP@@ -450,16 +541,6 @@ | endwhere { StEndWhere () (getSpan $1) Nothing } | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }-| id ':' if '(' EXPRESSION ')' then-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }-| elsif '(' EXPRESSION ')' then id-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }-| else { StElse () (getSpan $1) Nothing }-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }-| endif { StEndif () (getSpan $1) Nothing }-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) } | do { StDo () (getSpan $1) Nothing Nothing Nothing } | id ':' do   { let TId s id = $1@@ -501,21 +582,6 @@ | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) } | pause { StPause () (getSpan $1) Nothing } | pause EXPRESSION { StPause () (getTransSpan $1 $2) (Just $2) }-| selectcase '(' EXPRESSION ')'-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }-| id ':' selectcase '(' EXPRESSION ')'-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }-| case default id-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }-| case '(' INDICIES ')'-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }-| case '(' INDICIES ')' id-  { let TId s id = $5-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }-| endselect { StEndcase () (getSpan $1) Nothing }-| endselect id-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT   { StIfLogical () (getTransSpan $1 $5) $3 $5 } | read CILIST IN_IOLIST@@ -686,21 +752,21 @@ | INIT_COMMON_GROUP { [ $1 ] }  COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }  INIT_COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }-| PART_REFS+| UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $1     in CommonGroup () (getSpan alist) Nothing alist } @@ -762,11 +828,11 @@   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }  DECLARATION_STATEMENT :: { Statement A0 }-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;           declAList = fromReverseList $4 }     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }-| TYPE_SPEC DECLARATOR_LIST+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST   { let { declAList = fromReverseList $2 }     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } @@ -818,11 +884,15 @@ COMMON_NAME :: { Expression A0 } : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 } -DECLARATOR_LIST :: { [ Declarator A0 ] }-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }-| INITIALISED_DECLARATOR { [ $1 ] }+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }+| INITIALIZED_DECLARATOR { [ $1 ] } -INITIALISED_DECLARATOR :: { Declarator A0 }+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }+| DECLARATOR { [ $1 ] }++INITIALIZED_DECLARATOR :: { Declarator A0 } : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR { $1 }

@@ -1,6 +1,7 @@ -- -*- Mode: Haskell -*- { module Language.Fortran.Parser.Fortran95 ( functionParser+                                         , blockParser                                          , statementParser                                          , fortran95Parser                                          , fortran95ParserWithTransforms@@ -33,6 +34,7 @@ }  %name programParser PROGRAM+%name blockParser BLOCK %name statementParser STATEMENT %name functionParser SUBPROGRAM_UNIT %monad { LexAction }@@ -211,6 +213,10 @@  %% +maybe(p)+: p           { Just $1 }+| {- empty -} { Nothing }+ -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 } : NEWLINE PROGRAM_INNER { $2 }@@ -310,7 +316,9 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE@@ -319,6 +327,93 @@   { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) } | COMMENT_BLOCK { $1 } +IF_BLOCK :: { Block A0 }+IF_BLOCK+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          (endSpan, conds, blocks, endLabel) = $9;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { TId startSpan startName = $1;+          (endSpan, conds, blocks, endLabel) = $11;+          span = getTransSpan startSpan endSpan }+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          (endSpan, conds, blocks, endLabel) = $10;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let { startSpan = getSpan $1;+          startLabel = Just $1;+          TId _ startName = $2;+          (endSpan, conds, blocks, endLabel) = $12;+          span = getTransSpan startSpan endSpan }+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }++ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+ELSE_BLOCKS+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS+  { let (endSpan, conds, blocks, endLabel) = $10+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF+  { let (endSpan, endLabel) = $6+    in (endSpan, [Nothing], [reverse $5], endLabel) }+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }++END_IF :: { (SrcSpan, Maybe (Expression A0)) }+END_IF+: endif { (getSpan $1, Nothing) }+| endif id { (getSpan $2, Nothing) }+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }++CASE_BLOCK :: { Block A0 }+CASE_BLOCK+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+          span = getTransSpan $1 endSpan }+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+          span = getTransSpan $1 endSpan }+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+          TId s startName = $1;+          span = getTransSpan s endSpan }+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+          TId s startName = $2;+          span = getTransSpan s endSpan }+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }++-- We store line comments as statements, but this raises an issue: we have+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop+-- them. The inner CASES_ rule does /not/ use this, because comments can always+-- be parsed as belonging to to the above CASE block.+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: COMMENT_BLOCK CASES_ { $2 }+|               CASES_ { $1 }++CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_+  { let (scrutinees, blocks, endLabel, endSpan) = $9+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT+  { let (endLabel, endSpan) = $7+    in ([Nothing], [$6], endLabel, endSpan) }+| END_SELECT+  { let (endLabel, endSpan) = $1+    in ([], [], endLabel, endSpan) }++END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+: maybe(INTEGER_LITERAL) endselect maybe(id)+  { ($1, maybe (getSpan $2) getSpan $3) }+ MAYBE_EXPRESSION :: { Maybe (Expression A0) } : EXPRESSION { Just $1 } | {- EMPTY -} { Nothing }@@ -379,22 +474,22 @@   { let saveAList = (fromReverseList $3)     in StSave () (getTransSpan $1 saveAList) (Just saveAList) } | save { StSave () (getSpan $1) Nothing }-| dimension MAYBE_DCOLON DECLARATOR_LIST+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StDimension () (getTransSpan $1 declAList) declAList }-| allocatable MAYBE_DCOLON DECLARATOR_LIST+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StAllocatable () (getTransSpan $1 declAList) declAList }-| pointer MAYBE_DCOLON DECLARATOR_LIST+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StPointer () (getTransSpan $1 declAList) declAList }-| target MAYBE_DCOLON DECLARATOR_LIST+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StTarget () (getTransSpan $1 declAList) declAList }-| value MAYBE_DCOLON DECLARATOR_LIST+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StValue () (getTransSpan $1 declAList) declAList }-| volatile MAYBE_DCOLON DECLARATOR_LIST+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StVolatile () (getTransSpan $1 declAList) declAList } | data cDATA DATA_GROUPS cPOP@@ -467,16 +562,6 @@ | endwhere { StEndWhere () (getSpan $1) Nothing } | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }-| id ':' if '(' EXPRESSION ')' then-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }-| elsif '(' EXPRESSION ')' then id-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }-| else { StElse () (getSpan $1) Nothing }-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }-| endif { StEndif () (getSpan $1) Nothing }-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) } | do { StDo () (getSpan $1) Nothing Nothing Nothing } | id ':' do   { let TId s id = $1@@ -509,21 +594,6 @@ | continue { StContinue () (getSpan $1) } | stop { StStop () (getSpan $1) Nothing } | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }-| selectcase '(' EXPRESSION ')'-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }-| id ':' selectcase '(' EXPRESSION ')'-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }-| case default id-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }-| case '(' INDICIES ')'-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }-| case '(' INDICIES ')' id-  { let TId s id = $5-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }-| endselect { StEndcase () (getSpan $1) Nothing }-| endselect id-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT   { StIfLogical () (getTransSpan $1 $5) $3 $5 } | read CILIST IN_IOLIST@@ -697,21 +767,21 @@ | INIT_COMMON_GROUP { [ $1 ] }  COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }  INIT_COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $2     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS+| '/' '/' UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $3     in CommonGroup () (getTransSpan $1 alist) Nothing alist }-| PART_REFS+| UNINITIALIZED_DECLARATOR_LIST   { let alist = fromReverseList $1     in CommonGroup () (getSpan alist) Nothing alist } @@ -773,11 +843,11 @@   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }  DECLARATION_STATEMENT :: { Statement A0 }-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;           declAList = fromReverseList $4 }     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }-| TYPE_SPEC DECLARATOR_LIST+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST   { let { declAList = fromReverseList $2 }     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } @@ -831,11 +901,15 @@ COMMON_NAME :: { Expression A0 } : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 } -DECLARATOR_LIST :: { [ Declarator A0 ] }-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }-| INITIALISED_DECLARATOR { [ $1 ] }+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }+| INITIALIZED_DECLARATOR { [ $1 ] } -INITIALISED_DECLARATOR :: { Declarator A0 }+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }+| DECLARATOR { [ $1 ] }++INITIALIZED_DECLARATOR :: { Declarator A0 } : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 } | DECLARATOR { $1 }

@@ -22,6 +22,18 @@     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+olderThan verMax featureName ver cont =+    if   ver > verMax+    then error $+            featureName+            ++ " is only available in " ++ show verMax+            ++ " or before. You called pretty print with "+            ++ show ver ++ "."+    else cont+ (<?>) :: Doc -> Doc -> Doc doc1 <?> doc2 = if doc1 == empty || doc2 == empty then empty else doc1 <> doc2 infixl 7 <?>@@ -327,6 +339,23 @@             then indent i (pprint' v label <+> stDoc)             else pprint' v mLabel `overlay` indent i stDoc +    -- Note that binary expressions such as @a*b@ will always be wrapped in+    -- brackets. It appears to be built into 'Expression''s 'Pretty' instance.+    pprint v (BlAssociate _ _ mLabel mName abbrevs bodies mEndLabel) i+      | v >= Fortran2003 =+        labeledIndent mLabel+          $  pprint' v mName <?> colon+                <+> ("associate" <+> "(" <> pprint' v abbrevs <> ")" <> newline)+          <> pprint v bodies nextI+          <> labeledIndent mEndLabel ("end associate" <+> pprint' v mName <> newline)+      | otherwise = tooOld v "Associate block" Fortran2003+      where+        nextI = incIndentation i+        labeledIndent label stDoc =+          if v >= Fortran90+            then indent i (pprint' v label <+> stDoc)+            else pprint' v mLabel `overlay` indent i stDoc+     pprint v (BlComment _ _ (Comment comment)) i       | v >= Fortran90 = indent i (char '!' <> text comment <> newline)       | otherwise = char 'c' <> text comment <> newline@@ -344,6 +373,9 @@ instance Pretty (e a) => Pretty (AList e a) where     pprint' v es = commaSep (map (pprint' v) (aStrip es)) +instance (Pretty (t1 a), Pretty (t2 a)) => Pretty (ATuple t1 t2 a) where+    pprint' v (ATuple _ _ t1 t2) = pprint' v t1 <+> "=>" <+> pprint' v t2+ instance Pretty BaseType where     pprint' _ TypeInteger = "integer"     pprint' _ TypeReal    = "real"@@ -412,12 +444,13 @@           pprint' v declList       | otherwise = error "unhandled version" -    pprint' v (StStructure _ _ mName itemList)-      | v /= Fortran77Extended = tooOld v "Structure" Fortran77Extended-      | otherwise =-          "structure" <> (if isJust mName then " /" <> pprint' v mName <> "/" else empty) <> newline <>-          foldl' (\doc item -> doc <> pprint v item (incIndentation (Just 0)) <> newline) empty (aStrip itemList) <>-          "end structure"+    pprint' v (StStructure _ _ mName itemList) =+        olderThan Fortran77Legacy "Structure" v $+          "structure"+          <+> (if isJust mName then "/" <> pprint' v mName <> "/" else empty)+          <> newline+          <> foldl' (\doc item -> doc <> pprint v item (incIndentation (Just 0)) <> newline) empty (aStrip itemList)+          <> "end structure"      pprint' v (StIntent _ _ intent exps)       | v >= Fortran90 =@@ -562,41 +595,6 @@       pprint' v eqPred <> comma <+>       pprint' v gtPred -    pprint' v (StIfThen _ _ mConstructor condition)-      | v >= Fortran90 =-        pprint' v mConstructor <?> colon <+>-        "if" <+> parens (pprint' v condition) <+> "then"-      | v >= Fortran77Extended =-        case mConstructor of-          Nothing -> "if" <+> parens (pprint' v condition) <+> "then"-          _ -> tooOld v "Else" Fortran77Extended-      | otherwise = tooOld v "Structured if" Fortran90--    pprint' v (StElse _ _ mConstructor)-      | v >= Fortran90 = "else" <+> pprint' v mConstructor-      | v >= Fortran77Extended =-        case mConstructor of-          Nothing -> "else"-          Just _ -> tooOld v "Named else" Fortran90-      | otherwise = tooOld v "Else" Fortran77Extended--    pprint' v (StElsif _ _ mConstructor condition)-      | v >= Fortran90 =-        "else if" <+> parens (pprint' v condition) <+> pprint' v mConstructor-      | v >= Fortran77Extended =-        case mConstructor of-          Nothing -> "else if" <+> parens (pprint' v condition)-          _ -> tooOld v "Named else if" Fortran90-      | otherwise = tooOld v "Else if" Fortran77Extended--    pprint' v (StEndif _ _ mConstructor)-      | v >= Fortran90 = "end if" <+> pprint' v mConstructor-      | v >= Fortran77Extended =-        case mConstructor of-          Nothing -> "end if"-          Just _ -> tooOld v "Named end if" Fortran90-      | otherwise = tooOld v "End if" Fortran77Extended-     pprint' v (StSelectCase _ _ mConstructor exp)       | v >= Fortran90 =         pprint' v mConstructor <?> colon <+>@@ -900,7 +898,7 @@  instance Pretty (CommonGroup a) where     pprint' v (CommonGroup _ _ mName elems) =-      char '/' <> pprint' v mName <> char '/' <> pprint' v elems+      char '/' <> pprint' v mName <> char '/' <+> pprint' v elems  instance Pretty (Namelist a) where     pprint' Fortran90 (Namelist _ _ name elems) =

@@ -1,8 +1,6 @@ module Language.Fortran.Transformation.Grouping ( groupForall-                                                , groupIf                                                 , groupDo                                                 , groupLabeledDo-                                                , groupCase                                                 ) where  import Language.Fortran.AST@@ -72,115 +70,7 @@ isForall (StForallStatement{}) = True isForall _ = False ------------------------------------------------------------------------------------ Grouping if statement blocks into if blocks in entire parse tree--------------------------------------------------------------------------------- -groupIf :: Data a => Transform a ()-groupIf = genericGroup groupIf' isIf---- Actual grouping is done here.--- 1. Case: head is a statement block with an IF statement:--- 1.1  Group everything to the right of the statement.--- 1.2  Prepend the head--- 1.3  Decompose into if components (blocks and condition pairs).--- 1.4  Using original if statement and decomposition artefacts synthesise a---        structured if block.--- 1.5  Prepend the block to the left over artefacts, which have already been---        grouped in 1.1--- 2. Case: head is a statement block containing any other statement:--- 2.1  Group everything to the right and prepend the head.-groupIf' :: ABlocks a -> ABlocks a-groupIf' [] = []-groupIf' (b:bs) = b' : bs'-  where-    (b', bs') = case b of-      BlStatement a s label st-        | StIfThen _ _ mName _ <- st -> -- If statement-          let ( conditions, blocks, leftOverBlocks, endLabel, endStmt ) =-                decomposeIf (b:groupedBlocks)-          in ( BlIf a (getTransSpan s endStmt) label mName conditions blocks endLabel-             , leftOverBlocks)-      b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks-        ( applyGroupingToSubblocks groupIf' b'', groupedBlocks )-      _ -> ( b, groupedBlocks )-    groupedBlocks = groupIf' bs -- Assume everything to the right is grouped.---- A program has the following structure:------[ block... ]--- if <condition> then---   [ block... ]--- else if <condition>---   [ block... ]--- else---   [ block... ]--- end if--- [ block... ]------ This function must only receive a list of blocks that start with if.------ Internally it uses a more permissive breaking function that processes--- individual (if-then, block), (else-if, block), and (else, block) pairs.------ In that case it decomposes the block into list of (maybe) conditions and--- blocks that those conditions correspond to. Additionally, it returns--- whatever is after the if block.-decomposeIf :: ABlocks a-            -> ( [ Maybe (Expression (Analysis a)) ],-                 [ ABlocks a ],-                 ABlocks a,-                 Maybe (Expression (Analysis a)),-                 Statement (Analysis a) )-decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):_) =-    decomposeIf' blocks-  where-    decomposeIf' (BlStatement _ _ mLabel st:rest) =-      case st of-        StIfThen _ _ _ condition -> go (Just condition) rest-        StElsif _ _ _ condition -> go (Just condition) rest-        StElse{} -> go Nothing rest-        StEndif _ _ mName-          | mName == mTargetName -> ([], [], rest, mLabel, st)-          | otherwise -> error $ "If statement name does not match that of " ++-                                   "the corresponding end if statement."-        _ -> error "Block with non-if related statement. Should never occur."-    decomposeIf' _ = error "can't decompose block"-    go maybeCondition blocks' =-      let (nonConditionBlocks, rest') = collectNonConditionalBlocks blocks'-          (conditions, listOfBlocks, rest'', endLabel, endStmt) = decomposeIf' rest'-      in ( maybeCondition : conditions-         , nonConditionBlocks : listOfBlocks-         , rest''-         , endLabel-         , endStmt )-decomposeIf _ = error "can't decompose block"---- This compiles the executable blocks under various if conditions.-collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a)-collectNonConditionalBlocks blocks =-  case blocks of-    BlStatement _ _ _ StElsif{}:_ -> ([], blocks)-    BlStatement _ _ _ StElse{}:_ -> ([], blocks)-    -- Here end block is included within the blocks unlike the other-    -- conditional directives. The reason is that this block can be-    -- a branch target if it is labeled according to the specification, hence-    -- it is presence in the parse tree is meaningful.-    BlStatement _ _ _ StEndif{}:_ -> ([], blocks)-    -- Catch all case for all non-if related blocks.-    b:bs -> let (bs', rest) = collectNonConditionalBlocks bs in (b : bs', rest)-    -- In this case the structured if block is malformed and the file ends-    -- prematurely.-    _ -> error "Premature file ending while parsing structured if block."--isIf :: Statement a -> Bool-isIf s = case s of-  StIfThen{} -> True-  StElsif{}  -> True-  StElse{}   -> True-  StEndif{}  -> True-  _          -> False- -------------------------------------------------------------------------------- -- Grouping new do statement blocks into do blocks in entire parse tree --------------------------------------------------------------------------------@@ -296,74 +186,6 @@   _                         -> False  ----------------------------------------------------------------------------------- Grouping case statements-----------------------------------------------------------------------------------groupCase :: Data a => Transform a ()-groupCase = genericGroup groupCase' isCase--groupCase' :: ABlocks a -> ABlocks a-groupCase' [] = []-groupCase' (b:bs) = b' : bs'-  where-    (b', bs') = case b of-      BlStatement a s label st-        | StSelectCase _ _ mName scrutinee <- st ->-          let blocksToDecomp = dropWhile isComment groupedBlocks-              ( conds, blocks, leftOverBlocks, endLabel ) = decomposeCase blocksToDecomp mName-          in ( BlCase a (getTransSpan s blocks) label mName scrutinee conds blocks endLabel-             , leftOverBlocks)-      b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks-        ( applyGroupingToSubblocks groupCase' b'', groupedBlocks )-      _ -> ( b , groupedBlocks )-    groupedBlocks = groupCase' bs -- Assume everything to the right is grouped.-    isComment b'' = case b'' of { BlComment{} -> True; _ -> False }--decomposeCase :: ABlocks a -> Maybe String-              -> ( [ Maybe (AList Index (Analysis a)) ]-                 , [ ABlocks a ]-                 , ABlocks a-                 , Maybe (Expression (Analysis a)) )-decomposeCase (BlStatement _ _ mLabel st:rest) mTargetName =-    case st of-      StCase _ _ mName mCondition-        | Nothing <- mName -> go mCondition rest-        | mName == mTargetName -> go mCondition rest-        | otherwise -> error $ "Case name does not match that of " ++-                                 "the corresponding select case statement."-      StEndcase _ _ mName-        | mName == mTargetName -> ([], [], rest, mLabel)-        | otherwise -> error $ "End case name does not match that of " ++-                                 "the corresponding select case statement."-      _ -> error "Block with non-case related statement. Must not occur."-  where-    go mCondition blocks =-      let (nonCaseBlocks, rest') = collectNonCaseBlocks blocks-          (conditions, listOfBlocks, rest'', endLabel) = decomposeCase rest' mTargetName-      in ( mCondition : conditions-         , nonCaseBlocks : listOfBlocks-         , rest'', endLabel )-decomposeCase _ _ = error "can't decompose case"---- This compiles the executable blocks under various if conditions.-collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a)-collectNonCaseBlocks blocks =-  case blocks of-    BlStatement _ _ _ st:_-      | StCase{} <- st -> ( [], blocks )-      | StEndcase{} <- st -> ( [], blocks )-    -- In this case case block is malformed and the file ends prematurely.-    b:bs -> let (bs', rest) = collectNonCaseBlocks bs in (b : bs', rest)-    _ -> error "Premature file ending while parsing select case block."--isCase :: Statement a -> Bool-isCase s = case s of-  StCase{}       -> True-  StEndcase{}    -> True-  StSelectCase{} -> True-  _              -> False---------------------------------------------------------------------------------- -- Helpers for grouping of structured blocks with more blocks inside. -------------------------------------------------------------------------------- @@ -371,29 +193,35 @@ containsGroups b =   case b of     BlStatement{} -> False-    BlIf{} -> True-    BlCase{} -> True-    BlDo{} -> True-    BlDoWhile{} -> True+    BlIf{}        -> True+    BlCase{}      -> True+    BlDo{}        -> True+    BlDoWhile{}   -> True     BlInterface{} -> False-    BlComment{} -> False-    BlForall{}  -> True+    BlComment{}   -> False+    BlForall{}    -> True+    BlAssociate{} -> True  applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a) applyGroupingToSubblocks f b   | BlStatement{} <- b =       error "Individual statements do not have subblocks. Must not occur."-  | BlIf a s l mn conds blocks el <- b = BlIf a s l mn conds (map f blocks) el-  | BlCase a s l mn scrutinee conds blocks el <- b =-      BlCase a s l mn scrutinee conds (map f blocks) el-  | BlDo a s l n tl doSpec blocks el <- b = BlDo a s l n tl doSpec (f blocks) el-  | BlDoWhile a s l n tl doSpec blocks el <- b = BlDoWhile a s l n tl doSpec (f blocks) el+  | BlIf a s l mn conds blocks         el <- b =+    BlIf a s l mn conds (map f blocks) el+  | BlCase a s l mn scrutinee conds blocks         el <- b =+    BlCase a s l mn scrutinee conds (map f blocks) el+  | BlDo a s l n tl doSpec blocks     el <- b =+    BlDo a s l n tl doSpec (f blocks) el+  | BlDoWhile a s l n tl doSpec blocks     el <- b =+    BlDoWhile a s l n tl doSpec (f blocks) el   | BlInterface{} <- b =       error "Interface blocks do not have groupable subblocks. Must not occur."   | BlComment{} <- b =       error "Comment statements do not have subblocks. Must not occur."   | BlForall a s ml mn h blocks mel <- b =-     BlForall a s ml mn h (f blocks) mel+    BlForall a s ml mn h (f blocks) mel+  | BlAssociate a s ml mn abbrevs blocks     mel <- b =+    BlAssociate a s ml mn abbrevs (f blocks) mel  -------------------------------------------------- 

@@ -20,8 +20,6 @@  data Transformation =     GroupForall-  | GroupIf-  | GroupCase   | GroupDo   | GroupLabeledDo   | DisambiguateFunction@@ -31,8 +29,6 @@ transformationMapping :: Data a => Transformation -> Transform a () transformationMapping = \case   GroupForall           -> groupForall-  GroupIf               -> groupIf-  GroupCase             -> groupCase   GroupDo               -> groupDo   GroupLabeledDo        -> groupLabeledDo   DisambiguateFunction  -> disambiguateFunction@@ -49,6 +45,10 @@     trans = mapM_ transformationMapping trs  -- | The default post-parse AST transformations for each Fortran version.+--+-- Note that some of these may not be commutative with each other. Specifically,+-- the DO groupings are written so labeled (nonblock) DO grouping must occur+-- first, followed by block DO grouping. defaultTransformations :: FortranVersion -> [Transformation] defaultTransformations = \case   Fortran66 ->@@ -56,9 +56,14 @@     , DisambiguateIntrinsic     , DisambiguateFunction     ]-  Fortran77         -> GroupIf   : defaultTransformations Fortran66-  Fortran77Legacy   -> GroupDo   : defaultTransformations Fortran77-  Fortran77Extended -> GroupCase : defaultTransformations Fortran77Legacy+  Fortran77         -> defaultTransformations Fortran66+  Fortran77Legacy   ->+    [ GroupLabeledDo+    , GroupDo+    , DisambiguateIntrinsic+    , DisambiguateFunction+    ]+  Fortran77Extended -> defaultTransformations Fortran77Legacy   Fortran90   -> defaultTransformations Fortran77Extended   Fortran95   -> defaultTransformations Fortran77Extended   Fortran2003 -> defaultTransformations Fortran77Extended

@@ -19,6 +19,10 @@ import Control.DeepSeq (NFData) import Text.PrettyPrint.GenericPretty (Out) +-- | The Fortran specification version used (or relevant to its context).+--+-- 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

@@ -330,7 +330,7 @@ showTypes tenv =     flip concatMap (M.toList tenv) $       \ (name, IDType { idVType = vt, idCType = ct }) ->-        printf "%s\t\t%s %s\n" name (drop 3 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct)+        printf "%s\t\t%s %s\n" name (drop 1 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct) printTypes :: TypeEnv -> IO () printTypes = putStrLn . showTypes showTypeErrors :: [TypeError] -> String

@@ -12,6 +12,7 @@ import Language.Fortran.Analysis.Types import Language.Fortran.Analysis.SemanticTypes import Language.Fortran.Analysis.Renaming+import qualified Language.Fortran.Parser.Fortran77 as F77 import qualified Language.Fortran.Parser.Fortran90 as F90 import Language.Fortran.ParserMonad import qualified Data.ByteString.Char8 as B@@ -22,6 +23,9 @@ typedProgramFile :: Data a => ProgramFile a -> ProgramFile (Analysis a) typedProgramFile = fst . analyseTypes . analyseRenames . initAnalysis +legacy77Parser :: String -> String -> ProgramFile A0+legacy77Parser src file = fromParseResultUnsafe $ F77.legacy77Parser (B.pack src) file+ fortran90Parser :: String -> String -> ProgramFile A0 fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file @@ -148,6 +152,29 @@                                         (Just (CTArray [(Nothing, Just 20)])))]           `shouldNotSatisfy` null +    describe "structs and arrays" $ do+      it "can handle typing assignments to arrays within structs" $ do+        let mapping = inferTable $ structArray False+        mapping ! "s" `shouldBe` IDType (Just $ TCustom "strut") (Just CTVariable)+      it "can handle typing assignments to elements in arrays of structs" $ do+        let mapping = inferTable $ arrayOfStructs False+        mapping ! "a" `shouldBe` IDType (Just $ TCustom "elem") (Just $ CTArray [(Nothing, Just 10)])+      it "can handle typing assignments to array elements in arrays of structs" $ do+        let mapping = inferTable $ arrayOfStructsWithArrays False+        mapping ! "arr" `shouldBe` IDType (Just $ TCustom "elem2") (Just $ CTArray [(Nothing, Just 10)])++    describe "structs and arrays in common area" $ do+      it "can handle typing assignments to arrays within structs in common area" $ do+        let mapping = inferTable $ structArray True+        mapping ! "s" `shouldBe` IDType (Just $ TCustom "strut") (Just CTVariable)+      it "can handle typing assignments to elements in arrays of structs in common area" $ do+        let mapping = inferTable $ arrayOfStructs True+        mapping ! "a" `shouldBe` IDType (Just $ TCustom "elem") (Just $ CTArray [(Nothing, Just 10)])+      it "can handle typing assignments to array elements in arrays of structs in common area" $ do+        let mapping = inferTable $ arrayOfStructsWithArrays True+        mapping ! "arr" `shouldBe` IDType (Just $ TCustom "elem2") (Just $ CTArray [(Nothing, Just 10)])++ ex1 :: ProgramFile () ex1 = ProgramFile mi77 [ ex1pu1 ] ex1pu1 :: ProgramUnit ()@@ -305,6 +332,66 @@   , "  character(kind=2) :: f"   , "end program teststrings"   ]++commonTransform :: [String] -> String -> [String] -> Bool -> ProgramFile A0+commonTransform front cdecl back common =+  resetSrcSpan . flip legacy77Parser "" . unlines . (++) front $+    if common then cdecl : back else back++structArray :: Bool -> ProgramFile A0+structArray = commonTransform front cdecl back+  where+    front = [+        "      subroutine totes"+      , "       structure /strut/"+      , "         integer*4 arr(10)"+      , "       end structure"+      , "       record /strut/ s"+      ]+    cdecl =+        "       common /comm/ s"+    back = [+        "       s.arr(7) = 345"+      , "       print *, 'eyo'"+      , "      end subroutine totes"+      ]++arrayOfStructs :: Bool -> ProgramFile A0+arrayOfStructs = commonTransform front cdecl back+  where+    front = [+        "      subroutine totes"+      , "       structure /elem/"+      , "         integer val"+      , "       end structure"+      , "       record /elem/ a(10)"+      ]+    cdecl =+        "       common /comm2/ a"+    back = [+        "       a(7).val = 345"+      , "       print *, 'done'"+      , "      end subroutine totes"+      ]++arrayOfStructsWithArrays :: Bool -> ProgramFile A0+arrayOfStructsWithArrays = commonTransform front cdecl back+  where+    front = [+        "      subroutine totes"+      , "       structure /elem2/"+      , "         integer vals(4)"+      , "       end structure"+      , "       record /elem2/ arr(10)"+      ]+    cdecl =+        "       common /comm3/ arr"+    back = [+        "       arr(7).vals(2) = 45"+      , "       print *, 'DONE'"+      , "      end subroutine totes"+      ]+  -- Local variables: -- mode: haskell

@@ -21,14 +21,19 @@     paddedSourceCode = B.pack $ "      a = " ++ sourceCode     parseState =  initParseState paddedSourceCode Fortran2003 "<unknown>" +simpleParser :: Parse AlexInput Token a -> String -> a+simpleParser p sourceCode =+  evalParse p $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"+ sParser :: String -> Statement ()-sParser sourceCode =-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"+sParser = simpleParser statementParser  fParser :: String -> ProgramUnit ()-fParser sourceCode =-  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"+fParser = simpleParser functionParser +bParser :: String -> Block ()+bParser = simpleParser blockParser+ spec :: Spec spec =   describe "Fortran 2003 Parser" $ do@@ -141,16 +146,32 @@         sParser "real, protected, public :: x" `shouldBe'` st1         sParser "protected x" `shouldBe'` st2 -      describe "labelled where" $ do-        it "parses where construct statement" $-          sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue+    describe "labelled where" $ do+      it "parses where construct statement" $+        sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue -        it "parses elsewhere statement" $-          sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing+      it "parses elsewhere statement" $+        sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing -        it "parses elsewhere statement" $ do-          let exp = ExpBinary () u GT (varGen "a") (varGen "b")-          sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)+      it "parses elsewhere statement" $ do+        let exp = ExpBinary () u GT (varGen "a") (varGen "b")+        sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp) -        it "parses endwhere statement" $-          sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")+      it "parses endwhere statement" $+        sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")++    describe "associate block" $ do+      it "parses multiple assignment associate block" $ do+        let text = unlines [ "associate (x => a, y => (a * b))"+                           , "  print *, x"+                           , "  print *, y"+                           , "end associate" ]+            expected = BlAssociate () u Nothing Nothing abbrevs body' Nothing+            body'   = [blStmtPrint "x", blStmtPrint "y"]+            blStmtPrint x = BlStatement () u Nothing (stmtPrint x)+            stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])+            abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]+            abbrev var expr = ATuple () u (expValVar var) expr+            expValVar x = ExpValue () u (ValVariable x)+            expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)+        bParser text `shouldBe'` expected

@@ -110,13 +110,13 @@         sParser "      EXTERNAL f, g, h" `shouldBe'` expectedSt        it "parses 'COMMON a, b'" $ do-        let comGr = CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ])+        let comGr = CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])         let st = StCommon () u (AList () u [ comGr ])         sParser "      COMMON a, b" `shouldBe'` st        it "parses 'COMMON // a, b /hello/ x, y, z'" $ do-        let comGrs = [ CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ])-                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ varGen "x", varGen "y", varGen "z" ]) ]+        let comGrs = [ CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])+                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ declVarGen "x", declVarGen "y", declVarGen "z" ]) ]         let st = StCommon () u (AList () u comGrs)         sParser "      COMMON // a, b /hello/ x, y, z" `shouldBe'` st 

@@ -1,5 +1,6 @@ module Language.Fortran.Parser.Fortran77.IncludeSpec where +import System.FilePath import Test.Hspec import TestUtil @@ -23,7 +24,7 @@                           "      include 'foo.f'",                           "      end"                          ]-        incs = ["./test/Language/Fortran/Parser"]+        inc = "./test/Language/Fortran/Parser"         name = "bar"         pf = ProgramFile mi77 [pu]         puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")@@ -32,10 +33,11 @@          -- the expansion returns the span in the included file         -- it should return the span at the inclusion-        st2Span = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f")-        declSpan = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f")-        typeSpan = makeSrcR (6,7,1,"foo.f") (12,13,1,"foo.f")-        blockSpan = makeSrcR (14,15,1,"foo.f") (14,15,1,"foo.f")+        foo = inc </> "foo.f"+        st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)+        declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)+        typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)+        blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)         varGen' str =  ExpValue () blockSpan $ ValVariable str          pu = PUMain () puSpan (Just name) blocks Nothing@@ -48,6 +50,6 @@         ex = ExpValue () expSpan (ValString "foo.f")         bl2 = BlStatement () declSpan Nothing st2     it "includes some files and expands them" $ do-      ps <- iParser incs source+      ps <- iParser [inc] source       let pr = fromParseResultUnsafe ps       pr `shouldBe` pf

@@ -29,6 +29,9 @@ slParser sourceCode =   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "<unknown>" +blParser :: String -> Block ()+blParser src = evalParse blockParser $ initParseState (B.pack src) Fortran77Legacy "<unknown>"+ iParser :: String -> [Block ()] iParser sourceCode =   fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "<unknown>"@@ -220,6 +223,31 @@           st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])           bl = BlStatement () u Nothing st       iParser "      integer a" `shouldBe'` [bl]++    describe "parses if blocks" $ do+      let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]+          printStmt  = StPrint () u (ExpValue () u ValStar) printArgs+          printBlock = BlStatement () u Nothing printStmt+          trueLit = ExpValue () u $ ValLogical ".true."+      it "unlabelled" $ do+        let bl = BlIf () u Nothing Nothing [ Just trueLit, Nothing ] [[printBlock], [printBlock]]  Nothing+            src = unlines [ "      if (.true.) then ! comment if"+                          , "        print *, 'foo'"+                          , "      else ! comment else"+                          , "        print *, 'foo'"+                          , "       endif ! comment end"+                          ]+        blParser src `shouldBe'` bl+      it "labelled" $ do+        let label str = Just $ ExpValue () u $ ValInteger str+            bl = BlIf () u (label "10")  Nothing [Just trueLit, Nothing] [[printBlock], [printBlock]] (label "30")+            src = unlines [ "10    if (.true.) then ! comment if"+                          , "        print *, 'foo'"+                          , "20    else ! comment else"+                          , "        print *, 'foo'"+                          , "30     endif ! comment end"+                          ]+        blParser src `shouldBe'` bl      describe "Legacy Extensions" $ do       it "parses structure/union/map blocks" $ do

@@ -27,6 +27,10 @@ sParser sourceCode =   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>" +blParser :: String -> Block ()+blParser sourceCode =+  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"+ fParser :: String -> ProgramUnit () fParser sourceCode =   evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"@@ -350,10 +354,10 @@       describe "Common" $ do         let commonNames = [ ExpValue () u (ValVariable "something")                           , ExpValue () u (ValVariable "other") ]-        let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]-                     , fromList () [ varGen "y" ] ]+        let itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]+                     , fromList () [ declVarGen "y" ] ]         let st = StCommon () u $ fromList ()-              [ CommonGroup () u Nothing (fromList () [ varGen "q" ])+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])               , CommonGroup () u (Just $ head commonNames) (head itemss)               , CommonGroup () u (Just $ last commonNames) (last itemss) ] @@ -435,21 +439,22 @@             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing      describe "If" $ do-      it "parses if-then statement" $-        sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse--      it "parses if-then statement with construct name" $ do-        let st = StIfThen () u (Just "my_if") valFalse-        sParser "my_if: if (.false.) then" `shouldBe'` st--      it "parses else statement" $-        sParser "else" `shouldBe'` StElse () u Nothing+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])+      it "parser if block" $+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]+            falseLit = ExpValue () u (ValLogical ".false.")+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing -      it "parses else-if statement" $-        sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue+      it "parses named if block" $ do+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]+            trueLit = ExpValue () u (ValLogical ".true.")+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing+        blParser ifBlockSrc `shouldBe'` ifBlock -      it "parses end if statement" $-        sParser "end if" `shouldBe'` StEndif () u Nothing+      it "parses if-else block with inline comments (stripped)" $+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]+            falseLit = ExpValue () u (ValLogical ".false.")+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing        it "parses logical if statement" $ do         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")@@ -463,24 +468,45 @@         sParser "if (x) 1, 2, 3" `shouldBe'` stIf      describe "Case" $ do-      it "parses select case statement" $ do-        let st = StSelectCase () u Nothing (varGen "n")-        sParser "select case (n)" `shouldBe'` st--      it "parses select case statement with construct name" $ do-        let st = StSelectCase () u (Just "case") (varGen "n")-        sParser "case: select case (n)" `shouldBe'` st--      it "parses case statement" $ do-        let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ]-        sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges)--      it "parses case statement" $-        sParser "case default" `shouldBe'` StCase () u Nothing Nothing--      it "parses end select statement" $ do-        let st = StEndcase () u (Just "name")-        sParser "end select name" `shouldBe'` st+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs+          printBlock = BlStatement () u Nothing . printStmt+          intLit = ExpValue () u . ValInteger+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing+          conds = [Just ind2, Just ind3Plus, Nothing]+      it "unlabelled case block (with inline comments to be stripped)" $ do+        let src = unlines [ "select case (x) ! inline select"+                          , "! full line before first case (unrepresentable)"+                          , "case (2) ! inline case 1"+                          , "print *, 'foo'"+                          , "case (3:) ! inline case 2"+                          , "print *, 'bar'"+                          , "case default ! inline case 3"+                          , "print *, 'baz'"+                          , "end select ! inline end"+                          ]+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing+        blParser src `shouldBe'` block+      it "labelled case block (with inline comments to be stripped" $ do+        let src = unlines [ "10 mylabel: select case (x) ! comment select"+                          , "20 case (2) ! inline case 1"+                          , "30 print *, 'foo'"+                          , "40 case (3:) ! inline case 2"+                          , "50 print *, 'bar'"+                          , "60 case default ! inline case 3"+                          , "70 print *, 'baz'"+                          , "80 end select mylabel ! inline end"+                          ]+            blocks = (fmap . fmap)+                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)+                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]+            block = BlCase () u+                           (Just $ intLit "10") (Just "mylabel") (varGen "x")+                           conds blocks+                           (Just $ intLit "80")+        blParser src `shouldBe'` block      describe "Do" $ do       it "parses do statement with label" $ do@@ -503,9 +529,18 @@         let st = StEnddo () u (Just "constructor")         sParser "end do constructor" `shouldBe'` st -      it "parses end do while statement" $ do+    describe "DO WHILE" $ do+      it "parses unnamed do while statement" $ do+        let st = StDoWhile () u Nothing Nothing valTrue+        sParser "do while (.true.)" `shouldBe'` st++      it "parses named do while statement" $ do         let st = StDoWhile () u (Just "name") Nothing valTrue         sParser "name: do while (.true.)" `shouldBe'` st++      it "parses unnamed labelled do while statement" $ do+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue+        sParser "do 999 while (.true.)" `shouldBe'` st      describe "Goto" $ do       it "parses vanilla goto" $ do

@@ -29,6 +29,10 @@ sParser sourceCode =   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>" +blParser :: String -> Block ()+blParser sourceCode =+  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"+ fParser :: String -> ProgramUnit () fParser sourceCode =   evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"@@ -402,10 +406,10 @@       describe "Common" $ do         let commonNames = [ ExpValue () u (ValVariable "something")                           , ExpValue () u (ValVariable "other") ]-            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]-                     , fromList () [ varGen "y" ] ]+            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]+                     , fromList () [ declVarGen "y" ] ]             st = StCommon () u $ fromList ()-              [ CommonGroup () u Nothing (fromList () [ varGen "q" ])+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])               , CommonGroup () u (Just $ head commonNames) (head itemss)               , CommonGroup () u (Just $ last commonNames) (last itemss) ] @@ -484,21 +488,22 @@             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing      describe "If" $ do-      it "parses if-then statement" $-        sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse--      it "parses if-then statement with construct name" $ do-        let st = StIfThen () u (Just "my_if") valFalse-        sParser "my_if: if (.false.) then" `shouldBe'` st--      it "parses else statement" $-        sParser "else" `shouldBe'` StElse () u Nothing+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])+      it "parser if block" $+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]+            falseLit = ExpValue () u (ValLogical ".false.")+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing -      it "parses else-if statement" $-        sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue+      it "parses named if block" $ do+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]+            trueLit = ExpValue () u (ValLogical ".true.")+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing+        blParser ifBlockSrc `shouldBe'` ifBlock -      it "parses end if statement" $-        sParser "end if" `shouldBe'` StEndif () u Nothing+      it "parses if-else block with inline comments (stripped)" $+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]+            falseLit = ExpValue () u (ValLogical ".false.")+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing        it "parses logical if statement" $ do         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")@@ -512,24 +517,45 @@         sParser "if (x) 1, 2, 3" `shouldBe'` stIf      describe "Case" $ do-      it "parses select case statement" $ do-        let st = StSelectCase () u Nothing (varGen "n")-        sParser "select case (n)" `shouldBe'` st--      it "parses select case statement with construct name" $ do-        let st = StSelectCase () u (Just "case") (varGen "n")-        sParser "case: select case (n)" `shouldBe'` st--      it "parses case statement" $ do-        let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ]-        sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges)--      it "parses case statement" $-        sParser "case default" `shouldBe'` StCase () u Nothing Nothing--      it "parses end select statement" $ do-        let st = StEndcase () u (Just "name")-        sParser "end select name" `shouldBe'` st+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs+          printBlock = BlStatement () u Nothing . printStmt+          intLit = ExpValue () u . ValInteger+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing+          conds = [Just ind2, Just ind3Plus, Nothing]+      it "unlabelled case block (with inline comments to be stripped)" $ do+        let src = unlines [ "select case (x) ! comment select"+                          , "! full line before first case (unrepresentable)"+                          , "case (2) ! comment case 1"+                          , "print *, 'foo'"+                          , "case (3:) ! comment case 2"+                          , "print *, 'bar'"+                          , "case default ! comment case 3"+                          , "print *, 'baz'"+                          , "end select ! comment end"+                          ]+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing+        blParser src `shouldBe'` block+      it "labelled case block (with inline comments to be stripped" $ do+        let src = unlines [ "10 mylabel: select case (x) ! comment select"+                          , "20 case (2) ! comment case 1"+                          , "30 print *, 'foo'"+                          , "40 case (3:) ! comment case 2"+                          , "50 print *, 'bar'"+                          , "60 case default ! comment case 3"+                          , "70 print *, 'baz'"+                          , "80 end select mylabel ! comment end"+                          ]+            blocks = (fmap . fmap)+                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)+                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]+            block = BlCase () u+                           (Just $ intLit "10") (Just "mylabel") (varGen "x")+                           conds blocks+                           (Just $ intLit "80")+        blParser src `shouldBe'` block      describe "Do" $ do       it "parses do statement with label" $ do@@ -552,9 +578,18 @@         let st = StEnddo () u (Just "constructor")         sParser "end do constructor" `shouldBe'` st -      it "parses end do while statement" $ do+    describe "DO WHILE" $ do+      it "parses unnamed do while statement" $ do+        let st = StDoWhile () u Nothing Nothing valTrue+        sParser "do while (.true.)" `shouldBe'` st++      it "parses named do while statement" $ do         let st = StDoWhile () u (Just "name") Nothing valTrue         sParser "name: do while (.true.)" `shouldBe'` st++      it "parses unnamed labelled do while statement" $ do+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue+        sParser "do 999 while (.true.)" `shouldBe'` st      describe "Goto" $ do       it "parses vanilla goto" $ do

@@ -77,4 +77,4 @@         jExp a b c = Just (Exponent a b c)         expE = ExpLetterE         expD = ExpLetterD-        fails test = return test `shouldThrow` anyException+        -- fails test = return test `shouldThrow` anyException

@@ -81,15 +81,15 @@         pprint Fortran90 impList Nothing `shouldBe` "integer (x, a-z, o)"      describe "Common group" $ do-      let globs = [ varGen "x", varGen "y", varGen "z" ]+      let globs = [ declVarGen "x", declVarGen "y", declVarGen "z" ]        it "prints anonymous common group" $ do         let group = CommonGroup () u Nothing (AList () u globs)-        pprint Fortran66 group Nothing `shouldBe` "//x, y, z"+        pprint Fortran66 group Nothing `shouldBe` "// x, y, z"        it "prints named common group" $ do         let group = CommonGroup () u (Just $ varGen "my_g") (AList () u globs)-        pprint Fortran66 group Nothing `shouldBe` "/my_g/x, y, z"+        pprint Fortran66 group Nothing `shouldBe` "/my_g/ x, y, z"      describe "Format item" $       it "prints hollerith constant" $ do@@ -209,10 +209,6 @@           let logIf = StIfLogical () u valFalse as           pprint Fortran90 logIf Nothing `shouldBe` "if (.false.) x = 42" -        it "prints named if-then" $ do-          let ifThen = StIfThen () u (Just "mistral") valTrue-          pprint Fortran90 ifThen Nothing `shouldBe` "mistral: if (.true.) then"-       describe "Case" $ do         it "prints select case" $ do           let sc = StSelectCase () u Nothing (varGen "x")@@ -407,6 +403,43 @@                                , "    i = (i - 1)"                                , "42 end select" ]           pprint Fortran90 bl (Just 0) `shouldBe` text expect++      describe "Case" $+        it "prints multi-case select case construct" $ do+          let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing+          let cases = [ Just (AList () u [range])+                      , Just (AList () u [ IxSingle () u Nothing (intGen 7) ])+                      , Nothing ]+          let bodies = replicate 3 body+          let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42))+          let expect = unlines [ "select case (x)"+                               , "  case (2:4)"+                               , "    print *, i"+                               , "    i = (i - 1)"+                               , "  case (7)"+                               , "    print *, i"+                               , "    i = (i - 1)"+                               , "  case default"+                               , "    print *, i"+                               , "    i = (i - 1)"+                               , "42 end select" ]+          pprint Fortran90 bl (Just 0) `shouldBe` text expect++      describe "Associate" $+        it "prints multi-abbreviation associate block (Fortran2003)" $ do+          let bl      = BlAssociate () u Nothing Nothing abbrevs body' Nothing+              body'   = [blStmtPrint "x", blStmtPrint "y"]+              blStmtPrint x = BlStatement () u Nothing (stmtPrint x)+              stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])+              abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]+              abbrev var expr = ATuple () u (expValVar var) expr+              expValVar x = ExpValue () u (ValVariable x)+              expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)+          let expect = unlines [ "associate (x => a, y => (a * b))"+                               , "  print *, x"+                               , "  print *, y"+                               , "end associate" ]+          pprint Fortran2003 bl (Just 0) `shouldBe` text expect      describe "Program units" $ do       describe "Main" $ do

@@ -455,8 +455,16 @@   c2 <- BC.readFile actual   compareByteString c1 c2 +-- XXX: It appears the rewriter has different behaviour on Windows and Linux --+--      specifically relating to newlines. So we use a custom equality check+--      that skips Windows newlines (@\r@ characters are skipped).+--+--      (This is morally grey: the issue is unlikely to rear its head in+--      practical usage, _but_ if you were to be comparing rewriter output from+--      different platforms, you may encounter it. Most cross-platform text+--      tooling recognises/ignores Windows newlines, however.) compareByteString :: BC.ByteString -> BC.ByteString -> IO Bool-compareByteString expected actual = if expected == actual+compareByteString expected actual = if expected `eqSkipWinNewlines` actual   then return True   else do     BC.putStrLn ">>>>>>> EXPECTED"@@ -464,3 +472,25 @@     BC.putStrLn ">>>>>>> ACTUAL"     BC.putStrLn actual     return False++eqSkipWinNewlines :: BC.ByteString -> BC.ByteString -> Bool+eqSkipWinNewlines x1 x2 = go (BC.uncons x1) (BC.uncons x2)+  where+    go :: Maybe (Char, BC.ByteString) -> Maybe (Char, BC.ByteString) -> Bool++    -- both reached EOF simultaneously: identical+    go Nothing Nothing = True++    -- next character in either bytestring is @\r@: skip+    go (Just ('\r', bs1)) bs2 = go (BC.uncons bs1) bs2+    go bs1 (Just ('\r', bs2)) = go bs1 (BC.uncons bs2)++    -- only one bytestring is EOF: different+    go Nothing (Just _)       = False+    go (Just _) Nothing       = False++    -- main case: check equality of next words+    go (Just (b1, bs1)) (Just (b2, bs2)) =+        if   b1 == b2+        then go (BC.uncons bs1) (BC.uncons bs2)+        else False

@@ -14,8 +14,6 @@ import Language.Fortran.Parser.Fortran95 import Language.Fortran.Parser.Fortran77 -groupIf :: ProgramFile () -> ProgramFile ()-groupIf = transform [ GroupIf ] groupDo :: ProgramFile () -> ProgramFile () groupDo = transform [ GroupLabeledDo ] groupForall :: ProgramFile () -> ProgramFile ()@@ -33,13 +31,7 @@     it "groups unlabelled FORALL blocks" $ do       let lhs = (evaluate . force) (groupForall $ exampleForall name endName)       lhs `shouldThrow` anyErrorCall-  describe "Block IF-THEN and related statements" $ do-    it "groups example1" $-      groupIf example1 `shouldBe'` expectedExample1 -    it "groups example2" $-      groupIf example2 `shouldBe'` expectedExample2-   describe "Block DO statements" $ do     it "do group example1" $       groupDo example1do `shouldBe` expectedExample1do@@ -78,58 +70,6 @@ expectedForall :: Maybe String -> ProgramFile () expectedForall name  = buildExampleProgram "forall"     [BlForall () u Nothing name exampleHeader [exampleComment] Nothing]----- if (.true.) then--- end if-example1 :: ProgramFile ()-example1 = ProgramFile mi77 [ PUMain () u (Just "example1") example1Blocks Nothing ]-example1Blocks :: [Block ()]-example1Blocks =-  [ BlStatement () u Nothing (StIfThen () u Nothing valTrue)-  , BlStatement () u Nothing (StEndif () u Nothing) ]--expectedExample1 :: ProgramFile ()-expectedExample1 = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1Blocks Nothing ]-expectedExample1Blocks :: [Block ()]-expectedExample1Blocks = [ BlIf () u Nothing Nothing [ Just valTrue ] [ [ ] ] Nothing ]---- if (.true.) then---   integer x---   if (.false.) then---   endif--- else if (.true.) then--- else---   if (.false.) then---   endif--- end if-example2 :: ProgramFile ()-example2 = ProgramFile mi77 [ PUMain () u (Just "example2") example2Blocks Nothing ]-example2Blocks :: [Block ()]-example2Blocks =-  [ BlStatement () u Nothing (StIfThen () u Nothing valTrue)-  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ]))-  , BlStatement () u Nothing (StIfThen () u Nothing valFalse)-  , BlStatement () u Nothing (StEndif () u Nothing)-  , BlStatement () u Nothing (StElsif () u Nothing valTrue)-  , BlStatement () u Nothing (StElse () u Nothing)-  , BlStatement () u Nothing (StIfThen () u Nothing valFalse)-  , BlStatement () u Nothing (StEndif () u Nothing)-  , BlStatement () u Nothing (StEndif () u Nothing) ]--expectedExample2 :: ProgramFile ()-expectedExample2 = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2Blocks Nothing ]-expectedExample2Blocks :: [Block ()]-expectedExample2Blocks = [ BlIf () u Nothing Nothing [ Just valTrue, Just valTrue, Nothing ] blockGroups Nothing ]-blockGroups :: [[Block ()]]-blockGroups =-  [ [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ]))-    , innerIf ]-  , [ ]-  , [ innerIf ] ]-innerIf :: Block ()-innerIf = BlIf () u Nothing Nothing [ Just valFalse ] [ [ ] ] Nothing-  -- do 10 i = 0, 10 -- 10   continue

@@ -32,6 +32,9 @@ varGen :: String -> Expression () varGen str = ExpValue () u $ ValVariable str +declVarGen :: String -> Declarator ()+declVarGen str = DeclVariable () u (varGen str) Nothing Nothing+ intGen :: Integer -> Expression () intGen i = ExpValue () u $ ValInteger $ show i