fortran-src 0.2.0.0 → 0.2.1.1

raw patch · 42 files changed

+6956/−357 lines, 42 filesdep +deepseqdep ~GenericPrettyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

Dependency ranges changed: GenericPretty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• fortran-src.cabal +35/−36
• src/Language/Fortran/AST.hs +106/−8
• src/Language/Fortran/Analysis.hs +33/−3
• src/Language/Fortran/Analysis/BBlocks.hs +4/−4
• src/Language/Fortran/Analysis/Types.hs +9/−2
• src/Language/Fortran/Intrinsics.hs +116/−75
• src/Language/Fortran/LValue.hs +37/−0
• src/Language/Fortran/Lexer/FixedForm.x +352/−63
• src/Language/Fortran/Lexer/FreeForm.x +6/−0
• src/Language/Fortran/Parser/Any.hs +10/−3
• src/Language/Fortran/Parser/Fortran66.y +4/−4
• src/Language/Fortran/Parser/Fortran77.y +359/−75
• src/Language/Fortran/Parser/Fortran90.y +17/−8
• src/Language/Fortran/Parser/Fortran95.y +1178/−0
• src/Language/Fortran/ParserMonad.hs +4/−0
• src/Language/Fortran/PrettyPrint.hs +59/−11
• src/Language/Fortran/Transformation/Disambiguation/Function.hs +3/−0
• src/Language/Fortran/Transformation/Grouping.hs +87/−44
• src/Language/Fortran/Transformer.hs +4/−2
• src/Main.hs +26/−19
• test/Language/Fortran/Analysis/BBlocksSpec.hs +134/−0
• test/Language/Fortran/Analysis/DataFlowSpec.hs +414/−0
• test/Language/Fortran/Analysis/RenamingSpec.hs +371/−0
• test/Language/Fortran/Analysis/TypesSpec.hs +160/−0
• test/Language/Fortran/AnalysisSpec.hs +63/−0
• test/Language/Fortran/Lexer/FixedFormSpec.hs +281/−0
• test/Language/Fortran/Lexer/FreeFormSpec.hs +263/−0
• test/Language/Fortran/Parser/Fortran2003Spec.hs +9/−0
• test/Language/Fortran/Parser/Fortran2008Spec.hs +9/−0
• test/Language/Fortran/Parser/Fortran66Spec.hs +221/−0
• test/Language/Fortran/Parser/Fortran77Spec.hs +306/−0
• test/Language/Fortran/Parser/Fortran90Spec.hs +538/−0
• test/Language/Fortran/Parser/Fortran95Spec.hs +584/−0
• test/Language/Fortran/Parser/UtilsSpec.hs +28/−0
• test/Language/Fortran/ParserMonadSpec.hs +93/−0
• test/Language/Fortran/PrettyPrintSpec.hs +489/−0
• test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +158/−0
• test/Language/Fortran/Transformation/GroupingSpec.hs +176/−0
• test/Language/Fortran/Util/FirstParameterSpec.hs +58/−0
• test/Language/Fortran/Util/SecondParameterSpec.hs +55/−0
• test/TestUtil.hs +86/−0

@@ -0,0 +1,11 @@+### 0.2.1.1 (May 18, 2018)++* Extend Fortran 95 support+* Extend support for legacy extensions++### 0.2.1.1 (December 13, 2017)++* Fortran95Experimental module renamed to Fortran95+* No infinite loops due to symlinks.+* Fortran 95 support.+  * AST extended to support more non-standard statements internally.

@@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                fortran-src-version:             0.2.0.0-synopsis:            Parser and anlyses for Fortran standards 66, 77, 90.-description:         Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, and Fortran 90. 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.+version:             0.2.1.1+synopsis:            Parser and anlyses 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. bug-reports:         https://github.com/camfort/fortran-src/issues license:             Apache-2.0 license-file:        LICENSE@@ -13,21 +13,20 @@ -- copyright: category:            Language build-type:          Simple--- extra-source-files:+extra-source-files:  CHANGELOG.md cabal-version:       >=1.10 source-repository head   type:     git   location: https://github.com/camfort/fortran-src  executable fortran-src-  main-is: Main.hs-  hs-source-dirs: src+  main-is: src/Main.hs   build-depends:     base >= 4.6 && < 5,     mtl >= 2.2 && < 3,     array >= 0.5 && < 0.6,     uniplate >= 1.6 && < 2,-    GenericPretty >= 1.2 && < 2,+    GenericPretty >= 1.2.2 && < 2,     pretty >= 1.1 && < 2,     containers >= 0.5 && < 0.6,     text >= 1.2 && < 2,@@ -35,33 +34,8 @@     binary >= 0.8.3.0 && < 0.9,     filepath >= 1.4 && < 2,     directory >= 1.2 && < 2,-    fgl >= 5 && < 6-  other-modules:-    Language.Fortran.Analysis-    Language.Fortran.Analysis.Renaming-    Language.Fortran.Analysis.Types-    Language.Fortran.Analysis.BBlocks-    Language.Fortran.Analysis.DataFlow-    Language.Fortran.AST-    Language.Fortran.Intrinsics-    Language.Fortran.Lexer.FixedForm-    Language.Fortran.Lexer.FreeForm-    Language.Fortran.ParserMonad-    Language.Fortran.Parser.Any-    Language.Fortran.Parser.Fortran66-    Language.Fortran.Parser.Fortran77-    Language.Fortran.Parser.Fortran90-    Language.Fortran.Parser.Utils-    Language.Fortran.PrettyPrint-    Language.Fortran.Transformation.Disambiguation.Function-    Language.Fortran.Transformation.Disambiguation.Intrinsic-    Language.Fortran.Transformation.Grouping-    Language.Fortran.Transformation.TransformMonad-    Language.Fortran.Transformer-    Language.Fortran.Util.Position-    Language.Fortran.Util.FirstParameter-    Language.Fortran.Util.SecondParameter-    Language.Fortran.Util.ModFile+    fgl >= 5 && < 6,+    fortran-src   ghc-options: -fno-warn-tabs   default-language: Haskell2010 @@ -73,6 +47,7 @@     Language.Fortran.Analysis.BBlocks     Language.Fortran.Analysis.DataFlow     Language.Fortran.AST+    Language.Fortran.LValue     Language.Fortran.Intrinsics     Language.Fortran.Lexer.FixedForm     Language.Fortran.Lexer.FreeForm@@ -81,6 +56,7 @@     Language.Fortran.Parser.Fortran66     Language.Fortran.Parser.Fortran77     Language.Fortran.Parser.Fortran90+    Language.Fortran.Parser.Fortran95     Language.Fortran.Parser.Utils     Language.Fortran.PrettyPrint     Language.Fortran.Transformation.Disambiguation.Function@@ -100,7 +76,7 @@     mtl >= 2.2 && < 3,     array >= 0.5 && < 0.6,     uniplate >= 1.6 && < 2,-    GenericPretty >= 1.2 && < 2,+    GenericPretty >= 1.2.2 && < 2,     pretty >= 1.1 && < 2,     containers >= 0.5 && < 0.6,     text >= 1.2 && < 2,@@ -116,6 +92,7 @@ test-suite spec   type: exitcode-stdio-1.0   build-depends:+    deepseq,     base >= 4.6 && < 5,     hspec >= 2.2 && < 3,     mtl >= 2.2 && < 3,@@ -123,7 +100,7 @@     uniplate >= 1.6 && < 2,     directory >= 1.2 && < 2,     filepath >= 1.4 && < 2,-    GenericPretty >= 1.2 && < 2,+    GenericPretty >= 1.2.2 && < 2,     pretty >= 1.1 && < 2,     containers >= 0.5 && < 0.6,     text >= 1.2 && < 2,@@ -133,4 +110,26 @@     fortran-src   hs-source-dirs: test   main-is: Spec.hs+  other-modules:+    Language.Fortran.Analysis.BBlocksSpec+    Language.Fortran.Analysis.DataFlowSpec+    Language.Fortran.Analysis.RenamingSpec+    Language.Fortran.Analysis.TypesSpec+    Language.Fortran.AnalysisSpec+    Language.Fortran.Lexer.FixedFormSpec+    Language.Fortran.Lexer.FreeFormSpec+    Language.Fortran.Parser.Fortran2003Spec+    Language.Fortran.Parser.Fortran2008Spec+    Language.Fortran.Parser.Fortran66Spec+    Language.Fortran.Parser.Fortran77Spec+    Language.Fortran.Parser.Fortran90Spec+    Language.Fortran.Parser.Fortran95Spec+    Language.Fortran.Parser.UtilsSpec+    Language.Fortran.ParserMonadSpec+    Language.Fortran.PrettyPrintSpec+    Language.Fortran.Transformation.Disambiguation.FunctionSpec+    Language.Fortran.Transformation.GroupingSpec+    Language.Fortran.Util.FirstParameterSpec+    Language.Fortran.Util.SecondParameterSpec+    TestUtil   default-language:    Haskell2010

@@ -64,6 +64,7 @@   | TypeLogical   | TypeCharacter   | TypeCustom String+  | TypeByte   deriving (Ord, Eq, Show, Data, Typeable, Generic)  instance Binary BaseType@@ -99,7 +100,7 @@       (Maybe [ProgramUnit a]) -- Subprograms   | PUSubroutine       a SrcSpan-      Bool -- Recursive or not+      (PUFunctionOpt a) -- Subroutine options       Name       (Maybe (AList Expression a)) -- Arguments       [Block a] -- Body@@ -107,7 +108,7 @@   | PUFunction       a SrcSpan       (Maybe (TypeSpec a)) -- Return type-      Bool -- Recursive or not+      (PUFunctionOpt a) -- Function Options       Name       (Maybe (AList Expression a)) -- Arguments       (Maybe (Expression a)) -- Result@@ -120,6 +121,37 @@   | PUComment a SrcSpan (Comment a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) +type IsRecursive = Bool+data PUFunctionOpt a =+    None a SrcSpan IsRecursive+  | Pure a SrcSpan IsRecursive+  | Elemental a SrcSpan+  deriving (Eq, Show, Data, Typeable, Generic, Functor)++buildPUFunctionOpt :: (PUFunctionOpt ()) -> (PUFunctionOpt ()) -> Either String (PUFunctionOpt ())+buildPUFunctionOpt a b =+  case (a, b) of+    ((None () _ False ), _)         -> Right $ setSpan (getTransSpan a b) b+    (_, (None () _ False))          -> Right $ setSpan (getTransSpan a b) a+    ((Elemental () _), _)           -> if functionIsRecursive b+                                         then Left "Function cannot be both elemental and recursive. "+                                         else Right . Elemental () $ getTransSpan a b+    (_, (Elemental () _))           -> buildPUFunctionOpt b a+    ((Pure () _ r), b)              -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive b)+    (a, (Pure () _ r))              -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive a)+    ((None () _ r), (None () _ r')) -> Right $ None () (getTransSpan a b) (r || r')+-- Should parse: "elemental pure recursive function f()\nend": Right (Elemental ()) FAILED [4]++buildPUFunctionOpts :: [PUFunctionOpt ()] -> Either String (PUFunctionOpt())+buildPUFunctionOpts =+  foldr merge . Right $ None () initSrcSpan False+  where merge a = either Left $ buildPUFunctionOpt a++functionIsRecursive :: (PUFunctionOpt a) -> Bool+functionIsRecursive (Elemental _ _) = False+functionIsRecursive (Pure _ _ r)    = r+functionIsRecursive (None _ _ r)    = r+ programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _)              = bs programUnitBody (PUModule _ _ _ bs _)            = bs@@ -157,6 +189,13 @@                 (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+   | BlIf        a SrcSpan                 (Maybe (Expression a))       -- Label                 (Maybe String)               -- Construct name@@ -183,6 +222,7 @@   | 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@@ -197,6 +237,7 @@  data Statement a  =     StDeclaration         a SrcSpan (TypeSpec a) (Maybe (AList Attribute a)) (AList Declarator a)+  | StStructure           a SrcSpan (Maybe String) (AList StructureItem a)   | StIntent              a SrcSpan Intent (AList Expression a)   | StOptional            a SrcSpan (AList Expression a)   | StPublic              a SrcSpan (Maybe (AList Expression a))@@ -207,6 +248,7 @@   | StPointer             a SrcSpan (AList Declarator a)   | StTarget              a SrcSpan (AList Declarator a)   | StData                a SrcSpan (AList DataGroup a)+  | StAutomatic           a SrcSpan (AList Declarator a)   | StNamelist            a SrcSpan (AList Namelist a)   | StParameter           a SrcSpan (AList Declarator a)   | StExternal            a SrcSpan (AList Expression a)@@ -216,7 +258,7 @@   | StFormat              a SrcSpan (AList FormatItem a)   | StImplicit            a SrcSpan (Maybe (AList ImpList a))   | StEntry               a SrcSpan (Expression a) (Maybe (AList Expression a)) (Maybe (Expression a))-  | StInclude             a SrcSpan (Expression a)+  | StInclude             a SrcSpan (Expression a) (Maybe [Block a])   | StDo                  a SrcSpan (Maybe String) (Maybe (Expression a)) (Maybe (DoSpecification a))   | StDoWhile             a SrcSpan (Maybe String) (Maybe (Expression a)) (Expression a)   | StEnddo               a SrcSpan (Maybe String)@@ -236,7 +278,7 @@   | StPointerAssign       a SrcSpan (Expression a) (Expression a)   | StLabelAssign         a SrcSpan (Expression a) (Expression a)   | StGotoUnconditional   a SrcSpan (Expression a)-  | StGotoAssigned        a SrcSpan (Expression a) (AList Expression a)+  | StGotoAssigned        a SrcSpan (Expression a) (Maybe (AList Expression a))   | StGotoComputed        a SrcSpan (AList Expression a) (Expression a)   | StCall                a SrcSpan (Expression a) (Maybe (AList Argument a))   | StReturn              a SrcSpan (Maybe (Expression a))@@ -247,6 +289,7 @@   | StRead2               a SrcSpan (Expression a) (Maybe (AList Expression a))   | StWrite               a SrcSpan (AList ControlPair a) (Maybe (AList Expression a))   | StPrint               a SrcSpan (Expression a) (Maybe (AList Expression a))+  | StTypePrint           a SrcSpan (Expression a) (Maybe (AList Expression a))   | StOpen                a SrcSpan (AList ControlPair a)   | StClose               a SrcSpan (AList ControlPair a)   | StInquire             a SrcSpan (AList ControlPair a)@@ -268,7 +311,9 @@   | StType                a SrcSpan (Maybe (AList Attribute a)) String   | StEndType             a SrcSpan (Maybe String)   | StSequence            a SrcSpan-  | StForall              a SrcSpan (ForallHeader a) (Statement a)+  | StForall              a SrcSpan (Maybe String) (ForallHeader a)+  | StForallStatement     a SrcSpan (ForallHeader a) (Statement a)+  | StEndForall           a SrcSpan (Maybe String)   -- Following is a temporary solution to a complicated FORMAT statement   -- parsing problem.   | StFormatBogus         a SrcSpan String@@ -333,6 +378,16 @@   DataGroup a SrcSpan (AList Expression a) (AList Expression a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) +data StructureItem a =+    StructFields a SrcSpan (TypeSpec a) (Maybe (AList Attribute a)) (AList Declarator a)+  | StructUnion a SrcSpan (AList UnionMap a)+  | StructStructure a SrcSpan (Maybe String) (AList StructureItem a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)++data UnionMap a =+  UnionMap a SrcSpan (AList StructureItem a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+ data FormatItem a =     FIFormatList            a             SrcSpan   (Maybe String) (AList FormatItem a)   | FIHollerith             a             SrcSpan   (Value a)@@ -350,14 +405,23 @@  data Expression a =     ExpValue         a SrcSpan (Value a)+  -- ^ Use a value as an expression.   | 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.   | ExpSubscript     a SrcSpan (Expression a) (AList Index a)+  -- ^ Array indexing   | ExpDataRef       a SrcSpan (Expression a) (Expression a)+  -- ^ @%@ notation for variables inside data types   | ExpFunctionCall  a SrcSpan (Expression a) (Maybe (AList Argument a))+  -- ^ A function expression applied to a list of arguments.   | ExpImpliedDo     a SrcSpan (AList Expression a) (DoSpecification a)+  -- ^ Implied do (i.e. one-liner do loops)   | ExpInitialisation  a SrcSpan (AList Expression a)+  -- ^ Array initialisation   | ExpReturnSpec    a SrcSpan (Expression a)+  -- ^ Function return value specification   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data Index a =@@ -371,15 +435,25 @@ -- All recursive Values data Value a =     ValInteger           String+  -- ^ The string representation of an integer literal   | ValReal              String+  -- ^ The string representation of a real literal   | ValComplex           (Expression a) (Expression a)+  -- ^ The real and imaginary parts of a complex value   | ValString            String+  -- ^ A string literal   | ValHollerith         String+  -- ^ A Hollerith literal   | ValVariable          Name+  -- ^ The name of a variable   | ValIntrinsic         Name+  -- ^ The name of a built-in function   | ValLogical           String+  -- ^ A boolean value   | ValOperator          String+  -- ^ User-defined operators in interfaces   | ValAssignment+  -- ^ Overloaded assignment in interfaces   | ValType              String   | ValStar   deriving (Eq, Show, Data, Typeable, Generic, Functor)@@ -427,6 +501,7 @@   | EQ   | NE   | Or+  | XOr   | And   | Equivalent   | NotEquivalent@@ -448,6 +523,7 @@  instance FirstParameter (AList t a) a instance FirstParameter (ProgramUnit a) a+instance FirstParameter (PUFunctionOpt a) a instance FirstParameter (Block a) a instance FirstParameter (Statement a) a instance FirstParameter (Argument a) a@@ -459,6 +535,8 @@ instance FirstParameter (ImpElement a) a instance FirstParameter (CommonGroup a) a instance FirstParameter (DataGroup a) a+instance FirstParameter (StructureItem a) a+instance FirstParameter (UnionMap a) a instance FirstParameter (Namelist a) a instance FirstParameter (FormatItem a) a instance FirstParameter (Expression a) a@@ -470,6 +548,7 @@  instance SecondParameter (AList t a) SrcSpan instance SecondParameter (ProgramUnit a) SrcSpan+instance SecondParameter (PUFunctionOpt a) SrcSpan instance SecondParameter (Block a) SrcSpan instance SecondParameter (Statement a) SrcSpan instance SecondParameter (Argument a) SrcSpan@@ -481,6 +560,8 @@ instance SecondParameter (ImpElement a) SrcSpan instance SecondParameter (CommonGroup a) SrcSpan instance SecondParameter (DataGroup a) SrcSpan+instance SecondParameter (StructureItem a) SrcSpan+instance SecondParameter (UnionMap a) SrcSpan instance SecondParameter (Namelist a) SrcSpan instance SecondParameter (FormatItem a) SrcSpan instance SecondParameter (Expression a) SrcSpan@@ -503,6 +584,8 @@ instance Annotated ImpElement instance Annotated CommonGroup instance Annotated DataGroup+instance Annotated StructureItem+instance Annotated UnionMap instance Annotated Namelist instance Annotated FormatItem instance Annotated Expression@@ -514,6 +597,7 @@  instance Spanned (AList t a) instance Spanned (ProgramUnit a)+instance Spanned (PUFunctionOpt a) instance Spanned (Statement a) instance Spanned (Argument a) instance Spanned (Use a)@@ -525,6 +609,8 @@ instance Spanned (Block a) instance Spanned (CommonGroup a) instance Spanned (DataGroup a)+instance Spanned (StructureItem a)+instance Spanned (UnionMap a) instance Spanned (Namelist a) instance Spanned (FormatItem a) instance Spanned (Expression a)@@ -534,6 +620,14 @@ instance Spanned (DimensionDeclarator a) instance Spanned (ControlPair a) +instance Spanned (ProgramFile a) where+  getSpan (ProgramFile _ pus) =+    case pus of+      [] -> SrcSpan initPosition initPosition+      pus -> getSpan pus++  setSpan _ _ = error "Cannot set span to a program unit"+ instance (Spanned a) => Spanned [a] where   getSpan [] = error "Trying to find how long an empty list spans for."   getSpan [x]   = getSpan x@@ -611,20 +705,20 @@   getLabel (BlIf _ _ l _ _ _ _) = l   getLabel (BlCase _ _ l _ _ _ _ _) = l   getLabel (BlDo _ _ l _ _ _ _ _) = l-  getLabel (BlDoWhile _ _ l _ _ _ _) = l+  getLabel (BlDoWhile _ _ l _ _ _ _ _) = l   getLabel _ = Nothing    getLastLabel b@BlStatement{} = getLabel b   getLastLabel (BlIf _ _ _ _ _ _ l) = l   getLastLabel (BlCase _ _ _ _ _ _ _ l) = l   getLastLabel (BlDo _ _ _ _ _ _ _ l) = l-  getLastLabel (BlDoWhile _ _ _ _ _ _ l) = l+  getLastLabel (BlDoWhile _ _ _ _ _ _ _ l) = l   getLastLabel _ = Nothing    setLabel (BlStatement a s _ st) l = BlStatement a s (Just l) st   setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el   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 spec bs el) l = BlDoWhile a s (Just l) n 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 l = b  class Conditioned f where@@ -675,6 +769,7 @@ instance Out MetaInfo instance Out a => Out (ProgramFile a) instance Out a => Out (ProgramUnit a)+instance Out a => Out (PUFunctionOpt a) instance (Out a, Out (t a)) => Out (AList t a) instance Out a => Out (Statement a) instance Out Only@@ -688,6 +783,8 @@ instance Out a => Out (Block a) instance Out a => Out (CommonGroup a) instance Out a => Out (DataGroup a)+instance Out a => Out (StructureItem a)+instance Out a => Out (UnionMap a) instance Out a => Out (Namelist a) instance Out a => Out (FormatItem a) instance Out a => Out (Expression a)@@ -734,6 +831,7 @@     StFormatBogus {} -> True     StInclude {}     -> True     StDeclaration {} -> True+    StStructure {}   -> True     _                -> False  executableStatement :: FortranVersion -> Statement a -> Bool

@@ -3,7 +3,8 @@ -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis-  ( initAnalysis, stripAnalysis, Analysis(..), varName, srcName, isNamedExpression+  ( initAnalysis, stripAnalysis, Analysis(..)+  , varName, srcName, lvVarName, lvSrcName, isNamedExpression   , genVar, puName, puSrcName, blockRhsExprs, rhsExprs   , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..)   , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars@@ -16,6 +17,7 @@ import Data.Generics.Uniplate.Data import Data.Data import Language.Fortran.AST+import Language.Fortran.LValue import Data.Graph.Inductive.PatriciaTree (Gr) import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty@@ -24,6 +26,7 @@ import Data.Maybe import Data.Binary import Language.Fortran.Intrinsics (getIntrinsicDefsUses, allIntrinsics)+import Data.Bifunctor (first)  -------------------------------------------------- @@ -61,6 +64,7 @@ data ConstructType =     CTFunction   | CTSubroutine+  | CTExternal   | CTVariable   | CTArray   | CTParameter@@ -90,6 +94,19 @@   }   deriving (Data, Show, Eq, Generic) +instance Functor Analysis where+  fmap f analysis =+    Analysis+    { prevAnnotation = f (prevAnnotation analysis)+    , uniqueName = uniqueName analysis+    , sourceName = sourceName analysis+    , bBlocks = fmap (first . fmap . fmap . fmap $ f) . bBlocks $ analysis+    , insLabel = insLabel analysis+    , moduleEnv = moduleEnv analysis+    , idType = idType analysis+    , allLhsVarsAnn = allLhsVarsAnn analysis+    }+ instance Out (Analysis a) where   doc a = parens . text . unwords . map (uncurry (++) . fmap fromJust) . filter (isJust . snd) $             [ ("uniqueName: ", uniqueName a)@@ -131,6 +148,19 @@ srcName (ExpValue _ _ (ValIntrinsic n))                                   = n srcName _                                                                 = error "Use of srcName on non-variable." +-- | Obtain either uniqueName or source name from an LvSimpleVar variable.+lvVarName :: LValue (Analysis a) -> String+lvVarName (LvSimpleVar (Analysis { uniqueName = Just n }) _ _)  = n+lvVarName (LvSimpleVar (Analysis { sourceName = Just n }) _ _)  = n+lvVarName (LvSimpleVar _ _ n)                                   = n+lvVarName _                                                     = error "Use of lvVarName on non-variable."++-- | Obtain the source name from an LvSimpleVar variable.+lvSrcName :: LValue (Analysis a) -> String+lvSrcName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n+lvSrcName (LvSimpleVar _ _ n) = n+lvSrcName _ = error "Use of lvSrcName on a non-variable"+ -- | Generate an ExpValue variable with its source name == to its uniqueName. genVar :: Analysis a -> SrcSpan -> String -> Expression (Analysis a) genVar a s n = ExpValue (a { uniqueName = Just n, sourceName = Just n }) s v@@ -263,7 +293,7 @@ blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)   | ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs   | otherwise                      = universeBi (rhs, e1, e2)-blockRhsExprs (BlDoWhile _ _ e1 _ e2 _ _)   = universeBi (e1, e2)+blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2) blockRhsExprs (BlIf _ _ e1 _ e2 _ _)        = universeBi (e1, e2) blockRhsExprs b                             = universeBi b @@ -292,7 +322,7 @@ blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))   | Just uses <- intrinsicUses f = uses blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps-blockVarUses (BlDoWhile _ _ e1 _ e2 _ _)   = maybe [] allVars e1 ++ allVars e2+blockVarUses (BlDoWhile _ _ e1 _ _ e2 _ _) = maybe [] allVars e1 ++ allVars e2 blockVarUses (BlIf _ _ e1 _ e2 _ _)        = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2 blockVarUses b                             = allVars b 

@@ -91,7 +91,7 @@         BlIf        a s e1 mn e2 bss el    -> BlIf        a s (mfill i e1) mn (mmfill i e2) bss el         BlCase      a s e1 mn e2 is bss el -> BlCase      a s (mfill i e1) mn (fill i e2) (mmfill i is) bss el         BlDo        a s e1 mn tl e2 bs el  -> BlDo        a s (mfill i e1) mn tl (mfill i e2) bs el-        BlDoWhile   a s e1 n e2 bs el      -> BlDoWhile   a s (mfill i e1) n (fill i e2) bs el+        BlDoWhile   a s e1 n tl e2 bs el   -> BlDoWhile   a s (mfill i e1) n tl (fill i e2) bs el         _                             -> b       where i = insLabel $ getAnnotation b @@ -213,7 +213,7 @@ -- Find target of Goto statements (Return statements default target to -1). examineFinalBlock lm bs@(_:_)   | BlStatement _ _ _ (StGotoUnconditional _ _ k) <- last bs = [lookupBBlock lm k]-  | BlStatement _ _ _ (StGotoAssigned _ _ _ ks)   <- last bs = map (lookupBBlock lm) (aStrip ks)+  | BlStatement _ _ _ (StGotoAssigned _ _ _ ks)   <- last bs = map (lookupBBlock lm) (maybe [] aStrip ks)   | BlStatement _ _ _ (StGotoComputed _ _ ks _)   <- last bs = map (lookupBBlock lm) (aStrip ks)   | BlStatement _ _ _ (StReturn _ _ _)            <- last bs = [-1]   | BlStatement _ _ _ (StIfArithmetic _ _ _ k1 k2 k3) <- last bs =@@ -354,7 +354,7 @@   me3' <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing   perDoBlock Nothing b bs perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs-perBlock b@(BlDoWhile _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs+perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs perBlock b@(BlStatement _ _ _ (StReturn {})) =   processLabel b >> addToBBlock b >> closeBBlock_ perBlock b@(BlStatement _ _ _ (StGotoUnconditional {})) =@@ -474,7 +474,7 @@ -- Strip nested code not necessary since it is duplicated in another -- basic block. stripNestedBlocks (BlDo a s l mn tl ds _ el)     = BlDo a s l mn tl ds [] el-stripNestedBlocks (BlDoWhile a s l n e _ el)     = BlDoWhile a s l n e [] el+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

@@ -122,6 +122,7 @@   | mAttrs  <- maybe [] aStrip mAttrAList   , isArray <- any isAttrDimension mAttrs   , isParam <- any isAttrParameter mAttrs+  , isExtrn <- any isAttrExternal mAttrs   , decls   <- aStrip declAList = do     env <- gets environ     forM_ decls $ \ decl -> case decl of@@ -130,11 +131,14 @@       DeclVariable _ _ v Nothing _  -> recordType baseType cType n         where           n = varName v-          cType | isArray                                     = CTArray+          cType | isExtrn                                     = CTExternal+                | isArray                                     = CTArray                 | isParam                                     = CTParameter                 | Just (IDType _ (Just ct)) <- M.lookup n env = ct                 | otherwise                                   = CTVariable-+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@@ -232,6 +236,9 @@  isAttrParameter (AttrParameter {}) = True isAttrParameter _                  = False++isAttrExternal (AttrExternal {}) = True+isAttrExternal _                 = False  isIxSingle (IxSingle {}) = True isIxSingle _             = False

@@ -13,7 +13,7 @@ import Language.Fortran.ParserMonad (FortranVersion(..))  -data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITParam Int+data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITCharacter | ITParam Int   deriving (Show, Eq, Ord, Typeable, Generic)  data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) }@@ -51,91 +51,109 @@ func1 = ([0],[1]) func2 = ([0],[1,2]) func3 = ([0],[1,2,3])+func4 = ([0],[1,2,3,4]) funcN = func2 -- FIXME: implement arbitrary-# parameter functions  -- | name => (return-unit, parameter-units)+-- This is an exhaustive list of intrinsics listed in 15.10 of X3.9-1978 fortran77intrinsics :: IntrinsicsTable fortran77intrinsics = M.fromList-  [ ("abs"     , mkIEntry (ITParam 1)   func1)-  , ("aimag"   , mkIEntry (ITReal)      func1)-  , ("aint"    , mkIEntry (ITReal)      func1)-  , ("anint"   , mkIEntry (ITReal)      func1)-  , ("cmplx"   , mkIEntry (ITComplex)   func1)-  , ("conjg"   , mkIEntry (ITComplex)   func1)-  , ("dble"    , mkIEntry (ITDouble)    func1)-  , ("dim"     , mkIEntry (ITReal)      func1)-  , ("dprod"   , mkIEntry (ITDouble)    func1)-  , ("int"     , mkIEntry (ITInteger)   func1)-  , ("max"     , mkIEntry (ITParam 1)   funcN)-  , ("min"     , mkIEntry (ITParam 1)   funcN)-  , ("mod"     , mkIEntry (ITParam 1)   func2)-  , ("nint"    , mkIEntry (ITInteger)   func1)-  , ("real"    , mkIEntry (ITReal)      func1)-  , ("sign"    , mkIEntry (ITParam 1)   func2)+  [ ("int"     , mkIEntry ITInteger func1)+  , ("ifix"    , mkIEntry ITInteger func1)+  , ("idint"   , mkIEntry ITInteger func1)+  , ("real"    , mkIEntry ITReal func1)+  , ("float"   , mkIEntry ITReal func1)+  , ("sngl"    , mkIEntry ITReal func1)+  , ("dble"    , mkIEntry ITDouble func1)+  , ("cmplx"   , mkIEntry ITComplex func1)+  , ("ichar"   , mkIEntry ITInteger func1)+  , ("char"    , mkIEntry ITCharacter func1)+  , ("aint"    , mkIEntry (ITParam 1) func1)+  , ("dint"    , mkIEntry ITDouble func1)+  , ("anint"   , mkIEntry (ITParam 1) func1)+  , ("dnint"   , mkIEntry ITDouble func1)+  , ("nint"    , mkIEntry (ITParam 1) func1)+  , ("idnint"  , mkIEntry ITDouble func1)+  , ("abs"     , mkIEntry (ITParam 1) func1)+  , ("iabs"    , mkIEntry ITInteger func1)+  , ("dabs"    , mkIEntry ITDouble func1)+  , ("cabs"    , mkIEntry ITComplex func1)+  , ("mod"     , mkIEntry (ITParam 1) func2)+  , ("amod"    , mkIEntry ITReal func2)+  , ("dmod"    , mkIEntry ITDouble func2)+  , ("sign"    , mkIEntry (ITParam 1) func2)+  , ("isign"   , mkIEntry ITInteger func2)+  , ("dsign"   , mkIEntry ITDouble func2)+  , ("dim"     , mkIEntry (ITParam 1) func2)+  , ("idim"    , mkIEntry ITInteger func2)+  , ("ddim"    , mkIEntry ITDouble func2)+  , ("dprod"   , mkIEntry ITDouble func2)+  , ("max"     , mkIEntry (ITParam 1) funcN)+  , ("max0"    , mkIEntry ITInteger funcN)+  , ("amax1"   , mkIEntry ITReal funcN)+  , ("dmax1"   , mkIEntry ITDouble funcN)+  , ("amax0"   , mkIEntry ITReal funcN)+  , ("max1"    , mkIEntry ITInteger funcN)+  , ("min"     , mkIEntry (ITParam 1) funcN)+  , ("min0"    , mkIEntry ITInteger funcN)+  , ("amin1"   , mkIEntry ITReal funcN)+  , ("dmin1"   , mkIEntry ITDouble funcN)+  , ("amin0"   , mkIEntry ITReal funcN)+  , ("min1"    , mkIEntry ITInteger funcN)+  , ("len"     , mkIEntry ITInteger func1)+  , ("index"   , mkIEntry ITInteger func2)+  , ("aimag"   , mkIEntry ITReal func1)+  , ("conjg"   , mkIEntry ITComplex func1)+  , ("sqrt"    , mkIEntry (ITParam 1) func1)+  , ("dsqrt"   , mkIEntry ITDouble func1)+  , ("csqrt"   , mkIEntry ITComplex func1)+  , ("exp"     , mkIEntry (ITParam 1) func1)+  , ("dexp"    , mkIEntry ITDouble func1)+  , ("cexp"    , mkIEntry ITComplex func1)+  , ("log"     , mkIEntry (ITParam 1) func1)+  , ("alog"    , mkIEntry ITReal func1)+  , ("dlog"    , mkIEntry ITDouble func1)+  , ("clog"    , mkIEntry ITComplex func1)+  , ("log10"   , mkIEntry (ITParam 1) func1)+  , ("alog10"  , mkIEntry ITReal func1)+  , ("dlog10"  , mkIEntry ITDouble func1)+  , ("sin"     , mkIEntry (ITParam 1) func1)+  , ("dsin"    , mkIEntry ITDouble func1)+  , ("csin"    , mkIEntry ITComplex func1)+  , ("cos"     , mkIEntry (ITParam 1) func1)+  , ("dcos"    , mkIEntry ITDouble func1)+  , ("ccos"    , mkIEntry ITComplex func1)+  , ("tan"     , mkIEntry (ITParam 1) func1)+  , ("dtan"    , mkIEntry ITDouble func1)+  , ("asin"    , mkIEntry (ITParam 1) func1)+  , ("dasin"   , mkIEntry ITDouble func1)+  , ("acos"    , mkIEntry (ITParam 1) func1)+  , ("dacos"   , mkIEntry ITDouble func1)+  , ("atan"    , mkIEntry (ITParam 1) func1)+  , ("datan"   , mkIEntry ITDouble func1)+  , ("atan2"   , mkIEntry (ITParam 1) func2)+  , ("datan2"  , mkIEntry ITDouble func2)+  , ("sinh"    , mkIEntry (ITParam 1) func1)+  , ("dsinh"   , mkIEntry ITDouble func1)+  , ("cosh"    , mkIEntry (ITParam 1) func1)+  , ("dcosh"   , mkIEntry ITDouble func1)+  , ("tanh"    , mkIEntry (ITParam 1) func1)+  , ("dtanh"   , mkIEntry ITDouble func1)+  , ("lge"     , mkIEntry ITLogical func2)+  , ("lgt"     , mkIEntry ITLogical func2)+  , ("lle"     , mkIEntry ITLogical func2)+  , ("llt"     , mkIEntry ITLogical func2)+  -- https://gcc.gnu.org/onlinedocs/gfortran/Argument-list-functions.html+  , ("%loc", mkIEntry (ITParam 1) func1)+  , ("%ref", mkIEntry (ITParam 1) func1)+  , ("%val", mkIEntry (ITParam 1) func1)   ]  fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList-  [ ("iabs"    , mkIEntry (ITInteger)   func1)-  , ("dabs"    , mkIEntry (ITDouble)    func1)-  , ("cabs"    , mkIEntry (ITComplex)   func1)-  , ("dint"    , mkIEntry (ITDouble)    func1)-  , ("dnint"   , mkIEntry (ITDouble)    func1)-  , ("idnint"  , mkIEntry (ITInteger)   func1)-  , ("ifix"    , mkIEntry (ITInteger)   func1)-  , ("idint"   , mkIEntry (ITInteger)   func1)-  , ("min0"    , mkIEntry (ITInteger)   funcN)-  , ("amin1"   , mkIEntry (ITReal)      funcN)-  , ("dmin1"   , mkIEntry (ITDouble)    funcN)-  , ("amin0"   , mkIEntry (ITReal)      funcN)-  , ("min1"    , mkIEntry (ITInteger)   funcN)-  , ("amod"    , mkIEntry (ITReal)      func2)-  , ("dmod"    , mkIEntry (ITDouble)    func2)-  , ("float"   , mkIEntry (ITReal)      func1)-  , ("sngl"    , mkIEntry (ITReal)      func1)-  , ("isign"   , mkIEntry (ITInteger)   func2)-  , ("dsign"   , mkIEntry (ITDouble)    func2)-  , ("present" , mkIEntry (ITLogical)   func1)-  , ("sqrt"    , mkIEntry (ITParam 1)   func1)-  , ("dsqrt"   , mkIEntry (ITDouble)    func1)-  , ("csqrt"   , mkIEntry (ITComplex)   func1)-  , ("exp"     , mkIEntry (ITParam 1)   func1)-  , ("dexp"    , mkIEntry (ITDouble)    func1)-  , ("cexp"    , mkIEntry (ITComplex)   func1)-  , ("log"     , mkIEntry (ITParam 1)   func1)-  , ("alog"    , mkIEntry (ITReal)      func1)-  , ("dlog"    , mkIEntry (ITDouble)    func1)-  , ("clog"    , mkIEntry (ITComplex)   func1)-  , ("log10"   , mkIEntry (ITParam 1)   func1)-  , ("alog10"  , mkIEntry (ITReal)      func1)-  , ("dlog10"  , mkIEntry (ITDouble)    func1)-  , ("idim"    , mkIEntry (ITInteger)   func2)-  , ("ddim"    , mkIEntry (ITDouble)    func2)-  , ("sin"     , mkIEntry (ITReal)      func1)-  , ("dsin"    , mkIEntry (ITDouble)    func1)-  , ("csin"    , mkIEntry (ITComplex)   func1)-  , ("cos"     , mkIEntry (ITReal)      func1)-  , ("dcos"    , mkIEntry (ITDouble)    func1)-  , ("ccos"    , mkIEntry (ITComplex)   func1)-  , ("tan"     , mkIEntry (ITReal)      func1)-  , ("dtan"    , mkIEntry (ITDouble)    func1)-  , ("asin"    , mkIEntry (ITReal)      func1)-  , ("dasin"   , mkIEntry (ITDouble)    func1)-  , ("acos"    , mkIEntry (ITReal)      func1)-  , ("dacos"   , mkIEntry (ITDouble)    func1)-  , ("atan"    , mkIEntry (ITReal)      func1)-  , ("datan"   , mkIEntry (ITDouble)    func1)-  , ("atan2"   , mkIEntry (ITReal)      func2)-  , ("datan2"  , mkIEntry (ITDouble)    func2)-  , ("sinh"    , mkIEntry (ITReal)      func1)-  , ("dsinh"   , mkIEntry (ITDouble)    func1)-  , ("cosh"    , mkIEntry (ITReal)      func1)-  , ("dcosh"   , mkIEntry (ITDouble)    func1)-  , ("tanh"    , mkIEntry (ITReal)      func1)-  , ("dtanh"   , mkIEntry (ITDouble)    func1)+  [ ("present" , mkIEntry (ITLogical)   func1)   , ("modulo"  , mkIEntry (ITParam 1)   func2)   , ("ceiling" , mkIEntry (ITParam 1)   func1)-  , ("floor"   , mkIEntry (ITParam 1)   func1)   , ("iand"    , mkIEntry (ITInteger)   func2)   , ("ior"     , mkIEntry (ITInteger)   func2)   , ("ieor"    , mkIEntry (ITInteger)   func2)@@ -146,4 +164,27 @@   , ("ishftc"  , mkIEntry (ITInteger)   func3)   , ("btest"   , mkIEntry (ITInteger)   func2)   , ("not"     , mkIEntry (ITInteger)   func1)+  , ("dot_product"  , mkIEntry (ITParam 1)   func2)+  , ("matmul"       , mkIEntry (ITParam 1)   func2)+  , ("all"          , mkIEntry ITLogical     func2)+  , ("any"          , mkIEntry ITLogical     func2)+  , ("count"        , mkIEntry ITInteger     func2)+  , ("maxval"       , mkIEntry (ITParam 1)   func3)+  , ("minval"       , mkIEntry (ITParam 1)   func3)+  , ("product"      , mkIEntry (ITParam 1)   func3)+  , ("sum"          , mkIEntry (ITParam 1)   func3)+  , ("allocated"    , mkIEntry ITLogical     func1)+  , ("lbound"       , mkIEntry ITInteger     func2)+  , ("ubound"       , mkIEntry ITInteger     func2)+  , ("shape"        , mkIEntry ITInteger     func1)+  , ("size"         , mkIEntry ITInteger     func2)+  , ("merge"        , mkIEntry ITInteger     func3)+  , ("pack"         , mkIEntry (ITParam 3)   func3)+  , ("spread"       , mkIEntry (ITParam 1)   func3)+  , ("unpack"       , mkIEntry (ITParam 3)   func3)+  , ("reshape"      , mkIEntry (ITParam 1)   func4)+  , ("eoshift"      , mkIEntry (ITParam 1)   func4)+  , ("transpose"    , mkIEntry (ITParam 1)   func1)+  , ("maxloc"       , mkIEntry (ITParam 1)   func2)+  , ("minloc"       , mkIEntry (ITParam 1)   func2)   ]

@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Language.Fortran.LValue where++import           Data.Data+import           GHC.Generics                          (Generic)++import           Language.Fortran.AST+import           Language.Fortran.Util.FirstParameter+import           Language.Fortran.Util.Position+import           Language.Fortran.Util.SecondParameter++-- | A subset of 'Expression' which can only contain values that can be assigned+-- to.+data LValue a+  = LvSimpleVar a SrcSpan Name+  | LvSubscript a SrcSpan (LValue a) (AList Index a)+  | LvDataRef a SrcSpan (LValue a) (LValue a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+++-- | If the expression can be seen as an lvalue, convert it to an 'LValue'.+toLValue :: Expression a -> Maybe (LValue a)+toLValue (ExpValue ann sp (ValVariable nm)) = Just (LvSimpleVar ann sp nm)+toLValue (ExpSubscript ann sp exp ixs) = LvSubscript ann sp <$> toLValue exp <*> pure ixs+toLValue (ExpDataRef ann sp lhs rhs) = LvDataRef ann sp <$> toLValue lhs <*> toLValue rhs+toLValue _ = Nothing++instance FirstParameter (LValue a) a+instance SecondParameter (LValue a) SrcSpan++instance Annotated LValue+instance Spanned (LValue a)

@@ -1,5 +1,6 @@ -- -*- Mode: Haskell -*- {+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -7,12 +8,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -module Language.Fortran.Lexer.FixedForm where+module Language.Fortran.Lexer.FixedForm+  ( lexer, initParseState, collectFixedTokens, collectFixedTokensSafe+  , Token(..), LexAction, AlexInput(..), lexemeMatch, lexN+  ) where  import Data.Word (Word8)-import Data.Char (toLower, ord)+import Data.Char (toLower, ord, isDigit) import Data.List (isPrefixOf, any)-import Data.Maybe (fromJust, isNothing)+import Data.Maybe (fromJust, isNothing, isJust) import Data.Data import qualified Data.Bits import qualified Data.ByteString.Char8 as B@@ -29,6 +33,14 @@ }  $digit = [0-9]+$octalDigit = 0-7+$hexDigit = [a-f $digit]+$bit = 0-1++@binary = b\'$bit+\' | \'$bit+\'b+@octal = o\'$octalDigit+\' | \'$octalDigit+\'o+@hex = x\'$hexDigit+\' | \'$hexDigit+\'x | z\'$hexDigit+\' | \'$hexDigit+\'z+ $letter = [a-z] $alphanumeric = [$letter $digit] $alphanumericExtended = [$letter $digit \_]@@ -38,13 +50,18 @@ -- programs out there. @idExtended = $letter $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended? @id = $letter $alphanumeric{0,5}-@label = [1-9] $digit{0,4}+@label = $digit{1,5} +@idLegacy = [$letter \_ \%] [$alphanumericExtended \$]*+ @datatype = "integer" | "real" | "doubleprecision" | "complex" | "logical"+          -- legacy extensions+          | "byte"  -- Numbers @integerConst = $digit+ -- Integer constant @posIntegerConst = [1-9] $digit*+@bozLiteralConst = (@binary|@octal|@hex)  -- For reals @exponent = [ed] [\+\-]? @integerConst@@ -56,44 +73,63 @@ tokens :-    <0> [c!\*d] / { commentP }                  { lexComment Nothing }+  "!" / { bangCommentP &&& legacy77P }        { lexComment Nothing }   <0> @label / { withinLabelColsP }           { addSpanAndMatch TLabel }   <0> . / { \_ ai _ _ -> atColP 6 ai }        { toSC keyword }   <0> " "                                     ; -  <0,st,keyword,iif> \n                       { resetPar >> toSC 0 >> addSpan TNewline }-  <0,st,keyword,iif> \r                       ;+  <0,st,keyword,iif,assn,doo> \n              { resetPar >> toSC 0 >> addSpan TNewline }+  <0,st,keyword,iif,assn,doo> \r              ;+  <0,st,keyword,iif,assn,doo> ";"             { resetPar >> toSC keyword >> addSpan TNewline }    <st> "("                                    { addSpan TLeftPar }+  <keyword> "(" / { legacy77P }               { addSpan TLeftPar }   <iif> "("                                   { incPar >> addSpan TLeftPar }   <st> ")"                                    { addSpan TRightPar }+  <keyword> ")" / { legacy77P }               { typeSCChange >> addSpan TRightPar }   <iif> ")"                                   { maybeToKeyword >> addSpan TRightPar }   <st,iif> "(/" / { formatExtendedP }         { addSpan TLeftArrayPar }   <st,iif> "/)" / { formatExtendedP }         { addSpan TRightArrayPar }-  <st,iif,keyword> ","                        { addSpan TComma }-  <st,iif> "."                                { addSpan TDot }+  <st,iif,doo,keyword> ","                    { addSpan TComma }+  <st,iif,keyword> "."                        { addSpan TDot }+  <keyword> "." / { legacy77P }               { addSpan TDot }   <st,iif> ":" / { fortran77P }               { addSpan TColon }    <keyword> @id / { idP }                     { toSC st >> addSpanAndMatch TId }   <keyword> @idExtended / { extendedIdP }     { toSC st >> addSpanAndMatch TId }+  <keyword> @idLegacy / { legacyIdP }         { toSC st >> addSpanAndMatch TId }    <keyword> "include" / { extended77P }       { toSC st >> addSpan TInclude }    -- Tokens related to procedures and subprograms   <keyword> "program"                         { toSC st >> addSpan TProgram }-  <keyword> "function"                        { toSC st >> addSpan TFunction  }+  <keyword> "function" / { functionP }        { toSC st >> addSpan TFunction  }   <keyword> "subroutine"                      { toSC st >> addSpan TSubroutine  }   <keyword> "blockdata"                       { toSC st >> addSpan TBlockData  }+  <keyword> "structure"    / { legacy77P }    { toSC st >> addSpan TStructure  }+  <keyword> "union"        / { legacy77P }    { toSC st >> addSpan TUnion  }+  <keyword> "map"          / { legacy77P }    { toSC st >> addSpan TMap  }+  <keyword> "endstructure" / { legacy77P }    { toSC st >> addSpan TEndStructure  }+  <keyword> "endunion"     / { legacy77P }    { toSC st >> addSpan TEndUnion  }+  <keyword> "endmap"       / { legacy77P }    { toSC st >> addSpan TEndMap  }+  <keyword> "record"       / { legacy77P }    { toSC st >> addSpan TRecord  }   <keyword> "end"                             { toSC st >> addSpan TEnd  }+  <keyword> "endprogram"    / { legacy77P }   { toSC st >> addSpan TEndProgram  }+  <keyword> "endfunction"   / { legacy77P }   { toSC st >> addSpan TEndFunction  }+  <keyword> "endsubroutine" / { legacy77P }   { toSC st >> addSpan TEndSubroutine  }    -- Tokens related to assignment statements-  <keyword> "assign"                          { toSC st >> addSpan TAssign  }+  <keyword> "assign"                          { toSC assn >> addSpan TAssign  }+  <assn> @integerConst                        { addSpanAndMatch TInt }+  <assn> "to"                                 { addSpan TTo  }+  <assn> @id / { notToP }             { addSpanAndMatch TId }+  <assn> @idExtended / { notToP &&& extended77P } { addSpanAndMatch TId }+  <assn> @idLegacy / { notToP &&& legacy77P } { addSpanAndMatch TId }   <st,iif> "="                                { addSpan TOpAssign  }-  <st> "to"                                   { addSpan TTo  }    -- Tokens related to control statements   <keyword> "goto"                            { toSC st >> addSpan TGoto  }-  <keyword> "if"                              { toSC iif >> addSpan TIf  }-  <st> "if" / { fortran77P }                  { toSC iif >> addSpan TIf  }+  <keyword> "if" / { ifP }                    { toSC iif >> addSpan TIf  }   <st,keyword> "then" / { fortran77P }        { toSC keyword >> addSpan TThen  }   <keyword> "else" / {fortran77P }            { addSpan TElse  }   <keyword> "elseif" / {fortran77P }          { toSC st >> addSpan TElsif  }@@ -104,10 +140,20 @@   <keyword> "continue"                        { toSC st >> addSpan TContinue  }   <keyword> "stop"                            { toSC st >> addSpan TStop  }   <keyword> "exit" / { extended77P }          { toSC st >> addSpan TExit  }+  <keyword> "cycle" / { legacy77P }           { toSC st >> addSpan TCycle  }+  <keyword> "case" / { legacy77P }            { toSC st >> addSpan TCase  }+  <keyword> "casedefault" / { legacy77P }     { toSC st >> addSpan TCaseDefault  }+  <keyword> "selectcase" / { legacy77P }      { toSC st >> addSpan TSelectCase  }+  <keyword> "endselect" / { legacy77P }       { toSC st >> addSpan TEndSelect  }   <keyword> "pause"                           { toSC st >> addSpan TPause  }-  <keyword> "do"                              { toSC st >> addSpan TDo }   <keyword> "dowhile" / { extended77P }       { toSC st >> addSpan TDoWhile }   <keyword> "enddo" / { extended77P }         { toSC st >> addSpan TEndDo  }+  <keyword> "do"                              { toSC doo >> addSpan TDo }+  <doo> @integerConst                         { addSpanAndMatch TInt }+  <doo> "while" / { extended77P }             { toSC st >> addSpan TWhile }+  <doo> @id                                   { toSC st >> addSpanAndMatch TId }+  <doo> @idExtended / { extended77P }         { toSC st >> addSpanAndMatch TId }+  <doo> @idLegacy / { legacy77P }             { toSC st >> addSpanAndMatch TId }    -- Tokens related to I/O statements   <keyword> "read"                            { toSC st >> addSpan TRead  }@@ -119,6 +165,7 @@   <keyword> "open" / { fortran77P }           { toSC st >> addSpan TOpen  }   <keyword> "close" / { fortran77P }          { toSC st >> addSpan TClose  }   <keyword> "print" / { fortran77P }          { toSC st >> addSpan TPrint  }+  <keyword> "type" / { legacy77P }            { toSC st >> addSpan TTypePrint  }    -- Tokens related to non-executable statements @@ -130,29 +177,36 @@   <keyword> "intrinsic" / { fortran77P }      { toSC st >> addSpan TIntrinsic  }   <keyword> @datatype                         { typeSCChange >> addSpanAndMatch TType }   <st> @datatype / { implicitStP }            { addSpanAndMatch TType }+   <keyword> "doublecomplex" / { extended77P } { typeSCChange >> addSpanAndMatch TType }   <st> "doublecomplex" / { implicitTypeExtendedP }  { addSpanAndMatch TType }-  <keyword> "character" / { fortran77P }      { toSC st >> addSpanAndMatch TType }+  <keyword> "character" / { fortran77P }      { typeSCChange >> addSpanAndMatch TType }   <st> "character" / { implicitType77P }      { addSpanAndMatch TType }   <keyword> "implicit" / { fortran77P }       { toSC st >> addSpan TImplicit  }-  <st> "none" / { fortran77P }                { addSpan TNone  }+  <st> "none" / { implicitType77P }           { addSpan TNone  }   <keyword> "parameter" / { fortran77P }      { toSC st >> addSpan TParameter  }   <keyword> "entry" / { fortran77P }          { toSC st >> addSpan TEntry  }+  <keyword> "pointer" / { legacy77P }         { toSC st >> addSpan TPointer  }    -- Tokens related to data initalization statement   <keyword> "data"                            { toSC st >> addSpan TData  }+  <keyword> "automatic" / { legacy77P }       { toSC st >> addSpan TAutomatic  }    -- Tokens related to format statement-  <keyword> "format"                          { toSC st >> addSpan TFormat  }-  <st> "(".*")" / { formatP }                 { addSpanAndMatch TBlob }+  <keyword> "format"                          { toSC fmt >> enterFormat >> addSpan TFormat  }+  <fmt> "(".*")"                              { toSC st >> exitFormat >> addSpanAndMatch TBlob }    -- Tokens needed to parse integers, reals, double precision and complex   -- constants   <st,iif> @exponent / { exponentP }          { addSpanAndMatch TExponent }-  <st,iif,keyword> @integerConst              { addSpanAndMatch TInt }+  <st,iif> @integerConst                      { addSpanAndMatch TInt }+    -- can be part (end) of function type declaration+  <keyword> @integerConst                     { typeSCChange >> addSpanAndMatch TInt }+  <st,iif,keyword> @bozLiteralConst / { legacy77P } { addSpanAndMatch TBozInt }    -- String-  <st,iif> \' / { fortran77P }                { strAutomaton 0 }+  <st,iif> \' / { fortran77P }                { strAutomaton '\'' 0 }+  <st,iif> \" / { legacy77P }                 { strAutomaton '"'  0 }    -- Logicals   <st,iif> (".true."|".false.")               { addSpanAndMatch TBool  }@@ -162,12 +216,16 @@   <st,iif> "-"                                { addSpan TOpMinus  }   <st,iif> "**"                               { addSpan TOpExp  }   <st,iif> "*"                                { addSpan TStar  }+    -- can be part of function type declaration+  <keyword> "*" / { legacy77P }               { addSpan TStar  }   <st,iif> "/"                                { addSpan TSlash  }+  <st,iif> "&" / { legacy77P }                { addSpan TAmpersand  }    -- Logical operators   <st,iif> ".or."                             { addSpan TOpOr  }   <st,iif> ".and."                            { addSpan TOpAnd  }   <st,iif> ".not."                            { addSpan TOpNot  }+  <st,iif> ".xor." / { legacy77P }            { addSpan TOpXOr  }   <st,iif> ".eqv." / { fortran77P }           { addSpan TOpEquivalent  }   <st,iif> ".neqv." / { fortran77P }          { addSpan TOpNotEquivalent  } @@ -175,7 +233,7 @@   <st,iif> "<" / { extended77P }              { addSpan TOpLT  }   <st,iif> "<=" / { extended77P }             { addSpan TOpLE  }   <st,iif> "==" / { extended77P }             { addSpan TOpEQ  }-  <st,iif> "!=" / { extended77P }             { addSpan TOpNE  }+  <st,iif> "/=" / { extended77P }             { addSpan TOpNE  }   <st,iif> ">" / { extended77P }              { addSpan TOpGT  }   <st,iif> ">=" / { extended77P }             { addSpan TOpGE  }   <st,iif> ".lt."                             { addSpan TOpLT  }@@ -188,9 +246,11 @@   -- ID   <st,iif> @id                                { addSpanAndMatch TId }   <st,iif> @idExtended / { extended77P }      { addSpanAndMatch TId }+  <st,iif> @idLegacy / { legacy77P }          { addSpanAndMatch TId }    -- Strings   <st> @posIntegerConst "h" / { fortran66P }  { lexHollerith }+  <st,iif> @posIntegerConst "h" / { hollerithP &&& legacy77P } { lexHollerith }  { @@ -198,13 +258,13 @@ -- Predicated lexer helpers -------------------------------------------------------------------------------- -formatP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-formatP _ _ _ ai-  | Just TFormat{} <- aiPreviousToken ai = True-  | otherwise = False+(&&&) :: (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+f &&& g = \ fv ai1 i ai2 -> f fv ai1 i ai2 && g fv ai1 i ai2  formatExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-formatExtendedP fv _ _ ai = fv == Fortran77Extended &&+formatExtendedP fv _ _ ai = fv `elem` [Fortran77Extended, Fortran77Legacy] &&   case xs of     [ TFormat _, _ ] -> False     [ TLabel _ _, TFormat _ ] -> False@@ -225,14 +285,18 @@     f _ = False  extendedIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-extendedIdP fv a b ai = fv == Fortran77Extended && idP fv a b ai+extendedIdP fv a b ai = fv `elem` [Fortran77Extended, Fortran77Legacy] && idP fv a b ai +legacyIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+legacyIdP fv a b ai = fv == Fortran77Legacy && idP fv a b ai+ idP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-idP fv _ _ ai = not (doP fv ai) && equalFollowsP fv ai+idP fv ao i ai = not (doP fv ai) && not (ifP fv ao i ai)+             && (equalFollowsP fv ai || rParFollowsP fv ai)  doP :: FortranVersion -> AlexInput -> Bool doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) &&-    case unParse (lexer $ f) ps of+    case unParse (lexer $ f 0) ps of       ParseOk True _ -> True       _ -> False   where@@ -242,13 +306,62 @@       , psFilename = "<unknown>"       , psParanthesesCount = ParanthesesCount 0 False       , psContext = [ ConStart ] }-    f t =+    f 0 t =       case t of         TNewline{} -> return False         TEOF{} -> return False+        TLeftPar{} -> lexer $ f 1         TComma{} -> return True-        _ -> lexer f+        _ -> lexer $ f 0+    f !n t =+      case t of+        TLeftPar{} -> lexer $ f (n+1)+        TRightPar{} -> lexer $ f (n-1)+        _ -> lexer $ f n +ifP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+ifP fv _ _ ai = "if" == (reverse . lexemeMatch . aiLexeme $ ai) &&+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        -- IF is always followed by (+        TLeftPar{} -> return True+        _ -> return False++functionP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+functionP fv _ _ ai = "function" == (reverse . lexemeMatch . aiLexeme $ ai) &&+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        -- a function keyword should be followed by the name and a left paren+        TId{} -> lexer f+        TLeftPar{} -> return True+        _ -> return False++hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+hollerithP fv _ _ ai = isDigit (lookBack 2 ai)++notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+notToP fv _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai)+ equalFollowsP :: FortranVersion -> AlexInput -> Bool equalFollowsP fv ai =     case unParse (lexer $ f False 0) ps of@@ -267,10 +380,15 @@         TEOF{} -> return False         TOpAssign{} -> return True         TLeftPar{} -> lexer $ f True 1+        TDot{} -> lexer $ f False 0+        TId{} -> lexer $ f False 0         _ -> return False     f True 0 t =       case t of         TOpAssign{} -> return True+        TDot{} -> lexer $ f True 0+        TId{} -> lexer $ f True 0+        TLeftPar{} -> lexer $ f True 1         _ -> return False     f True n t =       case t of@@ -280,11 +398,33 @@         TRightPar{} -> lexer $ f True (n - 1)         _ -> lexer $ f True n +rParFollowsP :: FortranVersion -> AlexInput -> Bool+rParFollowsP fv ai =+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        TRightPar{} -> return True+        _ -> return False+ commentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool commentP _ aiOld _ aiNew = atColP 1 aiOld && _endsWithLine   where     _endsWithLine = (posColumn . aiPosition) aiNew /= 1 +bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+bangCommentP fv aiOld i aiNew = _endsWithLine+  where+    _endsWithLine = (posColumn . aiPosition) aiNew /= 1+ withinLabelColsP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool withinLabelColsP _ aiOld _ aiNew = getCol aiOld >= 1 && getCol aiNew <= 6   where@@ -299,20 +439,26 @@ -- as an exponent token. exponentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool exponentP _ _ _ ai =-  case aiPreviousToken ai of-    Just (TInt _ _) -> True-    Just (TDot _) -> True+  case aiPreviousTokensInLine ai of+    -- real*8 d8 is not an exponent+    TInt{} : TStar{} : TType{} : _ -> False+    TInt{} : _ -> True+    TDot{} : _ -> True     _ -> False  fortran66P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool fortran66P fv _ _ _ = fv == Fortran66  fortran77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended+fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended || fv == Fortran77Legacy  extended77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-extended77P fv _ _ _ = fv == Fortran77Extended+extended77P fv _ _ _ = fv == Fortran77Extended || fv == Fortran77Legacy +legacy77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+legacy77P fv _ _ _ = fv == Fortran77Legacy++ -------------------------------------------------------------------------------- -- Lexer helpers --------------------------------------------------------------------------------@@ -362,6 +508,26 @@   ai <- getAlex   putAlex $ ai { aiWhiteSensitiveCharCount = 0 } +setCaseSensitive :: LexAction ()+setCaseSensitive = do+  ai <- getAlex+  putAlex $ ai { aiCaseSensitive = True }++setCaseInsensitive :: LexAction ()+setCaseInsensitive = do+  ai <- getAlex+  putAlex $ ai { aiCaseSensitive = False }++enterFormat :: LexAction ()+enterFormat = do+  ai <- getAlex+  putAlex $ ai { aiInFormat = True }++exitFormat :: LexAction ()+exitFormat = do+  ai <- getAlex+  putAlex $ ai { aiInFormat = False }+ instance Spanned Lexeme where   getSpan lexeme =     let ms = lexemeStart lexeme@@ -402,11 +568,18 @@   m <- getMatch   s <- getLexemeSpan   alex <- getAlex+  version <- getVersion+  let emitComment = case version of+                      Fortran77Legacy+                        -> return Nothing+                      _ -> return $ Just $ TComment s $ tail m   let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 }   case mc of-    Just '\n' -> return $ Just $ TComment s $ tail m+    Just '\n' -> emitComment     Just _ ->       case alexGetByte modifiedAlex of+        Just (w, _) | fromIntegral w == ord '\n' -> do+          emitComment         Just (_, newAlex) -> do           putAlex newAlex           lexComment Nothing@@ -414,7 +587,7 @@     Nothing ->       case alexGetByte modifiedAlex of         Just (_, newAlex) -> lexComment (Just $ (head . lexemeMatch . aiLexeme) newAlex)-        Nothing -> return $ Just $ TComment s $ tail m+        Nothing -> emitComment   {-@@ -436,37 +609,39 @@        +-------------+             Chars -}-strAutomaton :: Int -> LexAction (Maybe Token)-strAutomaton 0 = do+strAutomaton :: Char -> Int -> LexAction (Maybe Token)+strAutomaton c 0 = do+  setCaseSensitive   incWhiteSensitiveCharCount   alex <- getAlex   case alexGetByte alex of     Just (_, newAlex) -> do       putAlex newAlex       m <- getMatch-      if last m == '\''-      then strAutomaton 1-      else strAutomaton 0-    Nothing -> strAutomaton 3-strAutomaton 1 = do+      if last m == c+      then strAutomaton c 1+      else strAutomaton c 0+    Nothing -> strAutomaton c 3+strAutomaton c 1 = do   incWhiteSensitiveCharCount   alex <- getAlex   case alexGetByte alex of     Just (_, newAlex) -> do       let m = lexemeMatch . aiLexeme $ newAlex-      if head m == '\''+      if head m == c       then do         putAlex newAlex         putMatch $ reverse . tail $ m-        strAutomaton 0-      else strAutomaton 2-    Nothing -> strAutomaton 2-strAutomaton 2 = do+        strAutomaton c 0+      else strAutomaton c 2+    Nothing -> strAutomaton c 2+strAutomaton c 2 = do   s <- getLexemeSpan   m <- getMatch   resetWhiteSensitiveCharCount+  setCaseInsensitive   return $ Just $ TString s $ (init . tail) m-strAutomaton 3 = fail "Unmatched string."+strAutomaton c 3 = fail "Unmatched string."  lexHollerith :: LexAction (Maybe Token) lexHollerith = do@@ -490,10 +665,14 @@   then return $ Just match'   else     case alexGetByte alex of+      Just (w, newAlex) | fromIntegral w == ord '\n' -> do+        return . Just $! pad match'       Just (_, newAlex) -> do         putAlex newAlex         lexN n       Nothing -> return Nothing+ where+  pad s = s ++ replicate (n - length s) ' '  maybeToKeyword :: LexAction (Maybe Token) maybeToKeyword = do@@ -513,6 +692,11 @@   else toSC st   where     f TFunction{} = return True+      -- can be part of function type declaration+    f TLeftPar{} = lexer f+    f TRightPar{} = lexer f+    f TStar{} = lexer f+    f TInt{} = lexer f     f _ = return False  toSC :: Int -> LexAction (Maybe Token)@@ -539,6 +723,16 @@            | TFunction            SrcSpan            | TSubroutine          SrcSpan            | TBlockData           SrcSpan+           | TStructure           SrcSpan+           | TRecord              SrcSpan+           | TUnion               SrcSpan+           | TMap                 SrcSpan+           | TEndProgram          SrcSpan+           | TEndFunction         SrcSpan+           | TEndSubroutine       SrcSpan+           | TEndStructure        SrcSpan+           | TEndUnion            SrcSpan+           | TEndMap              SrcSpan            | TEnd                 SrcSpan            | TAssign              SrcSpan            | TOpAssign            SrcSpan@@ -554,10 +748,16 @@            | TSave                SrcSpan            | TContinue            SrcSpan            | TStop                SrcSpan+           | TCycle               SrcSpan            | TExit                SrcSpan+           | TCase                SrcSpan+           | TCaseDefault         SrcSpan+           | TSelectCase          SrcSpan+           | TEndSelect           SrcSpan            | TPause               SrcSpan            | TDo                  SrcSpan            | TDoWhile             SrcSpan+           | TWhile               SrcSpan            | TEndDo               SrcSpan            | TRead                SrcSpan            | TWrite               SrcSpan@@ -568,9 +768,11 @@            | TOpen                SrcSpan            | TClose               SrcSpan            | TPrint               SrcSpan+           | TTypePrint           SrcSpan            | TDimension           SrcSpan            | TCommon              SrcSpan            | TEquivalence         SrcSpan+           | TPointer             SrcSpan            | TExternal            SrcSpan            | TIntrinsic           SrcSpan            | TType                SrcSpan String@@ -579,9 +781,11 @@            | TNone                SrcSpan            | TParameter           SrcSpan            | TData                SrcSpan+           | TAutomatic           SrcSpan            | TFormat              SrcSpan            | TBlob                SrcSpan String            | TInt                 SrcSpan String+           | TBozInt              SrcSpan String            | TExponent            SrcSpan String            | TBool                SrcSpan String            | TOpPlus              SrcSpan@@ -589,8 +793,10 @@            | TOpExp               SrcSpan            | TStar                SrcSpan            | TSlash               SrcSpan+           | TAmpersand           SrcSpan            | TOpOr                SrcSpan            | TOpAnd               SrcSpan+           | TOpXOr               SrcSpan            | TOpNot               SrcSpan            | TOpEquivalent        SrcSpan            | TOpNotEquivalent     SrcSpan@@ -645,6 +851,9 @@   , aiStartCode                 :: Int   , aiPreviousToken             :: Maybe Token   , aiPreviousTokensInLine      :: [ Token ]+  , aiCaseSensitive             :: Bool+  , aiInFormat                  :: Bool+  , aiFortranVersion            :: FortranVersion   } deriving (Show)  instance Loc AlexInput where@@ -666,7 +875,11 @@   , aiWhiteSensitiveCharCount = 6   , aiStartCode = 0   , aiPreviousToken = Nothing-  , aiPreviousTokensInLine = [ ] }+  , aiPreviousTokensInLine = [ ]+  , aiCaseSensitive = False+  , aiInFormat = False+  , aiFortranVersion = Fortran77+  }  updateLexeme :: Maybe Char -> Position -> AlexInput -> AlexInput updateLexeme maybeChar p ai =@@ -674,10 +887,11 @@       match = lexemeMatch lexeme       newMatch =         case maybeChar of-          Just c -> toLower c : match+          Just c -> c : match           Nothing -> match       start = lexemeStart lexeme-      newStart = if isNothing start then Just p else start+                 -- skipping should not start a new lexeme+      newStart = if isNothing start && isJust maybeChar then Just p else start       newEnd = Just p in     ai { aiLexeme = Lexeme newMatch newStart newEnd } @@ -685,7 +899,7 @@ -- Definitions needed for alexScanUser -------------------------------------------------------------------------------- -data Move = Continuation | Char | Newline+data Move = Continuation | Char | Newline | NewlineComment | Comment  alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte ai@@ -695,17 +909,23 @@   | posAbsoluteOffset _position == aiEndOffset ai = Nothing   -- Skip the continuation line altogether   | isContinuation ai && _isWhiteInsensitive = skip Continuation ai+  -- Skip the newline before a comment+  | aiFortranVersion ai == Fortran77Legacy &&+    _isWhiteInsensitive && isNewlineComment ai = skip NewlineComment ai   -- If we are not parsing a Hollerith skip whitespace   | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai+  -- Ignore inline comments+  | aiFortranVersion ai == Fortran77Legacy &&+    _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai   -- Read genuine character and advance. Also covers white sensitivity.   | otherwise =-      let (_b:_bs) = (utf8Encode . toLower) _curChar in+      let (_b:_bs) = utf8Encode _curChar in         Just(_b, updateLexeme (Just _curChar) _position           ai {             aiPosition =               case _curChar of-                '\n'  -> advance Newline _position-                _     -> advance Char _position,+                '\n'  -> advance Newline ai+                _     -> advance Char ai,             aiBytes = _bs,             aiPreviousChar = _curChar,             aiWhiteSensitiveCharCount =@@ -714,10 +934,11 @@               else aiWhiteSensitiveCharCount ai - 1           })   where-    _curChar = currentChar ai+    _curChar = (if aiCaseSensitive ai then id else toLower) $ currentChar ai     _bytes = aiBytes ai     _position = aiPosition ai     _isWhiteInsensitive = aiWhiteSensitiveCharCount ai == 0+    _inFormat = aiInFormat ai  alexInputPrevChar :: AlexInput -> Char alexInputPrevChar ai = aiPreviousChar ai@@ -731,19 +952,29 @@ currentChar :: AlexInput -> Char currentChar ai = B.index (aiSourceBytes ai) (fromIntegral . posAbsoluteOffset . aiPosition $ ai) +lookBack :: Int -> AlexInput -> Char+lookBack n ai = B.index (aiSourceBytes ai) (fromIntegral . subtract n . posAbsoluteOffset . aiPosition $ ai)+ isContinuation :: AlexInput -> Bool isContinuation ai =   take 6 _next7 == "\n     " && not (last _next7 `elem` [' ', '0', '\n', '\r'])   where     _next7 = takeNChars 7 ai +isNewlineComment :: AlexInput -> Bool+isNewlineComment ai =+  _next1 == "\n" && isCommentLine ai p+  where+    _next1 = takeNChars 1 ai+    p = (aiPosition ai) { posAbsoluteOffset = posAbsoluteOffset (aiPosition ai) + 1 }+ skip :: Move -> AlexInput -> Maybe (Word8, AlexInput) skip move ai =-  let _newPosition = advance move $ aiPosition ai in+  let _newPosition = advance move ai in     alexGetByte $ updateLexeme Nothing _newPosition $ ai { aiPosition = _newPosition } -advance :: Move -> Position -> Position-advance move position =+advance :: Move -> AlexInput -> Position+advance move ai =   case move of     Char ->       position { posAbsoluteOffset = _absl + 1, posColumn = _col + 1 }@@ -751,11 +982,68 @@       position { posAbsoluteOffset = _absl + 7, posColumn = 7, posLine = _line + 1 }     Newline ->       position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }+    NewlineComment ->+      skipComment ai+        position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }+    Comment ->+      skipComment ai position   where+    position = aiPosition ai     _col = posColumn position     _line = posLine position     _absl = posAbsoluteOffset position +skipComment :: AlexInput -> Position -> Position+skipComment ai p =+  p { posAbsoluteOffset = posAbsoluteOffset p + length line+    , posColumn = posColumn p + length line+    }+  where+  line = takeLine p ai++skipCommentLines :: AlexInput -> Position -> Position+skipCommentLines ai p = go p p+  where+  go p' p+    -- eof is not a comment line+    | not (null line)+    , isCommentLine ai p+    = go p p{ posAbsoluteOffset = posAbsoluteOffset p + length line + 1 -- skip the newline+            , posColumn = 1, posLine = posLine p + 1+            }+    | isContinuation ai'+    = advance Continuation ai'+    | otherwise+      -- after skipping comment lines, place cursor right at the last newline+    = p2+    where+    line = takeLine p ai+    line' = takeLine p' ai+    p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line'+            , posColumn = length line' + 1+            }+    ai' = ai { aiPosition = p2 }++isCommentLine :: AlexInput -> Position -> Bool+isCommentLine ai p+      -- eof is not a comment line+    | posAbsoluteOffset p == aiEndOffset ai+    = False+    | map toLower (take 1 line) `elem` ["c", "d", "!", "*"]+      || all (`elem` " \t") line+      || head (dropWhile (`elem` " \t") line) == '!'+    = True+    | otherwise+    = False+    where+    line = takeLine p ai++takeLine :: Position -> AlexInput -> String+takeLine p ai =+  B.unpack . B.takeWhile (/='\n') . B.drop (fromIntegral _dropN) $ aiSourceBytes ai+  where+    _dropN = posAbsoluteOffset p+ utf8Encode :: Char -> [Word8] utf8Encode = map fromIntegral . _go . ord   where@@ -821,7 +1109,8 @@       , psContext = [ ConStart ] }     _vanillaAlexInput = vanillaAlexInput       { aiSourceBytes = srcBytes-      , aiEndOffset   = fromIntegral $ B.length srcBytes  }+      , aiEndOffset   = fromIntegral $ B.length srcBytes+      , aiFortranVersion = fortranVersion }  collectFixedTokens :: FortranVersion -> B.ByteString -> [Token] collectFixedTokens version srcInput =

@@ -105,7 +105,11 @@ <scN> "function" / { typeSpecP }                  { addSpan TFunction } <0> "end"\ *"function"                            { addSpan TEndFunction } <scN> "result" / { resultP }                      { addSpan TResult }+<0> "pure"                                        { toSC 0 >> addSpan TPure }+<0> "elemental"                                   { toSC 0 >> addSpan TElemental } <0> "recursive"                                   { toSC 0 >> addSpan TRecursive }+<scN> "pure" / { typeSpecP }                      { toSC 0 >> addSpan TPure }+<scN> "elemental" / { typeSpecP }                 { toSC 0 >> addSpan TElemental } <scN> "recursive" / { typeSpecP }                 { toSC 0 >> addSpan TRecursive } <0> "subroutine"                                  { addSpan TSubroutine } <0> "end"\ *"subroutine"                          { addSpan TEndSubroutine }@@ -993,6 +997,8 @@   | TFunction           SrcSpan   | TEndFunction        SrcSpan   | TResult             SrcSpan+  | TPure          SrcSpan+  | TElemental          SrcSpan   | TRecursive          SrcSpan   | TSubroutine         SrcSpan   | TEndSubroutine      SrcSpan

@@ -6,8 +6,10 @@  import Language.Fortran.Parser.Fortran66 ( fortran66Parser, fortran66ParserWithModFiles ) import Language.Fortran.Parser.Fortran77 ( fortran77Parser, fortran77ParserWithModFiles-                                         , extended77Parser, extended77ParserWithModFiles )+                                         , extended77Parser, extended77ParserWithModFiles+                                         , legacy77Parser, legacy77ParserWithModFiles ) import Language.Fortran.Parser.Fortran90 ( fortran90Parser, fortran90ParserWithModFiles )+import Language.Fortran.Parser.Fortran95 ( fortran95Parser, fortran95ParserWithModFiles )  import qualified Data.ByteString.Char8 as B import Data.Char (toLower)@@ -20,6 +22,7 @@   | isExtensionOf ".fpp"    = Fortran77   | isExtensionOf ".ftn"    = Fortran77   | isExtensionOf ".f90"    = Fortran90+  | isExtensionOf ".f95"    = Fortran95   | isExtensionOf ".f03"    = Fortran2003   | isExtensionOf ".f2003"  = Fortran2003   | isExtensionOf ".f08"    = Fortran2008@@ -34,7 +37,9 @@   [ (Fortran66, fromParseResult `after` fortran66Parser)   , (Fortran77, fromParseResult `after` fortran77Parser)   , (Fortran77Extended, fromParseResult `after` extended77Parser)-  , (Fortran90, fromParseResult `after` fortran90Parser) ]+  , (Fortran77Legacy, fromParseResult `after` legacy77Parser)+  , (Fortran90, fromParseResult `after` fortran90Parser)+  , (Fortran95, fromParseResult `after` fortran95Parser) ]  type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserWithModFilesVersions :: [(FortranVersion, ParserWithModFiles)]@@ -42,7 +47,9 @@   [ (Fortran66, \m s -> fromParseResult . fortran66ParserWithModFiles m s)   , (Fortran77, \m s -> fromParseResult . fortran77ParserWithModFiles m s)   , (Fortran77Extended, \m s -> fromParseResult . extended77ParserWithModFiles m s)-  , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s) ]+  , (Fortran77Legacy, \m s -> fromParseResult . legacy77ParserWithModFiles m s)+  , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s)+  , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) ]  after g f x = g . (f x) 

@@ -128,11 +128,11 @@ OTHER_PROGRAM_UNIT :: { ProgramUnit A0 } OTHER_PROGRAM_UNIT : TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE-  { PUFunction () (getTransSpan $1 $7) (Just $1) False $3 $4 Nothing (reverse $6) Nothing }+  { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing } | function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE-  { PUFunction () (getTransSpan $1 $6) Nothing False $2 $3 Nothing (reverse $5) Nothing  }+  { PUFunction () (getTransSpan $1 $6) Nothing (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing  } | subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE-  { PUSubroutine () (getTransSpan $1 $6) False $2 $3 (reverse $5) Nothing }+  { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing } | blockData NEWLINE BLOCKS end MAYBE_NEWLINE { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }  MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }@@ -185,7 +185,7 @@ : EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 } | goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }-| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 $3 }+| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) } | goto LABELS_IN_STATEMENT VARIABLE { StGotoComputed () (getTransSpan $1 $3) $2 $3 } | if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } | call VARIABLE ARGUMENTS

@@ -1,30 +1,40 @@ -- -*- Mode: Haskell -*- {-module Language.Fortran.Parser.Fortran77 ( expressionParser-                               , statementParser-                               , fortran77Parser-                               , extended77Parser-                               , fortran77ParserWithModFiles-                               , extended77ParserWithModFiles-                               ) where+module Language.Fortran.Parser.Fortran77+  ( expressionParser+  , statementParser+  , fortran77Parser+  , extended77Parser+  , legacy77Parser+  , includeParser+  , fortran77ParserWithModFiles+  , extended77ParserWithModFiles+  , legacy77ParserWithModFiles+  , legacy77ParserWithIncludes+  ) where  import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST  import Control.Monad.State+import Data.List import Data.Maybe (isNothing, fromJust) import qualified Data.ByteString.Char8 as B import Language.Fortran.Util.Position import Language.Fortran.Util.ModFile import Language.Fortran.ParserMonad-import Language.Fortran.Lexer.FixedForm+import Language.Fortran.Lexer.FixedForm hiding (Move(..)) import Language.Fortran.Transformer import Language.Fortran.AST -import Debug.Trace+import Data.Generics.Uniplate.Operations+import System.Directory+import System.FilePath+import Control.Exception  }  %name programParser PROGRAM+%name includesParser INCLUDES %name statementParser STATEMENT %name expressionParser EXPRESSION %monad { LexAction }@@ -44,7 +54,17 @@   program               { TProgram _ }   function              { TFunction _ }   subroutine            { TSubroutine _ }+  endprogram            { TEndProgram _ }+  endfunction           { TEndFunction _ }+  endsubroutine         { TEndSubroutine _ }   blockData             { TBlockData _ }+  structure             { TStructure _ }+  union                 { TUnion _ }+  map                   { TMap _ }+  endstructure          { TEndStructure _ }+  endunion              { TEndUnion _ }+  endmap                { TEndMap _ }+  record                { TRecord _ }   end                   { TEnd _ }   '='                   { TOpAssign _ }   assign                { TAssign _ }@@ -61,13 +81,20 @@   continue              { TContinue _ }   stop                  { TStop _ }   exit                  { TExit _ }+  cycle                 { TCycle _ }+  case                  { TCase _ }+  selectcase            { TSelectCase _ }+  endselect             { TEndSelect _ }+  casedefault           { TCaseDefault _ }   pause                 { TPause _ }   do                    { TDo _ }   doWhile               { TDoWhile _ }+  while                 { TWhile _ }   enddo                 { TEndDo _ }   read                  { TRead _ }   write                 { TWrite _ }   print                 { TPrint _ }+  typeprint             { TTypePrint _ }   open                  { TOpen _ }   close                 { TClose _ }   inquire               { TInquire _ }@@ -78,6 +105,7 @@   equivalence           { TEquivalence _ }   external              { TExternal _ }   dimension             { TDimension _ }+  byte                  { TType _ "byte" }   character             { TType _ "character" }   integer               { TType _ "integer" }   real                  { TType _ "real" }@@ -88,12 +116,15 @@   intrinsic             { TIntrinsic _ }   implicit              { TImplicit _ }   parameter             { TParameter _ }+  pointer               { TPointer _ }   entry                 { TEntry _ }   none                  { TNone _ }   data                  { TData _ }+  automatic             { TAutomatic _ }   format                { TFormat _ }   blob                  { TBlob _ _ }   int                   { TInt _ _ }+  boz                   { TBozInt _ _ }   exponent              { TExponent _ _ }   bool                  { TBool _ _ }   '+'                   { TOpPlus _ }@@ -101,10 +132,12 @@   '**'                  { TOpExp _ }   '*'                   { TStar _ }   '/'                   { TSlash _ }+  '&'                   { TAmpersand _ }   eqv                   { TOpEquivalent _ }   neqv                  { TOpNotEquivalent _ }   or                    { TOpOr _ }   and                   { TOpAnd _ }+  xor                   { TOpXOr _ }   not                   { TOpNot _ }   '<'                   { TOpLT _ }   '<='                  { TOpLE _ }@@ -119,7 +152,7 @@   label                 { TLabel _ _ }   newline               { TNewline _ } -%left eqv neqv+%left eqv neqv xor %left or %left and %right not@@ -136,6 +169,24 @@  %% +maybe(p)+: p           { Just $1 }+| {- empty -} { Nothing }++rev_list1(p)+: p              { [$1] }+| rev_list1(p) p { $2 : $1 }++rev_list(p)+: rev_list1(p) { $1 }+| {- empty -}  { [] }++list1(p)+: rev_list1(p) { reverse $1 }++list(p)+: rev_list(p) { reverse $1 }+ -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 } PROGRAM@@ -148,28 +199,60 @@  PROGRAM_UNITS :: { [ ProgramUnit A0 ] } PROGRAM_UNITS-: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }-| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }+: 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 end { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }-| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end-  { PUFunction () (getTransSpan $1 $7) (Just $1) False $3 $4 Nothing (reverse $6) Nothing }-| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end-  { PUFunction () (getTransSpan $1 $6) Nothing False $2 $3 Nothing (reverse $5) Nothing }-| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end-  { PUSubroutine () (getTransSpan $1 $6) False $2 $3 (reverse $5) Nothing }-| blockData NEWLINE BLOCKS end { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }-| blockData NAME NEWLINE BLOCKS end { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) }+: program NAME NEWLINE BLOCKS ENDPROG+  { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }+| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN+  { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing }+| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN+  { PUFunction () (getTransSpan $1 $6) Nothing (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing }+| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB+  { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing }+| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }+| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } | 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 }+ MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } : '(' MAYBE_VARIABLES ')' { $2 } | {- Nothing -} { Nothing } +MAYBE_ID :: { Maybe Name }+: id { let (TId _ name) = $1 in Just name }+| {- empty -} { Nothing }+ 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 }@@ -185,8 +268,6 @@ COMMENT_BLOCK : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } -MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing }- NEWLINE :: { Token } NEWLINE : NEWLINE newline { $1 }@@ -207,6 +288,7 @@ : 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@@ -225,6 +307,10 @@ | endif { StEndif () (getSpan $1) Nothing } | doWhile '(' EXPRESSION ')'   { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 }+| do LABEL_IN_STATEMENT while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $6) Nothing (Just $2) $5 }+| do LABEL_IN_STATEMENT ',' while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 } | enddo { StEnddo () (getSpan $1) Nothing } | call VARIABLE ARGUMENTS   { StCall () (getTransSpan $1 $3) $2 $ Just $3 }@@ -236,8 +322,22 @@ | stop INTEGER_OR_STRING { StStop () (getTransSpan $1 $2) $ Just $2 } | stop { StStop () (getSpan $1) Nothing } | exit { StExit () (getSpan $1) Nothing }+| cycle { StCycle () (getSpan $1) Nothing } | pause INTEGER_OR_STRING { StPause () (getTransSpan $1 $2) $ Just $2 } | pause { StPause () (getSpan $1) Nothing }+| selectcase '(' EXPRESSION ')'+  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }+| casedefault { StCase () (getSpan $1) Nothing Nothing }+| casedefault id+  { let TId s id = $2 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) } -- IO Statements | read CILIST IN_IOLIST { StRead () (getTransSpan $1 $3) $2 (Just $ aReverse $3) } | read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }@@ -247,6 +347,8 @@ | write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing } | print FORMAT_ID ',' OUT_IOLIST { StPrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) } | print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing }+| typeprint FORMAT_ID ',' OUT_IOLIST { StTypePrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) }+| typeprint FORMAT_ID { StTypePrint () (getTransSpan $1 $2) $2 Nothing } | open CILIST { StOpen () (getTransSpan $1 $2) $2 } | close CILIST { StClose () (getTransSpan $1 $2) $2 } | inquire CILIST { StInquire () (getTransSpan $1 $2) $2 }@@ -265,13 +367,11 @@ -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT                     { $1 }-| VARIABLE                      { $1 } | '*' { ExpValue () (getSpan $1) ValStar }  UNIT :: { Expression A0 } UNIT : INTEGER_LITERAL { $1 }-| VARIABLE { $1 } | SUBSCRIPT { $1 } | '*' { ExpValue () (getSpan $1) ValStar } @@ -323,6 +423,7 @@ | ARITHMETIC_SIGN CI_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | CI_EXPRESSION or CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } | CI_EXPRESSION and CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| CI_EXPRESSION xor CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | not CI_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | CI_EXPRESSION eqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } | CI_EXPRESSION neqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }@@ -334,7 +435,6 @@ -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT                     { $1 }-| VARIABLE                      { $1 }  -- Input IOList used in read like statements is much more restrictive as it -- doesn't make sense to read into an integer.@@ -348,8 +448,7 @@  IN_IO_ELEMENT :: { Expression A0 } IN_IO_ELEMENT-: VARIABLE { $1 }-| SUBSCRIPT { $1 }+: SUBSCRIPT { $1 } | '(' IN_IOLIST ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) (aReverse $2) $4 }  OUT_IOLIST :: { AList Expression A0 }@@ -375,8 +474,9 @@ GOTO_STATEMENT :: { Statement A0 } GOTO_STATEMENT : goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }-| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 $3 }-| goto VARIABLE ',' LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $4) $2 $4 }+| goto VARIABLE { StGotoAssigned () (getTransSpan $1 $2) $2 Nothing }+| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) }+| goto VARIABLE ',' LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $4) $2 (Just $4) } | goto LABELS_IN_STATEMENT EXPRESSION { StGotoComputed () (getTransSpan $1 $3) $2 $3 } | goto LABELS_IN_STATEMENT ',' EXPRESSION { StGotoComputed () (getTransSpan $1 $4) $2 $4 } @@ -390,7 +490,9 @@ | dimension 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) }-| data DATA_GROUPS { StData () (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) } -- Following is a fake node to make arbitrary FORMAT statements parsable. -- Must be fixed in the future. TODO | format blob@@ -402,8 +504,39 @@   { StParameter () (getTransSpan $1 $4) $ fromReverseList $3 } | entry VARIABLE { StEntry () (getTransSpan $1 $2) $2 Nothing Nothing } | entry VARIABLE ENTRY_ARGS { StEntry () (getTransSpan $1 $3) $2 (Just $3) Nothing }-| include STRING { StInclude () (getTransSpan $1 $2) $2 }+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }+| structure MAYBE_NAME NEWLINE STRUCTURE_DECLARATIONS endstructure+  { 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+  { $2 : $1 }+| STRUCTURE_DECLARATION_STATEMENT { [ $1 ] }++STRUCTURE_DECLARATION_STATEMENT :: { StructureItem A0 }+STRUCTURE_DECLARATION_STATEMENT+: DECLARATION_STATEMENT NEWLINE+  { let StDeclaration () s t attrs decls = $1+    in StructFields () s t attrs decls }+| union NEWLINE UNION_MAPS endunion NEWLINE+  { StructUnion () (getTransSpan $1 $5) (fromReverseList $3) }++UNION_MAPS :: { [ UnionMap A0 ] }+UNION_MAPS+: UNION_MAPS UNION_MAP { $2 : $1 }+| UNION_MAP { [ $1 ] }++UNION_MAP :: { UnionMap A0 }+UNION_MAP+: map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE+  { UnionMap () (getTransSpan $1 $5) (fromReverseList $3) }+ ENTRY_ARGS :: { AList Expression A0 } ENTRY_ARGS : ENTRY_ARGS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }@@ -431,7 +564,7 @@  DECLARATION_STATEMENT :: { Statement A0 } DECLARATION_STATEMENT-: TYPE_SPEC DECLARATORS { StDeclaration () (getTransSpan $1 $2) $1 Nothing $2 }+: TYPE_SPEC maybe(',') DECLARATORS { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }  IMP_LISTS :: { AList ImpList A0 } IMP_LISTS@@ -466,14 +599,23 @@  ELEMENT :: { Expression A0 } ELEMENT-: VARIABLE { $1 }-| SUBSCRIPT { $1 }+: SUBSCRIPT { $1 } -DATA_GROUPS :: { AList DataGroup A0 }+DATA_GROUPS :: { [DataGroup A0] } DATA_GROUPS-: DATA_GROUPS ',' NAME_LIST  '/' DATA_ITEMS '/' { setSpan (getTransSpan $1 $6) $ (DataGroup () (getTransSpan $3 $6) (aReverse $3) (aReverse $5)) `aCons` $1 }-| NAME_LIST  '/' DATA_ITEMS '/' { AList () (getTransSpan $1 $4) [ DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) ] }+: 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}@@ -481,7 +623,7 @@  DATA_ITEM :: { Expression A0 } DATA_ITEM-: INTEGER_LITERAL '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+: INTEGER_CONSTANT '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | DATA_ITEM_LEVEL1 { $1 }  DATA_ITEM_LEVEL1 :: { Expression A0 }@@ -492,12 +634,24 @@ | '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | LOGICAL_LITERAL         { $1 } | STRING                  { $1 }+| 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 :: { 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 }@@ -543,12 +697,54 @@ ARRAY_DECLARATOR : VARIABLE '(' DIMENSION_DECLARATORS ')'   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing }+| 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))) } +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 }+| STRING { $1 }+| 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 '*' EXPRESSION+| 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@@ -584,7 +780,9 @@ -- Expression all by itself subsumes all other callable expressions. CALLABLE_EXPRESSION :: { Argument A0 } CALLABLE_EXPRESSION-: HOLLERITH   { Argument () (getSpan $1) Nothing $1 }+: id '=' EXPRESSION+  { let TId span keyword = $1+    in Argument () (getTransSpan span $3) (Just keyword) $3 } | EXPRESSION  { Argument () (getSpan $1) Nothing $1 }  EXPRESSION :: { Expression A0 }@@ -597,6 +795,7 @@ | EXPRESSION '/' '/' EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } | ARITHMETIC_SIGN EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | EXPRESSION or EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| EXPRESSION xor EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | EXPRESSION and EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 } | not EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | EXPRESSION eqv EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }@@ -607,16 +806,18 @@ | '(' EXPRESSION ',' EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) } | LOGICAL_LITERAL                   { $1 } | STRING                            { $1 }+| HOLLERITH                         { $1 } -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT                         { $1 }-| VARIABLE                          { $1 } | IMPLIED_DO                        { $1 } | '(/' EXPRESSION_LIST '/)' {     let { exps = reverse $2;           expList = AList () (getSpan exps) exps }     in ExpInitialisation () (getTransSpan $1 $3) expList           }+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }+| '&' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }  IMPLIED_DO :: { Expression A0 } IMPLIED_DO@@ -651,6 +852,7 @@ | CONSTANT_EXPRESSION '/' '/' CONSTANT_EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } | ARITHMETIC_SIGN CONSTANT_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | CONSTANT_EXPRESSION or CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| CONSTANT_EXPRESSION xor CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | CONSTANT_EXPRESSION and CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 } | not CONSTANT_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | CONSTANT_EXPRESSION RELATIONAL_OPERATOR CONSTANT_EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }@@ -659,7 +861,13 @@ | '(' CONSTANT_EXPRESSION ',' CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | LOGICAL_LITERAL               { $1 } | string                        { let (TString s cs) = $1 in ExpValue () s (ValString cs) }-| VARIABLE                     { $1 }+| SUBSCRIPT                    { $1 }+| HOLLERITH                    { $1 }+| '(/' EXPRESSION_LIST '/)' {+    let { exps = reverse $2;+          expList = AList () (getSpan exps) exps }+    in ExpInitialisation () (getTransSpan $1 $3) expList+          }  ARITHMETIC_CONSTANT_EXPRESSION :: { Expression A0 } ARITHMETIC_CONSTANT_EXPRESSION@@ -685,13 +893,13 @@  SUBSCRIPT :: { Expression A0 } SUBSCRIPT-: VARIABLE '(' ')'+: SUBSCRIPT '.' VARIABLE+  { ExpDataRef () (getTransSpan $1 $3) $1 $3 }+| SUBSCRIPT '(' ')'   { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }-| VARIABLE '(' INDICIES ')'+| SUBSCRIPT '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }-| VARIABLE '(' INDICIES ')' '(' INDICIES ')'-  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)-    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }+| VARIABLE { $1 }  INDICIES :: { [ Index A0 ] } : INDICIES ',' INDEX { $3 : $1 }@@ -717,8 +925,16 @@ : VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }  VARIABLES :: { [ Expression A0 ] }-VARIABLES : VARIABLES ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] }+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 }+ -- This may also be used to parse a function name, or an array name. Since when -- are valid options in a production there is no way of differentiating them at -- this stage.@@ -727,7 +943,9 @@ VARIABLE : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s } -INTEGER_LITERAL :: { Expression A0 } : int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i }+INTEGER_LITERAL :: { Expression A0 }+: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i }+| boz { let TBozInt s i = $1 in ExpValue () s $ ValInteger i }  REAL_LITERAL :: { Expression A0 } REAL_LITERAL@@ -777,45 +995,47 @@  TYPE_SPEC :: { TypeSpec A0 } TYPE_SPEC-: integer KIND_SELECTOR { TypeSpec () (getSpan $1) TypeInteger Nothing }-| real KIND_SELECTOR { TypeSpec () (getSpan $1) TypeReal Nothing }+: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  } | doublePrecision KIND_SELECTOR-  { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }-| logical KIND_SELECTOR { TypeSpec () (getSpan $1) TypeLogical Nothing }-| complex KIND_SELECTOR { TypeSpec () (getSpan $1) TypeComplex Nothing }+  { TypeSpec () (getSpan ($1, $2)) TypeDoublePrecision $2 }+| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } | doubleComplex KIND_SELECTOR-  { TypeSpec () (getSpan $1) TypeDoubleComplex Nothing }+  { TypeSpec () (getSpan ($1, $2)) TypeDoubleComplex $2 } | character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| byte KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 }+| record '/' NAME '/' { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }  KIND_SELECTOR :: { Maybe (Selector A0) } KIND_SELECTOR+: KIND_SELECTOR1+  { Just $1 }+| {- EMPTY -}+  { Nothing }++KIND_SELECTOR1 :: { Selector A0 }+KIND_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION-  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }-| '*' '(' STAR ')' { Just $ Selector () (getTransSpan $1 $4) Nothing (Just $3) }-| {- EMPTY -} { Nothing }+  { Selector () (getTransSpan $1 $2) Nothing (Just $2) }+| '*' '(' STAR ')' { Selector () (getTransSpan $1 $4) Nothing (Just $3) }  CHAR_SELECTOR :: { Maybe (Selector A0) }-CHAR_SELECTOR-: '(' ARITHMETIC_CONSTANT_EXPRESSION ')'-  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }-| BASIC_CHAR_SELECTOR { $1 }+: CHAR_SELECTOR1+  { Just $1 }+| {- EMPTY -}+  { Nothing } -BASIC_CHAR_SELECTOR :: { Maybe (Selector A0) }-BASIC_CHAR_SELECTOR+CHAR_SELECTOR1 :: { Selector A0 }+CHAR_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION-  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }-| '*' '(' STAR ')' { Just $ Selector () (getTransSpan $1 $4) (Just $3) Nothing }-| {- EMPTY -} { Nothing }+  { Selector () (getTransSpan $1 $2) (Just $2) Nothing }+| '*' '(' STAR ')'+  { Selector () (getTransSpan $1 $4) (Just $3) Nothing }  IMP_TYPE_SPEC :: { TypeSpec A0 } IMP_TYPE_SPEC-: integer          { TypeSpec () (getSpan $1) TypeInteger Nothing }-| real             { TypeSpec () (getSpan $1) TypeReal Nothing }-| doublePrecision  { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }-| logical          { TypeSpec () (getSpan $1) TypeLogical Nothing }-| complex          { TypeSpec () (getSpan $1) TypeComplex Nothing }-| doubleComplex    { TypeSpec () (getSpan $1) TypeDoubleComplex Nothing }-| character BASIC_CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+: TYPE_SPEC  { $1 }  STAR :: { Expression A0 } STAR : '*' { ExpValue () (getSpan $1) ValStar }@@ -858,6 +1078,7 @@   [ GroupLabeledDo   , GroupDo   , GroupIf+  , GroupCase   , DisambiguateIntrinsic   , DisambiguateFunction   ]@@ -872,6 +1093,69 @@   where     transform = transformWithModFiles mods transformations77Extended     parseState = initParseState sourceCode Fortran77Extended filename++transformations77Legacy =+  [ GroupLabeledDo+  , GroupDo+  , GroupIf+  , DisambiguateIntrinsic+  , DisambiguateFunction+  ]+legacy77Parser ::+    B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+legacy77Parser = legacy77ParserWithModFiles emptyModFiles++legacy77ParserWithModFiles ::+    ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+legacy77ParserWithModFiles mods sourceCode filename =+    fmap (pfSetFilename filename . transform) $ parse parseState+  where+    transform = transformWithModFiles mods transformations77Legacy+    parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename++legacy77ParserWithIncludes ::+  [String] -> B.ByteString -> String -> IO (ParseResult AlexInput Token (ProgramFile A0))+legacy77ParserWithIncludes incs sourceCode filename =+    fmap (pfSetFilename filename . transform) <$> doParse+  where+    doParse = case parse parseState of+      ParseFailed e -> return (ParseFailed e)+      ParseOk p x -> do+        p' <- descendBiM (inlineInclude Fortran77Legacy incs) p+        return (ParseOk p' x)+    transform = transformWithModFiles emptyModFiles transformations77Legacy+    parseState = initParseState sourceCode Fortran77Legacy filename++includeParser ::+    FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0]+includeParser version sourceCode filename =+    runParse includesParser parseState+  where+    -- ensure the file ends with a newline..+    parseState = initParseState (sourceCode `B.snoc` '\n') version filename++inlineInclude :: FortranVersion -> [String] -> Statement A0 -> IO (Statement A0)+inlineInclude fv dirs st = case st of+  StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do+    inc <- truncateLines <$> readInDirs dirs path+    case includeParser fv inc path of+      ParseOk blocks _ -> do+        blocks' <- descendBiM (inlineInclude fv dirs) blocks+        return $ StInclude a s e (Just blocks')+      ParseFailed e -> throwIO e+  _ -> return st++readInDirs :: [String] -> String -> IO B.ByteString+readInDirs [] f = fail $ "cannot find file: " ++ f+readInDirs (d:ds) f = do+  b <- doesFileExist (d</>f)+  if b then+    B.readFile (d</>f)+  else+    readInDirs ds f++truncateLines :: B.ByteString -> B.ByteString+truncateLines b = B.unlines . map (B.filter (/='\r') . B.take 72) . B.lines $ b  parseError :: Token -> LexAction a parseError _ = do

@@ -1,6 +1,7 @@ -- -*- Mode: Haskell -*- { module Language.Fortran.Parser.Fortran90 ( statementParser+                                         , functionParser                                          , fortran90Parser                                          , fortran90ParserWithModFiles                                          ) where@@ -27,6 +28,7 @@ }  %name programParser PROGRAM+%name functionParser SUBPROGRAM_UNIT %name statementParser STATEMENT %monad { LexAction } %lexer { lexer } { TEOF _ }@@ -237,22 +239,25 @@ SUBPROGRAM_UNIT :: { ProgramUnit A0 } : TYPE_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END   {% do { unitNameCheck $10 $3;-          return $ PUFunction () (getTransSpan $1 $10) (Just $1) False $3 $4 $6 (reverse $8) $9 } }+          return $ PUFunction () (getTransSpan $1 $10) (Just $1) (None () initSrcSpan False) $3 $4 $6 (reverse $8) $9 } } | TYPE_SPEC recursive function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END   {% do { unitNameCheck $11 $4;-          return $ PUFunction () (getTransSpan $1 $11) (Just $1) True $4 $5 $7 (reverse $9) $10 } }+          return $ PUFunction () (getTransSpan $1 $11) (Just $1) (None () (getSpan $2) True) $4 $5 $7 (reverse $9) $10 } } | recursive TYPE_SPEC function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END   {% do { unitNameCheck $11 $4;-          return $ PUFunction () (getTransSpan $1 $11) (Just $2) True $4 $5 $6 (reverse $9) $10 } }+          return $ PUFunction () (getTransSpan $1 $11) (Just $2) (None () (getSpan $1) True) $4 $5 $6 (reverse $9) $10 } } | function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END   {% do { unitNameCheck $9 $2;-          return $ PUFunction () (getTransSpan $1 $9) Nothing False $2 $3 $4 (reverse $7) $8 } }+          return $ PUFunction () (getTransSpan $1 $9) Nothing (None () initSrcSpan False) $2 $3 $4 (reverse $7) $8 } }+| recursive function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END+  {% do { unitNameCheck $10 $3;+          return $ PUFunction () (getTransSpan $1 $10) Nothing (None () initSrcSpan True) $3 $4 $5 (reverse $8) $9 } } | subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END   {% do { unitNameCheck $8 $2;-          return $ PUSubroutine () (getTransSpan $1 $8) False $2 $3 (reverse $6) $7 } }+          return $ PUSubroutine () (getTransSpan $1 $8) (None () initSrcSpan False) $2 $3 (reverse $6) $7 } } | recursive subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END   {% do { unitNameCheck $9 $3;-          return $ PUSubroutine () (getTransSpan $1 $9) True $3 $4 (reverse $7) $8 } }+          return $ PUSubroutine () (getTransSpan $1 $9) (None () initSrcSpan True) $3 $4 (reverse $7) $8 } } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) }  MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }@@ -407,7 +412,7 @@ | endType { StEndType () (getSpan $1) Nothing } | endType id   { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }-| include STRING { StInclude () (getTransSpan $1 $2) $2 }+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing } -- Following is a fake node to make arbitrary FORMAT statements parsable. -- Must be fixed in the future. TODO | format blob@@ -467,10 +472,14 @@ | cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) } | exit { StExit () (getSpan $1) Nothing } | exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }+-- GO TO label | goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }+-- GO TO scalar-int-variable | goto VARIABLE { StGotoUnconditional () (getTransSpan $1 $2) $2 }+-- GO TO scalar-int-variable [,] label-list | goto VARIABLE MAYBE_COMMA '(' INTEGERS ')'-  { StGotoAssigned () (getTransSpan $1 $6) $2 (fromReverseList $5) }+  { StGotoAssigned () (getTransSpan $1 $6) $2 (Just (fromReverseList $5)) }+-- GO TO label-list [,] scalar-int-expression | goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION   { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 } | assign INTEGER_LITERAL to VARIABLE

@@ -0,0 +1,1178 @@+-- -*- Mode: Haskell -*-+{+module Language.Fortran.Parser.Fortran95 ( functionParser+                                         , statementParser+                                         , fortran95Parser+                                         , fortran95ParserWithModFiles+                                         ) where++import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST+import Control.Monad.State+import Data.Maybe (fromMaybe, isJust)+import Data.List (nub)+import Data.Either (either, lefts, rights)+import Control.Applicative+import qualified Data.ByteString.Char8 as B++#ifdef DEBUG+import Data.Data (toConstr)+#endif++import Language.Fortran.Util.Position+import Language.Fortran.Util.ModFile+import Language.Fortran.ParserMonad+import Language.Fortran.Lexer.FreeForm+import Language.Fortran.AST+import Language.Fortran.Transformer++import Debug.Trace++}++%name programParser PROGRAM+%name statementParser STATEMENT+%name functionParser SUBPROGRAM_UNIT +%monad { LexAction }+%lexer { lexer } { TEOF _ }+%tokentype { Token }+%error { parseError }++%token+  id                          { TId _ _ }+  comment                     { TComment _ _ }+  string                      { TString _ _ }+  int                         { TIntegerLiteral _ _ }+  float                       { TRealLiteral _ _ }+  boz                         { TBozLiteral _ _ }+  ','                         { TComma _ }+  ',2'                        { TComma2 _ }+  ';'                         { TSemiColon _ }+  ':'                         { TColon _ }+  '::'                        { TDoubleColon _ }+  '='                         { TOpAssign _ }+  '=>'                        { TArrow _ }+  '%'                         { TPercent _ }+  '('                         { TLeftPar _ }+  '(2'                        { TLeftPar2 _ }+  ')'                         { TRightPar _ }+  '(/'                        { TLeftInitPar _ }+  '/)'                        { TRightInitPar _ }+  opCustom                    { TOpCustom _ _ }+  '**'                        { TOpExp _ }+  '+'                         { TOpPlus _ }+  '-'                         { TOpMinus _ }+  '*'                         { TStar _ }+  '/'                         { TOpDivision _ }+  slash                       { TSlash _ }+  or                          { TOpOr _ }+  and                         { TOpAnd _ }+  not                         { TOpNot _ }+  eqv                         { TOpEquivalent _ }+  neqv                        { TOpNotEquivalent _ }+  '<'                         { TOpLT _ }+  '<='                        { TOpLE _ }+  '=='                        { TOpEQ _ }+  '!='                        { TOpNE _ }+  '>'                         { TOpGT _ }+  '>='                        { TOpGE _ }+  bool                        { TLogicalLiteral _ _ }+  program                     { TProgram _ }+  endProgram                  { TEndProgram _ }+  function                    { TFunction _ }+  endFunction                 { TEndFunction _ }+  result                      { TResult _ }+  pure                        { TPure _ }+  elemental                   { TElemental _ }+  recursive                   { TRecursive _ }+  subroutine                  { TSubroutine _ }+  endSubroutine               { TEndSubroutine _ }+  blockData                   { TBlockData _ }+  endBlockData                { TEndBlockData _ }+  module                      { TModule _ }+  endModule                   { TEndModule _ }+  contains                    { TContains _ }+  use                         { TUse _ }+  only                        { TOnly _ }+  interface                   { TInterface _ }+  endInterface                { TEndInterface _ }+  moduleProcedure             { TModuleProcedure _ }+  assignment                  { TAssignment _ }+  operator                    { TOperator _ }+  call                        { TCall _ }+  return                      { TReturn _ }+  entry                       { TEntry _ }+  include                     { TInclude _ }+  public                      { TPublic _ }+  private                     { TPrivate _ }+  parameter                   { TParameter _ }+  allocatable                 { TAllocatable _ }+  dimension                   { TDimension _ }+  external                    { TExternal _ }+  intent                      { TIntent _ }+  intrinsic                   { TIntrinsic _ }+  optional                    { TOptional _ }+  pointer                     { TPointer _ }+  save                        { TSave _ }+  target                      { TTarget _ }+  in                          { TIn _ }+  out                         { TOut _ }+  inout                       { TInOut _ }+  data                        { TData _ }+  namelist                    { TNamelist _ }+  implicit                    { TImplicit _ }+  equivalence                 { TEquivalence _ }+  common                      { TCommon _ }+  allocate                    { TAllocate _ }+  deallocate                  { TDeallocate _ }+  nullify                     { TNullify _ }+  none                        { TNone _ }+  goto                        { TGoto _ }+  to                          { TTo _ }+  continue                    { TContinue _ }+  stop                        { TStop _ }+  do                          { TDo _ }+  enddo                       { TEndDo _ }+  while                       { TWhile _ }+  if                          { TIf _ }+  then                        { TThen _ }+  else                        { TElse _ }+  elsif                       { TElsif _ }+  endif                       { TEndIf _ }+  case                        { TCase _ }+  selectcase                  { TSelectCase _ }+  endselect                   { TEndSelect _ }+  default                     { TDefault _ }+  cycle                       { TCycle _ }+  exit                        { TExit _ }+  where                       { TWhere _ }+  elsewhere                   { TElsewhere _ }+  endwhere                    { TEndWhere _ }+  type                        { TType _ }+  endType                     { TEndType _ }+  sequence                    { TSequence _ }+  kind                        { TKind _ }+  len                         { TLen _ }+  integer                     { TInteger _ }+  real                        { TReal _ }+  doublePrecision             { TDoublePrecision _ }+  logical                     { TLogical _ }+  character                   { TCharacter _ }+  complex                     { TComplex _ }+  open                        { TOpen _ }+  close                       { TClose _ }+  read                        { TRead _ }+  write                       { TWrite _ }+  print                       { TPrint _ }+  backspace                   { TBackspace _ }+  rewind                      { TRewind _ }+  inquire                     { TInquire _ }+  endfile                     { TEndfile _ }+  format                      { TFormat _ }+  blob                        { TBlob _ _ }+  end                         { TEnd _ }+  newline                     { TNewline _ }+  forall                      { TForall _ }+  endforall                   { TEndForall _ }+-- Precedence of operators++-- Level 6+%left opCustom++-- Level 5+%left eqv neqv+%left or+%left and+%right not++-- Level 4+%nonassoc '==' '!=' '>' '<' '>=' '<='+%nonassoc RELATIONAL++-- Level 3+%left CONCAT++-- Level 2+%left '+' '-'+%left '*' '/'+%right SIGN+%right '**'++-- Level 1+%right DEFINED_UNARY++-- Level 0+%left '%'++%%++-- This rule is to ignore leading whitespace+PROGRAM :: { ProgramFile A0 }+: NEWLINE PROGRAM_INNER { $2 }+| PROGRAM_INNER { $1 }++PROGRAM_INNER :: { ProgramFile A0 }+: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran95, miFilename = "" }) (reverse $1) }++PROGRAM_UNITS :: { [ ProgramUnit A0 ] }+: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }+| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }++PROGRAM_UNIT :: { ProgramUnit A0 }+: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END+  {% do { unitNameCheck $6 $2;+          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }+| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END+  {% do { unitNameCheck $6 $2;+          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }+| blockData NEWLINE BLOCKS BLOCK_DATA_END+  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }+| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END+  {% do { unitNameCheck $5 $2;+          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }+| SUBPROGRAM_UNIT { $1 }++MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }+: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }+| {- Empty -} { Nothing }++SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }+| {- EMPTY -} { [ ] }++SUBPROGRAM_UNIT :: { ProgramUnit A0 }+: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END+  {% do { unitNameCheck $10 $3;+          let (fSpec, typeSpec) = $1 in+          return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9 } }+| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END+  {% do { unitNameCheck $9 $3;+          let (fSpec, _) = $1 in+          return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8 } }+| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }+| recursive RECURSIVE_SUBPROGRAM_UNIT { setSpan (getTransSpan $1 $2) $2 }++RECURSIVE_SUBPROGRAM_UNIT :: { ProgramUnit A0 }+: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END+  {% do+    unitNameCheck $10 $3+    fSpec <- either fail return $ fst $1 `buildPUFunctionOpt`  None () (getSpan $ fst $1) True+    let typeSpec = snd $1+    return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9+  }+| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END+  {% do+    unitNameCheck $9 $3+    fSpec <- either fail return $ fst $1 `buildPUFunctionOpt` None () (getSpan $ fst $1) True+    return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8+  }+++FUNCTION_SPEC :: { (PUFunctionOpt A0, Maybe (TypeSpec A0)) }+: PFUNCTION_SPECS {% do+  let funcSpecs = lefts $1+  let typeSpecs = rights $1+  if length typeSpecs > 1+  then fail "Specified a type spec multiple times in a function spec."+  else if length (nub funcSpecs) /= length funcSpecs then fail "Specified a function spec multiple times."+  else do+    let typeSpec = case typeSpecs of+                                  [] -> Nothing+                                  (x:_) -> Just x+    funcSpec <- either fail return $ buildPUFunctionOpts funcSpecs+    return (funcSpec, typeSpec)+  }++PFUNCTION_SPECS :: { [Either (PUFunctionOpt A0) (TypeSpec A0)] }+: {- EMPTY -} { [] }+| PFUNCTION_SPEC PFUNCTION_SPECS { $1 : $2 }++-- crucically, recursive cannot appear first, which is dealt with in SUBPROGRAM_UNIT+| PFUNCTION_SPEC recursive PFUNCTION_SPECS { $1 : Left (None () (getSpan $2) True) : $3 }++PFUNCTION_SPEC :: { Either (PUFunctionOpt A0) (TypeSpec A0) }+: pure      { Left $ Pure () (getSpan $1) False }+| elemental { Left $ Elemental () (getSpan $1) }+| TYPE_SPEC { Right $ $1 }++MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }+: '(' MAYBE_VARIABLES ')' { $2 }+| {- Nothing -} { Nothing }++RESULT :: { Maybe (Expression a) }+: result '(' VARIABLE ')' { Just $3 }+| {- EMPTY -} { Nothing }++PROGRAM_END :: { Token }+: end { $1 } | endProgram { $1 } | endProgram id { $2 }+MODULE_END :: { Token }+: end { $1 } | endModule { $1 } | endModule id { $2 }+FUNCTION_END :: { Token }+: end { $1 } | endFunction { $1 } | endFunction id { $2 }+SUBROUTINE_END :: { Token }+: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }+BLOCK_DATA_END :: { Token }+: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }++NAME :: { Name } : id { let (TId _ name) = $1 in name }++BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }++BLOCK :: { Block A0 }+: 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 NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE+  { BlInterface () (getTransSpan $1 $7) $2 $4 $5 }+| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE+  { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 }+| COMMENT_BLOCK { $1 }++MAYBE_EXPRESSION :: { Maybe (Expression A0) }+: EXPRESSION { Just $1 }+| {- EMPTY -} { Nothing }++MAYBE_COMMENT :: { Maybe Token }+: comment { Just $1 }+| {- EMPTY -} { Nothing }++SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }++MODULE_PROCEDURES :: { [ Block A0 ] }+: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }+| { [ ] }++MODULE_PROCEDURE :: { Block A0 }+: moduleProcedure VARIABLES NEWLINE+  { let { al = fromReverseList $2;+          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }+    in BlStatement () (getTransSpan $1 $3) Nothing st }++COMMENT_BLOCK :: { Block A0 }+: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }++MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing }++NEWLINE :: { Token }+: NEWLINE newline { $1 }+| NEWLINE ';' { $1 }+| newline { $1 }+| ';' { $1 }++STATEMENT :: { Statement A0 }+: NONEXECUTABLE_STATEMENT { $1 }+| EXECUTABLE_STATEMENT { $1 }++EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }+: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }++NONEXECUTABLE_STATEMENT :: { Statement A0 }+: DECLARATION_STATEMENT { $1 }+| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST+  { let expAList = fromReverseList $6+    in StIntent () (getTransSpan $1 expAList) $3 expAList }+| optional MAYBE_DCOLON EXPRESSION_LIST+  { let expAList = fromReverseList $3+    in StOptional () (getTransSpan $1 expAList) expAList }+| public MAYBE_DCOLON EXPRESSION_LIST+  { let expAList = fromReverseList $3+    in StPublic () (getTransSpan $1 expAList) (Just expAList) }+| public { StPublic () (getSpan $1) Nothing }+| private MAYBE_DCOLON EXPRESSION_LIST+  { let expAList = fromReverseList $3+    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }+| private { StPrivate () (getSpan $1) Nothing }+| save MAYBE_DCOLON SAVE_ARGS+  { let saveAList = (fromReverseList $3)+    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }+| save { StSave () (getSpan $1) Nothing }+| dimension MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StDimension () (getTransSpan $1 declAList) declAList }+| allocatable MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StAllocatable () (getTransSpan $1 declAList) declAList }+| pointer MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StPointer () (getTransSpan $1 declAList) declAList }+| target MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StTarget () (getTransSpan $1 declAList) declAList }+| data cDATA DATA_GROUPS cPOP+  { let dataAList = fromReverseList $3+    in StData () (getTransSpan $1 dataAList) dataAList }+| parameter '(' PARAMETER_ASSIGNMENTS ')'+  { let declAList = fromReverseList $3+    in StParameter () (getTransSpan $1 $4) declAList }+| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }+| implicit cIMPLICIT IMP_LISTS cPOP+  { let impAList = fromReverseList $3+    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }+| namelist cNAMELIST NAMELISTS cPOP+  { let nameALists = fromReverseList $3+    in StNamelist () (getTransSpan $1 nameALists) nameALists }+| equivalence EQUIVALENCE_GROUPS+  { let eqALists = fromReverseList $2+    in StEquivalence () (getTransSpan $1 eqALists) eqALists }+| common cCOMMON COMMON_GROUPS cPOP+  { let commonAList = fromReverseList $3+    in StCommon () (getTransSpan $1 commonAList) commonAList }+| external VARIABLES+  { let alist = fromReverseList $2+    in StExternal () (getTransSpan $1 alist) alist }+| intrinsic VARIABLES+  { let alist = fromReverseList $2+    in StIntrinsic () (getTransSpan $1 alist) alist }+| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing }+| use VARIABLE ',' RENAME_LIST+  { let alist = fromReverseList $4+    in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) }+| use VARIABLE ',' only ':' RENAME_LIST+  { let alist = fromReverseList $6+    in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) }+| entry VARIABLE RESULT+  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }+| entry VARIABLE '(' ')' RESULT+  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }+| entry VARIABLE '(' VARIABLES ')' RESULT+  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }+| sequence { StSequence () (getSpan $1) }+| type ATTRIBUTE_LIST '::' id+  { let { TId span id = $4;+          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }+    in StType () (getTransSpan $1 span) alist id }+| type id+  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }+| endType { StEndType () (getSpan $1) Nothing }+| endType id+  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }+-- Following is a fake node to make arbitrary FORMAT statements parsable.+-- Must be fixed in the future. TODO+| format blob+  { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob }++EXECUTABLE_STATEMENT :: { Statement A0 }+: allocate '(' DATA_REFS ')'+  { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }+| allocate '(' DATA_REFS ',' CILIST_PAIR ')'+  { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }+| nullify '(' DATA_REFS ')'+  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }+| deallocate '(' DATA_REFS ')'+  { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }+| deallocate '(' DATA_REFS ',' CILIST_PAIR ')'+  { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }+| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }+| POINTER_ASSIGNMENT_STMT { $1 }+| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT+  { StWhere () (getTransSpan $1 $5) $3 $5 }+| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) $3 }+| elsewhere { StElsewhere () (getSpan $1) }+| endwhere { StEndWhere () (getSpan $1) }+| 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+    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }+| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION+  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }+| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }+| id ':' do DO_SPECIFICATION+  { let TId s id = $1+    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }+| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }+| do while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }+| id ':' do while '(' EXPRESSION ')'+  { let TId s id = $1+    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }+| enddo { StEnddo () (getSpan $1) Nothing }+| enddo id+  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }+| cycle { StCycle () (getSpan $1) Nothing }+| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }+| exit { StExit () (getSpan $1) Nothing }+| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }+-- GO TO label+| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }+-- GO TO label-list [,] scalar-int-expression+| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION+  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $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+  { let alist = fromReverseList $3+    in StRead () (getTransSpan $1 alist) $2 (Just alist) }+| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }+| read FORMAT_ID ',' IN_IOLIST+  { let alist = fromReverseList $4+    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }+| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }+| write CILIST OUT_IOLIST+  { let alist = fromReverseList $3+    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }+| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }+| print FORMAT_ID ',' OUT_IOLIST+  { let alist = fromReverseList $4+    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }+| print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing }+| open CILIST { StOpen () (getTransSpan $1 $2) $2 }+| close CILIST { StClose () (getTransSpan $1 $2) $2 }+| inquire CILIST { StInquire () (getTransSpan $1 $2) $2 }+| rewind CILIST { StRewind () (getTransSpan $1 $2) $2 }+| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 }+| endfile CILIST { StEndfile () (getTransSpan $1 $2) $2 }+| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 }+| backspace CILIST { StBackspace () (getTransSpan $1 $2) $2 }+| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }+| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }+| call VARIABLE '(' ARGUMENTS ')'+  { let alist = fromReverseList $4+    in StCall () (getTransSpan $1 $5) $2 (Just alist) }+| return { StReturn () (getSpan $1) Nothing }+| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }+| FORALL { $1 }+| END_FORALL { $1 }++ARGUMENTS :: { [ Argument A0 ] }+: ARGUMENTS ',' ARGUMENT { $3 : $1 }+| ARGUMENT { [ $1 ] }++ARGUMENT :: { Argument A0 }+: id '=' EXPRESSION+  { let TId span keyword = $1+    in Argument () (getTransSpan span $3) (Just keyword) $3 }+| EXPRESSION+  { Argument () (getSpan $1) Nothing $1 }++RENAME_LIST :: { [ Use A0 ] }+: RENAME_LIST ',' RENAME { $3 : $1 }+| RENAME { [ $1 ] }++RENAME :: { Use A0  }+: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }+| VARIABLE { UseID () (getSpan $1) $1 }++MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }++FORMAT_ID :: { Expression A0 }+: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| INTEGER_LITERAL { $1 }+| STRING { $1 }+| DATA_REF { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++UNIT :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| DATA_REF { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++CILIST :: { AList ControlPair A0 }+: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;+          cp2 = ControlPair () (getSpan $4) Nothing $4;+          tail = fromReverseList $6 }+    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }+| '(' CILIST_ELEMENT ',' FORMAT_ID ')'+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;+          cp2 = ControlPair () (getSpan $4) Nothing $4 }+    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }+| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;+          tail = fromReverseList $4 }+    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }+| '(' CILIST_ELEMENT ')'+  { let cp1 = ControlPair () (getSpan $2) Nothing $2+    in AList () (getTransSpan $1 $3) [ cp1 ] }+| '(' CILIST_PAIRS ')' { fromReverseList $2 }++CILIST_PAIRS :: { [ ControlPair A0 ] }+: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }+| CILIST_PAIR { [ $1 ] }++CILIST_PAIR :: { ControlPair A0 }+: id '=' CILIST_ELEMENT+  { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }++CILIST_ELEMENT :: { Expression A0 }+: CI_EXPRESSION { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++CI_EXPRESSION :: { Expression A0 }+: 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 }+| CI_EXPRESSION '/' CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| CI_EXPRESSION '**' CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| CI_EXPRESSION '/' '/' CI_EXPRESSION %prec CONCAT+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| ARITHMETIC_SIGN CI_EXPRESSION %prec SIGN+  { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| CI_EXPRESSION or CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| CI_EXPRESSION and CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| not CI_EXPRESSION+  { ExpUnary () (getTransSpan $1 $2) Not $2 }+| CI_EXPRESSION eqv CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }+| CI_EXPRESSION neqv CI_EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }+| CI_EXPRESSION RELATIONAL_OPERATOR CI_EXPRESSION %prec RELATIONAL+  { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| opCustom CI_EXPRESSION %prec DEFINED_UNARY+  { let TOpCustom span str = $1+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }+| CI_EXPRESSION opCustom CI_EXPRESSION+  { let TOpCustom _ str = $2+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }+| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| INTEGER_LITERAL { $1 }+| LOGICAL_LITERAL { $1 }+| STRING { $1 }+| DATA_REF { $1 }++IN_IOLIST :: { [ Expression A0 ] }+: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}+| IN_IO_ELEMENT { [ $1 ] }++IN_IO_ELEMENT :: { Expression A0 }+: DATA_REF { $1 }+| '(' IN_IOLIST ',' DO_SPECIFICATION ')'+  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }++OUT_IOLIST :: { [ Expression A0 ] }+: OUT_IOLIST ',' EXPRESSION { $3 : $1}+| EXPRESSION { [ $1 ] }++COMMON_GROUPS :: { [ CommonGroup A0 ] }+: COMMON_GROUPS COMMON_GROUP { $2 : $1 }+| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }+| INIT_COMMON_GROUP { [ $1 ] }++COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME PART_REFS+  { let alist = fromReverseList $2+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }+| '/' '/' PART_REFS+  { let alist = fromReverseList $3+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }++INIT_COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME PART_REFS+  { let alist = fromReverseList $2+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }+| '/' '/' PART_REFS+  { let alist = fromReverseList $3+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }+| PART_REFS+  { let alist = fromReverseList $1+    in CommonGroup () (getSpan alist) Nothing alist }++EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }+: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'+  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }+| '(' PART_REFS ')'+  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }++NAMELISTS :: { [ Namelist A0 ] }+: NAMELISTS NAMELIST { $2 : $1 }+| NAMELISTS ',2' NAMELIST { $3 : $1 }+| NAMELIST { [ $1 ] }++NAMELIST :: { Namelist A0 }+: '/' VARIABLE '/' VARIABLES+  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }++MAYBE_VARIABLES :: { Maybe (AList Expression A0) }+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }++VARIABLES :: { [ Expression A0 ] }+: VARIABLES ',' VARIABLE { $3 : $1 }+| VARIABLE { [ $1 ] }++IMP_LISTS :: { [ ImpList A0 ] }+: IMP_LISTS ',' IMP_LIST { $3 : $1 }+| IMP_LIST { [ $1 ] }++IMP_LIST :: { ImpList A0 }+: TYPE_SPEC '(2' IMP_ELEMENTS ')'+  { ImpList () (getTransSpan $1 $4) $1 (aReverse $3) }++IMP_ELEMENTS :: { AList ImpElement A0 }+: IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| IMP_ELEMENT { AList () (getSpan $1) [ $1 ] }++IMP_ELEMENT :: { ImpElement A0 }+: id {% do+      let (TId s id) = $1+      if length id /= 1+      then fail "Implicit argument must be a character."+      else return $ ImpCharacter () s id+     }+| id '-' id {% do+             let (TId _ id1) = $1+             let (TId _ id2) = $3+             if length id1 /= 1 || length id2 /= 1+             then fail "Implicit argument must be a character."+             else return $ ImpRange () (getTransSpan $1 $3) id1 id2+             }++PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }+: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }+| PARAMETER_ASSIGNMENT { [ $1 ] }++PARAMETER_ASSIGNMENT :: { Declarator A0 }+: VARIABLE '=' EXPRESSION+  { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }++DECLARATION_STATEMENT :: { Statement A0 }+: TYPE_SPEC ATTRIBUTE_LIST '::' 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+  { let { declAList = fromReverseList $2 }+    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }++ATTRIBUTE_LIST :: { [ Attribute A0 ] }+: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }+| {- EMPTY -} { [ ] }++ATTRIBUTE_SPEC :: { Attribute A0 }+: public { AttrPublic () (getSpan $1) }+| private { AttrPrivate () (getSpan $1) }+| allocatable { AttrAllocatable () (getSpan $1) }+| dimension '(' DIMENSION_DECLARATORS ')'+  { AttrDimension () (getTransSpan $1 $4) $3 }+| external { AttrExternal () (getSpan $1) }+| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }+| intrinsic { AttrIntrinsic () (getSpan $1) }+| optional { AttrOptional () (getSpan $1) }+| pointer { AttrPointer () (getSpan $1) }+| parameter { AttrParameter () (getSpan $1) }+| save { AttrSave () (getSpan $1) }+| target { AttrTarget () (getSpan $1) }++INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }++DATA_GROUPS :: { [ DataGroup A0 ] }+: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash+  { let { nameAList = fromReverseList $3;+          dataAList = fromReverseList $5 }+    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }+| DATA_LIST slash EXPRESSION_LIST slash+  { let { nameAList = fromReverseList $1;+          dataAList = fromReverseList $3 }+    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }++MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }++DATA_LIST :: { [ Expression A0 ] }+: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }+| DATA_ELEMENT { [ $1 ] }++DATA_ELEMENT :: { Expression A0 }+: DATA_REF { $1 } | IMPLIED_DO { $1 }++SAVE_ARGS :: { [ Expression A0 ] }+: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }++SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }++COMMON_NAME :: { Expression A0 }+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }++DECLARATOR_LIST :: { [ Declarator A0 ] }+: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }+| INITIALISED_DECLARATOR { [ $1 ] }++INITIALISED_DECLARATOR :: { Declarator A0 }+: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }+| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }+| DECLARATOR { $1 }++DECLARATOR :: { Declarator A0 }+: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }+| VARIABLE '*' EXPRESSION+  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }+| VARIABLE '*' '(' '*' ')'+  { let star = ExpValue () (getSpan $4) ValStar+    in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')'+  { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION+  { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'+  { let star = ExpValue () (getSpan $7) ValStar+    in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing }++DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }+: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| DIMENSION_DECLARATOR+  { AList () (getSpan $1) [ $1 ] }++DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }+: EXPRESSION ':' EXPRESSION+  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }+| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }+-- Lower bound only+| EXPRESSION ':'+  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }+| EXPRESSION ':' '*'+  { let { span = getSpan $3;+          star = ExpValue () span ValStar }+    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }+| '*'+  { let { span = getSpan $1;+          star = ExpValue () span ValStar }+    in DimensionDeclarator () span Nothing (Just star) }+| ':'+  { let span = getSpan $1+    in DimensionDeclarator () span Nothing Nothing }++TYPE_SPEC :: { TypeSpec A0 }+: integer KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real    KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }+| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }+| complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| type '(' id ')'+  { let TId _ id = $3+    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }++KIND_SELECTOR :: { Maybe (Selector A0) }+: '(' EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }+| '(' kind '=' EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }+| {- EMPTY -} { Nothing }++CHAR_SELECTOR :: { Maybe (Selector A0) }+: '*' EXPRESSION+  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }+-- The following rule is a bug in the spec.+-- | '*' EXPRESSION ','+--   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }+| '*' '(' '*' ')'+  { let star = ExpValue () (getSpan $3) ValStar+    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }+| '(' LEN_EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }+| '(' len '=' LEN_EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }+| '(' LEN_EXPRESSION ',' EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }+| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }+| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }+| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'+  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }+| {- EMPTY -} { Nothing }++LEN_EXPRESSION :: { Expression A0 }+: EXPRESSION { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++EXPRESSION :: { Expression A0 }+: 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 }+| EXPRESSION '/' EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| EXPRESSION '**' EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| EXPRESSION '/' '/' EXPRESSION %prec CONCAT+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| ARITHMETIC_SIGN EXPRESSION %prec SIGN+  { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| EXPRESSION or EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| EXPRESSION and EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| not EXPRESSION+  { ExpUnary () (getTransSpan $1 $2) Not $2 }+| EXPRESSION eqv EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }+| EXPRESSION neqv EXPRESSION+  { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }+| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL+  { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| opCustom EXPRESSION %prec DEFINED_UNARY+  { let TOpCustom span str = $1+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }+| EXPRESSION opCustom EXPRESSION+  { let TOpCustom _ str = $2+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| NUMERIC_LITERAL                   { $1 }+| '(' EXPRESSION ',' EXPRESSION ')'+  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }+| LOGICAL_LITERAL                   { $1 }+| STRING                            { $1 }+| DATA_REF                          { $1 }+| IMPLIED_DO                        { $1 }+| '(/' EXPRESSION_LIST '/)'+  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }+| operator '(' opCustom ')'+  { let TOpCustom _ op = $3+    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }+| assignment { ExpValue () (getSpan $1) ValAssignment }+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }++DATA_REFS :: { [ Expression A0 ] }+: DATA_REFS ',' DATA_REF { $3 : $1 }+| DATA_REF { [ $1 ] }++DATA_REF :: { Expression A0 }+: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }+| PART_REF { $1 }++PART_REFS :: { [ Expression A0 ] }+: PART_REFS ',' PART_REF { $3 : $1 }+| PART_REF { [ $1 ] }++PART_REF :: { Expression A0 }+: VARIABLE { $1 }+| VARIABLE '(' ')'+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+| VARIABLE '(' INDICIES ')'+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }+| VARIABLE '(' INDICIES ')' '(' INDICIES ')'+  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)+    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }++INDICIES :: { [ Index A0 ] }+: INDICIES ',' INDEX { $3 : $1 }+| INDEX { [ $1 ] }++INDEX :: { Index A0 }+: RANGE { $1 }+| RANGE ':' EXPRESSION+  { let IxRange () s lower upper _ = $1+    in IxRange () (getTransSpan s $3) lower upper (Just $3) }+| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }+-- Following is only as an intermediate stage before having been turned into+-- an argument by later transformation.+| id '=' EXPRESSION+  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }++RANGE :: { Index A0 }+: ':' { IxRange () (getSpan $1) Nothing Nothing Nothing }+| ':' EXPRESSION { IxRange () (getTransSpan $1 $2) Nothing (Just $2) Nothing }+| EXPRESSION ':' { IxRange () (getTransSpan $1 $2) (Just $1) Nothing Nothing }+| EXPRESSION ':' EXPRESSION+  { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }++DO_SPECIFICATION :: { DoSpecification A0 }+: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION+  { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }+| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION+  { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }++IMPLIED_DO :: { Expression A0 }+: '(' EXPRESSION ',' DO_SPECIFICATION ')'+  { let expList = AList () (getSpan $2) [ $2 ]+    in ExpImpliedDo () (getTransSpan $1 $5) expList $4 }+| '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')'+  { let expList = AList () (getTransSpan $2 $4) [ $2, $4 ]+    in ExpImpliedDo () (getTransSpan $1 $5) expList $6 }+| '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')'+  { let { exps =  reverse $6;+          expList = AList () (getTransSpan $2 exps) ($2 : $4 : reverse $6) }+    in ExpImpliedDo () (getTransSpan $1 $9) expList $8 }++FORALL :: { Statement A0 }+: id ':' forall FORALL_HEADER {+  let (TId s1 id) = $1 in+  let (h,s2) = $4 in+  StForall () (getTransSpan s1 s2) (Just id) h+}+| forall FORALL_HEADER {+  let (h,s) = $2 in+  StForall () (getTransSpan $1 s) Nothing h+}+| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT {+  let (h,_) = $2 in+  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_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 }++POINTER_ASSIGNMENT_STMT :: { Statement A0 }+POINTER_ASSIGNMENT_STMT :+ 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)}++EXPRESSION_LIST :: { [ Expression A0 ] }+: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }+| EXPRESSION { [ $1 ] }++ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }+: '-' { (getSpan $1, Minus) }+| '+' { (getSpan $1, Plus) }++RELATIONAL_OPERATOR :: { BinaryOp }+: '=='  { EQ }+| '!='  { NE }+| '>'   { GT }+| '>='  { GTE }+| '<'   { LT }+| '<='  { LTE }++VARIABLE :: { Expression A0 }+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }++NUMERIC_LITERAL :: { Expression A0 }+: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }++INTEGERS :: { [ Expression A0 ] }+: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }+| INTEGER_LITERAL { [ $1 ] }++INTEGER_LITERAL :: { Expression A0 }+: int { let TIntegerLiteral s i = $1 in ExpValue () s $ ValInteger i }+| boz { let TBozLiteral s i = $1 in ExpValue () s $ ValInteger i }++REAL_LITERAL :: { Expression A0 }+: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }++LOGICAL_LITERAL :: { Expression A0 }+: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }++STRING :: { Expression A0 }+: string { let TString s c = $1 in ExpValue () s $ ValString c }++cDATA :: { () } : {% pushContext ConData }+cIMPLICIT :: { () } : {% pushContext ConImplicit }+cNAMELIST :: { () } : {% pushContext ConNamelist }+cCOMMON :: { () } : {% pushContext ConCommon }+cPOP :: { () } : {% popContext }++{++unitNameCheck :: Token -> String -> Parse AlexInput Token ()+unitNameCheck (TId _ name1) name2+  | name1 == name2 = return ()+  | otherwise = fail "Unit name does not match the corresponding END statement."+unitNameCheck _ _ = return ()++parse = runParse programParser++transformations95 =+  [ GroupLabeledDo+  , GroupDo+  , GroupIf+  , GroupCase+  , DisambiguateIntrinsic+  , DisambiguateFunction+  ]++fortran95Parser ::+     B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+fortran95Parser sourceCode filename =+    (pfSetFilename filename . transform transformations95) <$> parse parseState+  where+    parseState = initParseState sourceCode Fortran95 filename++fortran95ParserWithModFiles ::+     ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+fortran95ParserWithModFiles mods sourceCode filename =+    fmap (pfSetFilename filename . transform) $ parse parseState+  where+    transform = transformWithModFiles mods transformations95+    parseState = initParseState sourceCode Fortran95 filename++parseError :: Token -> LexAction a+parseError token = do+    parseState <- get+#ifdef DEBUG+    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex+#endif+    fail $ psFilename parseState ++ ": parsing failed. "+      ++ specifics token+#ifdef DEBUG+      ++ '\n' : show tokens+#endif+  where specifics (TPause _) = "\nPAUSE statements are not supported in Fortran 95 or later. "+        specifics (TAssign _) = "\nASSIGN statements are not supported in Fortran 95 or later. "+        specifics _ = ""++}

@@ -26,7 +26,9 @@ data FortranVersion = Fortran66                     | Fortran77                     | Fortran77Extended+                    | Fortran77Legacy                     | Fortran90+                    | Fortran95                     | Fortran2003                     | Fortran2008                     deriving (Ord, Eq, Data, Typeable, Generic)@@ -35,7 +37,9 @@   show Fortran66 = "Fortran 66"   show Fortran77 = "Fortran 77"   show Fortran77Extended = "Fortran 77 Extended"+  show Fortran77Legacy = "Fortran 77 Legacy"   show Fortran90 = "Fortran 90"+  show Fortran95 = "Fortran 95"   show Fortran2003 = "Fortran 2003"   show Fortran2008 = "Fortran 2008" 

@@ -8,7 +8,7 @@ import Data.Maybe (isJust, isNothing) import Data.List (foldl') -import Prelude hiding (EQ,LT,GT)+import Prelude hiding (EQ,LT,GT,(<>))  import Language.Fortran.AST import Language.Fortran.ParserMonad@@ -108,12 +108,18 @@       where         nextI = incIndentation i -    pprint v (PUSubroutine _ _ isRec name mArgs body mSubs) i-      | isRec, v < Fortran90 = tooOld v "Recursive subroutine" Fortran90+    pprint v (PUSubroutine _ _ funcSpec name mArgs body mSubs) i+      | Pure _ _ _ <- funcSpec, v < Fortran95 = tooOld v "Pure subroutine" Fortran90+      | Elemental _ _ <- funcSpec, v < Fortran90 = tooOld v "Elemental subroutine" Fortran90+      | functionIsRecursive funcSpec, v < Fortran90 = tooOld v "Recursive subroutine" Fortran90       | isJust mSubs, v < Fortran90 = tooOld v "Subroutine subprogram" Fortran90       | otherwise =         indent curI-          ((if isRec then "recursive" else empty) <+>+          ((case funcSpec of+            (Elemental _ _) -> "elemental"+            (Pure _ _ _) -> "pure"+            otherwise -> empty) <+>+          (if functionIsRecursive funcSpec then "recursive" else empty) <+>           "subroutine" <+> text name <>           lparen <?> pprint' v mArgs <?> rparen <> newline) <>         pprint v body nextI <>@@ -128,14 +134,20 @@                     then incIndentation i                     else incIndentation fixedForm -    pprint v (PUFunction _ _ mRetType isRec name mArgs mRes body mSubs) i-      | isRec, v < Fortran90 = tooOld v "Recursive function" Fortran90+    pprint v (PUFunction _ _ mRetType fSpec name mArgs mRes body mSubs) i+      | (Elemental _ _) <- fSpec, v < Fortran95 = tooOld v "Elemental function" Fortran90+      | (Pure _ _ _) <- fSpec, v < Fortran95 = tooOld v "Pure function" Fortran90+      | functionIsRecursive fSpec, v < Fortran90 = tooOld v "Recursive function" Fortran90       | isJust mRes, v < Fortran90 = tooOld v "Function result" Fortran90       | isJust mSubs, v < Fortran90 = tooOld v "Function subprogram" Fortran90       | otherwise =         indent curI           (pprint' v mRetType <+>-          (if isRec then "recursive" else empty) <+>+          (case fSpec of+            (Elemental _ _) -> "elemental"+            (Pure _ _ _) -> "pure"+            otherwise -> empty) <+>+          (if functionIsRecursive fSpec then "recursive" else empty) <+>           "function" <+> text name <>           lparen <?> pprint' v mArgs <?> rparen <+>           "result" <?> lparen <?> pprint' v mRes <?> rparen <> newline) <>@@ -262,13 +274,15 @@             then indent i (pprint' v label <+> stDoc)             else pprint' v mLabel `overlay` indent i stDoc -    pprint v (BlDoWhile _ _ mLabel mName cond body el) i+    pprint v (BlDoWhile _ _ mLabel mName mTarget cond body el) i        | v >= Fortran77Extended =         labeledIndent mLabel           (pprint' v mName <?> colon <+>-          "do while" <+> parens (pprint' v cond) <> newline) <>+          "do" <+> pprint' v mTarget <+> "while" <+> parens (pprint' v cond) <> newline) <>         pprint v body nextI <>-        labeledIndent el ("end do" <+> pprint' v mName <> newline)+        if isJust mTarget && isNothing mName+          then empty+          else labeledIndent el ("end do" <+> pprint' v mName <> newline)       | otherwise = tooOld v "Do while loop" Fortran77Extended       where         nextI = incIndentation i@@ -308,7 +322,11 @@       | otherwise = tooOld v "Character data type" Fortran77     pprint' v (TypeCustom str)       | v >= Fortran90 = "type" <+> parens (text str)+      | v >= Fortran77Extended = "record" <+> char '/' <> text str <> char '/'       | otherwise = tooOld v "User defined type" Fortran90+    pprint' v TypeByte+      | v >= Fortran77Extended = "byte"+      | otherwise = tooOld v "Byte" Fortran77Extended  instance Pretty (TypeSpec a) where     pprint' v (TypeSpec _ _ baseType mSelector) =@@ -348,6 +366,13 @@           text "::" <+>           pprint' v declList +    pprint' v st@(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 (StIntent _ _ intent exps)       | v >= Fortran90 =           "intent" <+> parens (pprint' v intent) <+> "::" <+> pprint' v exps@@ -389,6 +414,10 @@       | v >= Fortran90 = "data" <+> pprint' v aDataGroups       | otherwise = "data" <+> hsep (map (pprint' v) dataGroups) +    pprint' v (StAutomatic _ _ decls)+      | v == Fortran77Extended = "automatic" <+> pprint' v decls+      | otherwise = tooOld v "Target statement" Fortran90+     pprint' v (StNamelist _ _ namelist)       | v >= Fortran90 = "namelist" <+> pprint' v namelist       | otherwise = tooOld v "Namelist statement" Fortran90@@ -421,7 +450,7 @@         pprint' v name <+> parens (pprint' v mArgs) <+>         "result (" <?> pprint' v mResult <?> char ')' -    pprint' v (StInclude _ _ file) = "include" <+> pprint' v file+    pprint' v (StInclude _ _ file _) = "include" <+> pprint' v file      pprint' v (StDo _ s mConstructor mLabel mDoSpec)       | v < Fortran90@@ -555,6 +584,10 @@       "write" <+> parens (pprint' v cilist) <+> pprint' v mIolist     pprint' v (StPrint _ _ formatId mIolist) =       "print" <+> pprint' v formatId <> comma <?+> pprint' v mIolist+    pprint' v (StTypePrint _ _ formatId mIolist)+      | v == Fortran77Extended+      = "type" <+> pprint' v formatId <> comma <?+> pprint' v mIolist+      | otherwise = tooOld v "Type (print) statement" Fortran77Extended      pprint' v (StOpen _ _ cilist) = "open" <+> parens (pprint' v cilist)     pprint' v (StClose _ _ cilist) = "close" <+> parens (pprint' v cilist)@@ -769,6 +802,20 @@     pprint' v (ValString str) = quotes $ text str     pprint' v valLit = text . getFirstParameter $ valLit +instance IndentablePretty (StructureItem a) where+  pprint v (StructFields a s spec mAttrs decls) i = pprint' v (StDeclaration a s spec mAttrs decls)+  pprint v (StructUnion _ _ maps) i =+    "union" <> newline <>+    foldl' (\doc item -> doc <> pprint v item (incIndentation i) <> newline) empty (aStrip maps) <>+    "end union"+  pprint v (StructStructure a s mName items) i = pprint' v (StStructure a s mName items)++instance IndentablePretty (UnionMap a) where+  pprint v (UnionMap _ _ items) i =+    "map" <> newline <>+    foldl' (\doc item -> doc <> pprint v item (incIndentation i) <> newline) empty (aStrip items) <>+    "end map"+ instance Pretty (Declarator a) where     pprint' v (DeclVariable _ _ e mLen mInit)       | v >= Fortran90 =@@ -835,6 +882,7 @@     pprint' v EQ  = if v <= Fortran77Extended then ".eq." else "=="     pprint' v NE  = if v <= Fortran77Extended then ".ne." else "/="     pprint' v Or  = ".or."+    pprint' v XOr = ".xor."     pprint' v And = ".and."     pprint' v Equivalent       | v >= Fortran77 = ".eqv."

@@ -33,6 +33,9 @@     expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies)       | Just (IDType _ (Just CTFunction)) <- idType a       , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+    expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies)+      | Just (IDType _ (Just CTExternal)) <- idType a+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)     expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValIntrinsic _)) indicies)       | Just (IDType _ (Just CTIntrinsic)) <- idType a       , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)

@@ -1,38 +1,71 @@-module Language.Fortran.Transformation.Grouping ( groupIf+module Language.Fortran.Transformation.Grouping ( groupForall+                                                , groupIf                                                 , groupDo                                                 , groupLabeledDo                                                 , groupCase                                                 ) where  import Language.Fortran.AST+import Language.Fortran.Util.Position import Language.Fortran.Analysis import Language.Fortran.Transformation.TransformMonad +import Data.Data+import Data.Generics.Uniplate.Operations -genericGroup :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Transform a ()+type ABlocks a = [ Block (Analysis a) ]++genericGroup :: Data a => (ABlocks a -> ABlocks a) -> Transform a () genericGroup groupingFunction =-    modifyProgramFile $-      \(ProgramFile mi pus) ->-        ProgramFile mi (map go pus)+    modifyProgramFile $ transformBi groupingFunction++--------------------------------------------------------------------------------+-- Grouping FORALL statement blocks into FORALL blocks in entire parse tree+--------------------------------------------------------------------------------+groupForall :: Data a => Transform a ()+groupForall = genericGroup groupForall'+++groupForall' :: ABlocks a -> ABlocks a+groupForall' [] = []+groupForall' (b:bs) = b' : bs'   where-    go pu =-      case pu of-        PUMain a s n bs subPUs                  ->-          PUMain a s n (groupingFunction bs) (map go <$> subPUs)-        PUModule a s n bs subPUs                ->-          PUModule a s n (groupingFunction bs) (map go <$> subPUs)-        PUSubroutine a s r n as bs subPUs       ->-          PUSubroutine a s r n as (groupingFunction bs) (map go <$> subPUs)-        PUFunction a s r rec n as res bs subPUs ->-          PUFunction a s r rec n as res (groupingFunction bs) (map go <$> subPUs)-        bd@PUBlockData {}                       -> bd -- Block data cannot have any if statements.-        c@PUComment {}                          -> c+    (b', bs') = case b of+      BlStatement a s label st+        | StForall _ _ mTarget header <- st ->+          let ( blocks, leftOverBlocks, endLabel ) =+               collectNonForallBlocks groupedBlocks mTarget+          in ( BlForall a (getTransSpan s blocks) label mTarget header blocks endLabel+             , leftOverBlocks)+        | StForallStatement _ _ header st' <- st ->+          let block = BlStatement a (getSpan st') Nothing st' in+          ( BlForall a (getTransSpan s st') label Nothing header [block] Nothing, groupedBlocks )+      b | containsGroups b ->+        ( applyGroupingToSubblocks groupForall' b, groupedBlocks )+      _ -> (b, groupedBlocks)+    groupedBlocks = groupForall' bs +collectNonForallBlocks :: ABlocks a -> Maybe String+                          -> ( ABlocks a+                             , ABlocks a+                             , Maybe (Expression (Analysis a)) )+collectNonForallBlocks blocks mNameTarget =+  case blocks of+    b@(BlStatement _ _ mLabel (StEndForall _ _ mName)):rest+      | mName == mNameTarget -> ([], rest, mLabel)+      | otherwise ->+        error "Forall block name does not match that of the end statement."+    b:bs ->+      let (bs', rest, mLabel) = collectNonForallBlocks bs mNameTarget+      in (b : bs', rest, mLabel)+    _ -> error "Premature file ending while parsing structured forall block."++ -------------------------------------------------------------------------------- -- Grouping if statement blocks into if blocks in entire parse tree -------------------------------------------------------------------------------- -groupIf :: Transform a ()+groupIf :: Data a => Transform a () groupIf = genericGroup groupIf'  -- Actual grouping is done here.@@ -44,9 +77,9 @@ --        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 contianing any other statement:+-- 2. Case: head is a statement block containing any other statement: -- 2.1  Group everything to the right and prepend the head.-groupIf' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ]+groupIf' :: ABlocks a -> ABlocks a groupIf' [] = [] groupIf' (b:bs) = b' : bs'   where@@ -82,10 +115,10 @@ -- 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 :: [ Block (Analysis a) ]+decomposeIf :: ABlocks a             -> ( [ Maybe (Expression (Analysis a)) ],-                 [ [ Block (Analysis a) ] ],-                 [ Block (Analysis a) ],+                 [ ABlocks a ],+                 ABlocks a,                  Maybe (Expression (Analysis a)) ) decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):rest) =     decomposeIf' blocks@@ -109,7 +142,7 @@          , endLabel )  -- This compiles the executable blocks under various if conditions.-collectNonConditionalBlocks :: [ Block (Analysis a) ] -> ([ Block (Analysis a) ], [ Block (Analysis a) ])+collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a) collectNonConditionalBlocks blocks =   case blocks of     BlStatement _ _ _ StElsif{}:_ -> ([], blocks)@@ -129,20 +162,20 @@ -- Grouping new do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- -groupDo :: Transform a ()+groupDo :: Data a => Transform a () groupDo = genericGroup groupDo' -groupDo' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ]+groupDo' :: ABlocks a -> ABlocks a groupDo' [ ] = [ ] groupDo' blocks@(b:bs) = b' : bs'   where     (b', bs') = case b of       BlStatement a s label st         -- Do While statement-        | StDoWhile _ _ mTarget _ condition <- st ->+        | StDoWhile _ _ mTarget Nothing condition <- st ->           let ( blocks, leftOverBlocks, endLabel ) =                 collectNonDoBlocks groupedBlocks mTarget-          in ( BlDoWhile a (getTransSpan s blocks) label mTarget condition blocks endLabel+          in ( BlDoWhile a (getTransSpan s blocks) label mTarget Nothing condition blocks endLabel              , leftOverBlocks)         -- Vanilla do statement         | StDo _ _ mName Nothing doSpec <- st ->@@ -155,9 +188,9 @@       _ -> ( b, groupedBlocks )     groupedBlocks = groupDo' bs -- Assume everything to the right is grouped. -collectNonDoBlocks :: [ Block (Analysis a) ] -> Maybe String-                   -> ( [ Block (Analysis a)]-                      , [ Block (Analysis a) ]+collectNonDoBlocks :: ABlocks a -> Maybe String+                   -> ( ABlocks a+                      , ABlocks a                       , Maybe (Expression (Analysis a)) ) collectNonDoBlocks blocks mNameTarget =   case blocks of@@ -174,10 +207,10 @@ -- Grouping labeled do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- -groupLabeledDo :: Transform a ()+groupLabeledDo :: Data a => Transform a () groupLabeledDo = genericGroup groupLabeledDo' -groupLabeledDo' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ]+groupLabeledDo' :: ABlocks a -> ABlocks a groupLabeledDo' [ ] = [ ] groupLabeledDo' blos@(b:bs) = b' : bs'   where@@ -189,6 +222,13 @@               lastLabel = getLastLabel $ last blocks           in ( BlDo a (getTransSpan s blocks) label mn tl doSpec blocks lastLabel              , leftOverBlocks )+      BlStatement a s label+        (StDoWhile _ _ mn tl@Just{} cond) ->+          let ( blocks, leftOverBlocks ) =+                collectNonLabeledDoBlocks tl groupedBlocks+              lastLabel = getLastLabel $ last blocks+          in ( BlDoWhile a (getTransSpan s blocks) label mn tl cond blocks lastLabel+             , leftOverBlocks )       b | containsGroups b ->         ( applyGroupingToSubblocks groupLabeledDo' b, groupedBlocks )       _ -> (b, groupedBlocks)@@ -197,8 +237,8 @@     groupedBlocks = groupLabeledDo' bs  -collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> [ Block (Analysis a) ]-                          -> ([ Block (Analysis a) ], [ Block (Analysis a) ])+collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> ABlocks a+                          -> (ABlocks a, ABlocks a) collectNonLabeledDoBlocks targetLabel blocks =   case blocks of     -- Didn't find a statement with matching label; don't group@@ -212,17 +252,20 @@  compLabel :: Maybe (Expression a) -> Maybe (Expression a) -> Bool compLabel (Just (ExpValue _ _ (ValInteger l1)))-          (Just (ExpValue _ _ (ValInteger l2))) = l1 == l2+          (Just (ExpValue _ _ (ValInteger l2))) = strip l1 == strip l2 compLabel _ _ = False +strip :: String -> String+strip = dropWhile (=='0')+ -------------------------------------------------------------------------------- -- Grouping case statements -------------------------------------------------------------------------------- -groupCase :: Transform a ()+groupCase :: Data a => Transform a () groupCase = genericGroup groupCase' -groupCase' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ]+groupCase' :: ABlocks a -> ABlocks a groupCase' [] = [] groupCase' (b:bs) = b' : bs'   where@@ -239,10 +282,10 @@     groupedBlocks = groupCase' bs -- Assume everything to the right is grouped.     isComment b = case b of { BlComment{} -> True; _ -> False } -decomposeCase :: [ Block (Analysis a) ] -> Maybe String+decomposeCase :: ABlocks a -> Maybe String               -> ( [ Maybe (AList Index (Analysis a)) ]-                 , [ [ Block (Analysis a) ] ]-                 , [ Block (Analysis a) ]+                 , [ ABlocks a ]+                 , ABlocks a                  , Maybe (Expression (Analysis a)) ) decomposeCase blocks@(BlStatement _ _ mLabel st:rest) mTargetName =     case st of@@ -265,7 +308,7 @@          , rest', endLabel )  -- This compiles the executable blocks under various if conditions.-collectNonCaseBlocks :: [ Block (Analysis a) ] -> ([ Block (Analysis a) ], [ Block (Analysis a) ])+collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a) collectNonCaseBlocks blocks =   case blocks of     b@(BlStatement _ _ _ st):_@@ -290,7 +333,7 @@     BlInterface{} -> False     BlComment{} -> False -applyGroupingToSubblocks :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Block (Analysis a) -> Block (Analysis a)+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."@@ -298,7 +341,7 @@   | 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 doSpec blocks el <- b = BlDoWhile a s l n 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 =

@@ -13,7 +13,8 @@ import Language.Fortran.AST (ProgramFile)  data Transformation =-    GroupIf+    GroupForall+  | GroupIf   | GroupCase   | GroupDo   | GroupLabeledDo@@ -23,7 +24,8 @@  transformationMapping :: Data a => [ (Transformation, Transform a ()) ] transformationMapping =-  [ (GroupIf, groupIf)+  [ (GroupForall, groupForall)+  , (GroupIf, groupIf)   , (GroupCase, groupCase)   , (GroupDo, groupDo)   , (GroupLabeledDo, groupLabeledDo)

@@ -8,6 +8,7 @@ import Data.Text.Encoding.Error (replace)  import Text.PrettyPrint (render)+import Text.Read  import System.Console.GetOpt @@ -84,7 +85,7 @@                   sgr = genSuperBBGr bbm        case actionOpt of-        Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended ] ->+        Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended, Fortran77Legacy ] ->           print $ FixedForm.collectFixedTokens version contents         Lex | version `elem` [Fortran90, Fortran2003, Fortran2008] ->           print $ FreeForm.collectFreeTokens version contents@@ -100,14 +101,17 @@  -- List files in dir rGetDirContents :: String -> IO [String]-rGetDirContents d = do+rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d'+  where+  go seen d = do     ds <- getDirectoryContents d     fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries       where         f x = do-          g <- doesDirectoryExist (d ++ "/" ++ x)-          if g then do-            x' <- rGetDirContents (d ++ "/" ++ x)+          path <- canonicalizePath $ d ++ "/" ++ x+          g <- doesDirectoryExist path+          if g && not (path `elem` seen) then do+            x' <- go (path : seen) path             return $ map (\ y -> x ++ "/" ++ y) x'           else return [x] @@ -208,8 +212,8 @@ options =   [ Option ['v']       ["fortranVersion"]-      (ReqArg (\v opts -> opts { fortranVersion = Just $ read v }) "VERSION")-      "Fortran version to use, format: Fortran[66/77/77Extended/90]"+      (ReqArg (\v opts -> opts { fortranVersion = readMaybe v }) "VERSION")+      "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]"   , Option ['a']       ["action"]       (ReqArg (\a opts -> opts { action = read a }) "ACTION")@@ -257,18 +261,21 @@     header = "Usage: forpar [OPTION...] <lex|parse> <file>"  instance Read FortranVersion where-  readsPrec _ value =-    let options = [ ("66", Fortran66)-                  , ("77e", Fortran77Extended)-                  , ("77", Fortran77)-                  , ("90", Fortran90)-                  , ("03", Fortran2003)-                  , ("08", Fortran2008)] in-      tryTypes options-      where-        tryTypes [] = []-        tryTypes ((attempt,result):xs) =-          if attempt `isInfixOf` value then [(result, "")] else tryTypes xs+  readsPrec _ value = tryTypes options+    where+      value' = map toLower value+      options = [ ("66" , Fortran66)+                , ("77e", Fortran77Extended)+                , ("77l", Fortran77Legacy)+                , ("77" , Fortran77)+                , ("90" , Fortran90)+                , ("95" , Fortran95)+                , ("03" , Fortran2003)+                , ("08" , Fortran2008) ]+      tryTypes [] = []+      tryTypes ((attempt,result):xs)+          | attempt `isInfixOf` value' = [(result, "")]+          | otherwise = tryTypes xs  instance {-# OVERLAPPING #-} Show [ FixedForm.Token ] where   show = unlines . lines'

@@ -0,0 +1,134 @@+module Language.Fortran.Analysis.BBlocksSpec where++import Test.Hspec+import TestUtil++import Language.Fortran.Parser.Fortran77+import Language.Fortran.Lexer.FixedForm (initParseState)+import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe)+import Language.Fortran.AST+import Language.Fortran.Analysis+import Language.Fortran.Analysis.BBlocks+import Language.Fortran.Analysis.Renaming+import qualified Data.Map as M+import qualified Data.IntSet as IS+import Data.Graph.Inductive+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.Maybe+import qualified Data.ByteString.Char8 as B++pParser :: String -> ProgramFile (Analysis ())+pParser source = rename . analyseBBlocks . analyseRenames . initAnalysis . fromParseResultUnsafe+               $ extended77Parser (B.pack source) "<unknown>"++spec :: Spec+spec =+  describe "Basic Blocks" $ do+    describe "loop4" $ do+      it "nodes and edges length" $ do+        let pf = pParser programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let ns = nodes gr+        let es = edges gr+        (length ns, length es) `shouldBe` (11, 12)+      it "branching nodes" $ do+        let pf = pParser programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20])) `shouldBe` (2, 2)+      it "all reachable" $ do+        let pf = pParser programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let reached = IS.fromList $ dfs [0] gr+        let nodeSet = IS.fromList $ nodes gr+        reached `shouldBe` nodeSet+      it "all terminate" $ do+        let pf = pParser programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let reached = IS.fromList $ rdfs [-1] gr+        let nodeSet = IS.fromList $ nodes gr+        reached `shouldBe` nodeSet+    describe "if arith" $ do+      it "nodes and edges length" $ do+        let pf = pParser programArithIf+        let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf+        let ns = nodes gr+        let es = edges gr+        (length ns, length es) `shouldBe` (6, 7)+      it "branching nodes" $ do+        let pf = pParser programArithIf+        let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf+        (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20]), IS.size (findSuccsBB gr [30])) `shouldBe` (1, 1, 1)+      it "all reachable" $ do+        let pf = pParser programArithIf+        let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf+        let reached = IS.fromList $ dfs [0] gr+        let nodeSet = IS.fromList $ nodes gr+        reached `shouldBe` nodeSet+      it "all terminate" $ do+        let pf = pParser programArithIf+        let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf+        let reached = IS.fromList $ rdfs [-1] gr+        let nodeSet = IS.fromList $ nodes gr+        reached `shouldBe` nodeSet++--------------------------------------------------+-- Label-finding helper functions to help write tests that are+-- insensitive to minor changes to the AST.++-- For each label in the list, find the corresponding basic block,+-- return as an IntSet.+findLabelsBB :: BBGr a -> [Int] -> IS.IntSet+findLabelsBB gr = IS.fromList . mapMaybe (flip findLabeledBBlock gr . show)++findLabelBB :: BBGr a -> Int -> Node+findLabelBB gr = (error "findLabelBB" `fromMaybe`) . flip findLabeledBBlock gr . show++-- For each label in the list, find the successors of the+-- corresponding basic block, return as an IntSet.+findSuccsBB :: BBGr a -> [Int] -> IS.IntSet+findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show)++--------------------------------------------------+-- Test programs++programLoop4 = unlines [+      "      program loop4"+    , "      integer r, i, j"+    , ""+    , "      r = 0"+    , ""+    , "c     outer loop"+    , "      i = 1"+    , " 10   if (i .gt. 10) goto 40"+    , ""+    , "c     inner loop"+    , "      j = 1"+    , " 20   if (j .gt. 5) goto 30"+    , "      r = r + i * j"+    , "      j = j + 1"+    , "      goto 20"+    , "c     inner loop end"+    , ""+    , " 30   i = i + 1"+    , "      goto 10"+    , "c     outer loop end"+    , ""+    , " 40   write (*,*) r"+    , "      end"+  ]++programArithIf = unlines [+    "      program arithif"+  , "      integer n"+  , "      n = 0"+  , "      if (n) 10, 20, 30"+  , " 10   write (*,*) 10"+  , " 20   write (*,*) 20"+  , " 30   write (*,*) 30"+  , "      end"]+++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,414 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Fortran.Analysis.DataFlowSpec where++import Test.Hspec+import TestUtil++import Language.Fortran.Parser.Fortran77+import qualified Language.Fortran.Parser.Fortran90 as F90+import Language.Fortran.Lexer.FixedForm (initParseState)+import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe)+import Language.Fortran.AST+import Language.Fortran.Analysis+import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming)+import Language.Fortran.Analysis.BBlocks+import Language.Fortran.Analysis.DataFlow+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Graph.Inductive+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.Maybe+import Data.List+import Data.Data+import Data.Generics.Uniplate.Operations+import qualified Data.ByteString.Char8 as B++data F77 = F77+data F90 = F90++class Parser t where+    parser :: t -> String -> String -> ProgramFile A0+instance Parser F77 where+    parser F77 src file = fromParseResultUnsafe $ extended77Parser (B.pack src) file+instance Parser F90 where+    parser F90 src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file++pParser :: Parser t => t -> String -> ProgramFile (Analysis ())+pParser version source = rename . analyseBBlocks . analyseRenames . initAnalysis+                                . resetSrcSpan $ parser version source "<unknown>"++withParse :: Data a => Parser t => t -> String -> (ProgramFile (Analysis A0) -> a) -> a+withParse version source f = underRenaming (f . analyseBBlocks) (parser version source "<unknown>")++testGraph version f p = fromJust . M.lookup (Named f) . withParse version p $ genBBlockMap+testPfAndGraph version f p = fmap (fromJust . M.lookup (Named f)) . withParse version p $ \ pf -> (pf, genBBlockMap pf)++testGenDefMap version = flip (withParse version) (genDefMap . genBlockMap . analyseBBlocks . initAnalysis)++testBackEdges version f p = bedges+  where+    gr     = testGraph version f p+    domMap = dominators gr+    bedges = genBackEdgeMap domMap gr++spec :: Spec+spec =+  describe "Dataflow" $ do+  ----------------------------------------------+    let pf = pParser F77 programLoop4+    describe "loop4" $ do+      it "genBackEdgeMap" $ do+        let gr = testGraph F77 "loop4" programLoop4+        testBackEdges F77 "loop4" programLoop4 `shouldBe`+          IM.fromList [(findLabelBB gr 8, findLabelBB gr 10), (findLabelBB gr 7, findLabelBB gr 20)]++      it "loopNodes" $ do+        let pf = pParser F77 programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let domMap = dominators gr+        let bedges = genBackEdgeMap domMap gr+        S.fromList (loopNodes bedges gr) `shouldBe`+          S.fromList [findLabelsBB gr [5,6,7,20], IS.unions [findLabelsBB gr [4,5,6,7,8,10,20,30], findSuccsBB gr [20]]]++      it "genDefMap" $+        testGenDefMap F77 programLoop4 `shouldBe`+          M.fromList [("i",findLabelsBl pf [3,30]),("j",findLabelsBl pf [4,6]),("r",findLabelsBl pf [2,5])]++      it "reachingDefinitions" $ do+        let pf = pParser F77 programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let bm = genBlockMap pf+        let dm = genDefMap bm+        IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe`+          Just (findLabelsBl pf [2,3,4,5,6,30], findLabelsBl pf [3,4,5,6,30])++      it "flowsTo" $ do+        let pf = pParser F77 programLoop4+        let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf+        let bm = genBlockMap pf+        let dm = genDefMap bm+        (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe`+          -- Find the flows of the assignment statements in the program.+          findLabelsBlEdges pf [(2,5),(2,40)            -- r = 0+                               ,(3,5),(3,10),(3,30)     -- i = 1+                               ,(4,5),(4,6),(4,20)      -- j = 1+                               ,(5,5),(5,40)            -- r = r + i * j+                               ,(6,5),(6,6),(6,20)      -- j = j + 1+                               ,(30,5),(30,10),(30,30)  -- i = i + 1+                               ]++  ----------------------------------------------+    let pf = pParser F90 programLoop4Alt+    let sgr = genSuperBBGr (genBBlockMap pf)+    let gr = superBBGrGraph sgr+    let domMap = dominators gr+    let bedges = genBackEdgeMap domMap gr+    let bm = genBlockMap pf+    let dm = genDefMap bm++    describe "loop4 alt (module)" $ do+      it "genBackEdgeMap" $ do+        let gr = testGraph F90 "loop4" programLoop4Alt+        testBackEdges F90 "loop4" programLoop4Alt `shouldBe`+          IM.fromList [(findLabelBB gr 22, findLabelBB gr 20), (findLabelBB gr 31, findLabelBB gr 10)]++      it "loopNodes" $ do+        S.fromList (loopNodes bedges gr) `shouldBe`+          S.fromList [findLabelsBB gr [20,21,22], findLabelsBB gr [10,11,20,21,22,31,40]]++      it "genDefMap" $+        testGenDefMap F90 programLoop4Alt `shouldBe`+          M.fromList [("i",findLabelsBl pf [2,31]),("j",findLabelsBl pf [11,22]),("r",findLabelsBl pf [1,21])]++      it "reachingDefinitions" $ do+        IM.lookup (findLabelBB gr 21) (reachingDefinitions dm gr) `shouldBe`+          Just (findLabelsBl pf [1,2,11,21,22,31], findLabelsBl pf [2,11,21,22,31])++      it "flowsTo" $ do+        (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe`+          -- Find the flows of the assignment statements in the program.+          findLabelsBlEdges pf [(1,21),(1,41)           -- r = 0+                               ,(2,10),(2,21),(2,31)    -- i = 1+                               ,(11,20),(11,21),(11,22) -- j = 1+                               ,(21,21),(21,41)         -- r = r + i * j+                               ,(22,20),(22,21),(22,22) -- j = j + 1+                               ,(31,10),(31,21),(31,31) -- i = i + 1+                               ]++    -----------------------------------------------++    describe "rd3" $ do+      it "genBackEdgeMap" $ do+        let gr = testGraph F77 "f" programRd3+        testBackEdges F77 "f" programRd3 `shouldBe` IM.singleton (findLabelBB gr 4) (findLabelBB gr 1)++      it "loopNodes" $ do+        let (pf, gr) = testPfAndGraph F77 "f" programRd3+        let domMap = dominators gr+        let bedges = genBackEdgeMap domMap gr+        S.fromList (loopNodes bedges gr) `shouldBe`+          S.fromList [findLabelsBB gr [1,2,3,4]]++      it "reachingDefinitions" $ do+        let (pf, gr) = testPfAndGraph F77 "f" programRd3+        let bm = genBlockMap pf+        let dm = genDefMap bm+        IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe`+          Just (IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3]]+               ,IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3,5]])++      it "flowsTo" $ do+        let (pf, gr) = testPfAndGraph F77 "f" programRd3+        let bm = genBlockMap pf+        let dm = genDefMap bm+        (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldSatisfy`+          -- Find the flows of the assignment statements in the program.+          S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3) -- do 4  i = 2, 10+                                             ,(2,3)       -- b(i) = a(i-1) + x+                                             ,(3,2),(3,5) -- a(i) = b(i)+                                             ])++    describe "rd4" $ do+      it "ivMapByASTBlock" $ do+        let (pf, gr) = testPfAndGraph F77 "f" programRd4+        let domMap = dominators gr+        let bedges = genBackEdgeMap domMap gr+        let ivMap  = genInductionVarMapByASTBlock bedges gr+        (sort . map (\ x -> (head x, length x)) . group . sort . map S.size $ IM.elems ivMap) `shouldBe` [(1,3),(2,3)]++    describe "bug36" $ do+      let pf = pParser F90 programBug36+      let sgr = genSuperBBGr (genBBlockMap pf)+      let gr = superBBGrGraph sgr+      let domMap = dominators gr+      let bedges = genBackEdgeMap domMap gr+      it "loopNodes" $ do+        length (loopNodes bedges gr) `shouldBe` 2++    describe "funcflow1" $ do+      let pf = pParser F90 programFuncFlow1+      let sgr = genSuperBBGr (genBBlockMap pf)+      let gr = superBBGrGraph sgr+      let bm = genBlockMap pf+      let dm = genDefMap bm+      let rDefs = reachingDefinitions dm gr+      let flTo = genFlowsToGraph bm dm gr rDefs+      let domMap = dominators gr+      let bedges = genBackEdgeMap domMap gr+      let diMap = genDerivedInductionMap bedges gr+      it "flowsTo" $ do+        (S.fromList . edges . trc $ flTo) `shouldSatisfy`+          -- Find the flows of the assignment statements in the program.+          S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)])++    describe "funcflow2" $ do+      let pf = pParser F90 programFuncFlow2+      let sgr = genSuperBBGr (genBBlockMap pf)+      let gr = superBBGrGraph sgr+      let bm = genBlockMap pf+      let dm = genDefMap bm+      let rDefs = reachingDefinitions dm gr+      let flTo = genFlowsToGraph bm dm gr rDefs+      let domMap = dominators gr+      let bedges = genBackEdgeMap domMap gr+      let diMap = genDerivedInductionMap bedges gr+      let (iLabel, iName):_ = [ (fromJust (insLabel a), varName e)+                              | e@(ExpValue a _ (ValVariable _)) <- rhsExprs pf, srcName e == "i" ]+      let (jLabel, jName):_ = [ (fromJust (insLabel a), varName e)+                              | e@(ExpValue a _ (ValVariable _)) <- lhsExprs pf, srcName e == "j" ]+      it "flowsTo" $ do+        (S.fromList . edges . trc $ flTo) `shouldSatisfy`+          -- Find the flows of the assignment statements in the program.+          S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)])+      it "derivedInduction" $ do+        IM.lookup iLabel diMap `shouldBe` Just (IELinear iName 1 0)+        IM.lookup jLabel diMap `shouldBe` Just (IELinear iName 6 2)++    describe "other" $ do+      it "dominators on disconnected graph" $ do+        dominators (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)] :: Gr () ())) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])]++--------------------------------------------------+-- Label-finding helper functions to help write tests that are+-- insensitive to minor changes to the AST.++-- For each Fortran label in the list, find the corresponding basic+-- block, return as an IntSet.+findLabelsBB :: BBGr a -> [Int] -> IS.IntSet+findLabelsBB gr = IS.fromList . mapMaybe (flip findLabeledBBlock gr . show)++findLabelBB :: BBGr a -> Int -> Node+findLabelBB gr = (error "findLabelBB" `fromMaybe`) . flip findLabeledBBlock gr . show++-- For each Fortran label in the list, find the successors of the+-- corresponding basic block, return as an IntSet.+findSuccsBB :: BBGr a -> [Int] -> IS.IntSet+findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show)++-- For each Fortran label in the list, find the AST-block label numbers ('insLabel') associated+findLabelsBl :: forall a. Data a => ProgramFile (Analysis a) -> [Int] -> IS.IntSet+findLabelsBl pf labs = IS.fromList [ i | b <- universeBi pf :: [Block (Analysis a)]+                                       , ExpValue _ _ (ValInteger lab') <- maybeToList (getLabel b)+                                       , lab' `elem` labsS+                                       , let a = getAnnotation b+                                       , i <- maybeToList (insLabel a) ]+  where labsS = map show labs++-- Translate a list of edges given as Fortran labels into a set of+-- edges given as AST-block label numbers.+findLabelsBlEdges :: Data a => ProgramFile (Analysis a) -> [(Int, Int)] -> S.Set (Int, Int)+findLabelsBlEdges pf = S.fromList . map convEdge+  where+    convEdge (a, b)+      | a':_ <- IS.toList (findLabelsBl pf [a]) -- FIXME: inefficient+      , b':_ <- IS.toList (findLabelsBl pf [b]) = (a', b')+      | otherwise = error $ "findLabelsBlEdges (" ++ show a ++ "," ++ show b ++ ")"++-- Get the set of AST-block labels found in a given basic block+findBBlockBl :: BBGr (Analysis a) -> Int -> IS.IntSet+findBBlockBl gr = IS.fromList . mapMaybe (insLabel . getAnnotation) . concat . maybeToList . lab gr++--------------------------------------------------+-- Test programs++programLoop4 = unlines [+      "      program loop4"+    , " 1    integer r, i, j"+    , ""+    , " 2    r = 0"+    , ""+    , " 3    i = 1"+    , " 10   if (i .gt. 10) goto 40"+    , ""+    , " 4    j = 1"+    , " 20   if (j .gt. 5) goto 30"+    , " 5    r = r + i * j"+    , " 6    j = j + 1"+    , " 7    goto 20"+    , ""+    , " 30   i = i + 1"+    , " 8    goto 10"+    , ""+    , " 40   write (*,*) r"+    , "      end"+  ]++programLoop4Alt = unlines [+      "      module loopMod"+    , "      implicit none"+    , "      contains"+    , "      subroutine loop4()"+    , "      integer r, i, j"+    , ""+    , " 1    r = 0"+    , ""+--    , "!     outer loop"+    , " 2    i = 1"+    , " 10   do while (i .gt. 10)"+    , ""+--    , "!     inner loop"+    , " 11   j = 1"+    , " 20   do while (j .gt. 5)"+    , " 21   r = r + i * j"+    , " 22   j = j + 1"+    , "      end do"+--    , "!     inner loop end"+    , ""+    , " 31   i = i + 1"+    , "      end do"+--    , "!     outer loop end"+    , ""+    , " 41   write (*,*) r"+    , "      end subroutine"+    , "      end module"+  ]++programRd3 = unlines [+      "      function f(x)"+    , "      integer i, a, b, x, f"+    , "      dimension a(10), b(10)"+    , ""+    , " 1    do 4  i = 2, 10"+    , " 2       b(i) = a(i-1) + x"+    , " 3       a(i) = b(i)"+    , " 4    continue"+    , " 5    f = a(10)"+    , "      end"+    , "      program rd3"+    , "      implicit none"+    , "      integer f"+    , ""+    , "      write (*,*) f(1)"+    , "      end"+    , ""+    ]++programRd4 = unlines [+      "      function f(x)"+    , "      integer i, j, a, b, x, f"+    , "      dimension a(10), b(10)"+    , ""+    , "      do 10 i = 2, 10"+    , "      do 20 j = 2, 10"+    , "         b(i) = a(i-1) + x"+    , " 20   continue"+    , "         a(i) = b(i)"+    , " 10   continue"+    , "      f = a(10)"+    , "      end"+    , "      program rd3"+    , "      implicit none"+    , "      integer f"+    , ""+    , "      write (*,*) f(1)"+    , "      end"+    , ""+    ]++-- do not use line numbers+programBug36 = unlines [+      "program foo"+    , "  implicit none"+    , "  integer :: i, j"+    , "  real, dimension(100) :: a, b"+    , "  do i=1,100"+    , "     do j=1,100"+    , "      a(i) = b(i) + b(1)"+    , "     end do"+    , "  end do"+    , "end program"+    ]++programFuncFlow1 = unlines [+      "      program main"+    , "        integer :: i, j"+    , " 1      i = 1"+    , " 2      j = f(i)"+    , "      contains"+    , "        integer function f(k)"+    , "          integer :: k"+    , " 3        f = k + 1"+    , "        end function f"+    , "      end program main"+    ]++programFuncFlow2 = unlines [+      "      program main"+    , "        integer :: i, j"+    , " 1      do i = 1, 10"+    , " 2         j = 2*f(3*i)"+    , "        end do"+    , "      contains"+    , "        integer function f(k)"+    , "          integer :: k"+    , " 3        f = k + 1"+    , "        end function f"+    , "      end program main"+    ]++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,371 @@+module Language.Fortran.Analysis.RenamingSpec (spec) where++import Test.Hspec+import TestUtil++import Data.Map ((!), elems)+import qualified Data.Map as M+import Data.List++import Language.Fortran.ParserMonad+import Language.Fortran.AST+import Language.Fortran.Util.Position+import qualified Language.Fortran.Parser.Fortran90 as F90+import Language.Fortran.Analysis+import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming)+import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.Operations+import Data.Data+import qualified Data.ByteString.Char8 as B++import Debug.Trace++testF90 pf = (resetSrcSpan . analyseRenames . initAnalysis) $ pf+extractNameMap' = extractNameMap . analyseRenames . initAnalysis+unrename' = stripAnalysis . unrename . rename . analyseRenames . initAnalysis+renameAndStrip' x = stripAnalysis . rename . analyseRenames . initAnalysis $ x++countUnrenamed e = length [ () | ExpValue (Analysis { uniqueName = Nothing }) _ (ValVariable {}) <- uniE_PF e ]+  where uniE_PF :: ProgramFile (Analysis ()) -> [Expression (Analysis ())]+        uniE_PF = universeBi++fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file++spec :: Spec+spec = do+  describe "Basic" $ do+    it "num-entries 1" $ do+      let entry = extractNameMap' ex3+      shouldBe ( length (filter (=="f1") (elems entry))+               , length (filter (=="a") (elems entry))+               , length (filter (=="b") (elems entry))+               , length (filter (=="d") (elems entry)) )+               ( 1, 2, 2, 2 )++    -- Test that every symbol that is supposed to be renamed is renamed.+    it "complete ex1" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex1) `shouldBe` 0+    it "complete ex2" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex2) `shouldBe` 0+    it "complete ex3" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex3) `shouldBe` 0+    it "complete ex4" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex4) `shouldBe` 0+    it "complete ex5" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex5) `shouldBe` 0+    it "complete ex6" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex6) `shouldBe` 0+    it "complete ex8" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex8) `shouldBe` 0+    it "complete ex9" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex9) `shouldBe` 0+    it "complete ex10" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex10) `shouldBe` 0+    it "complete ex11" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex11) `shouldBe` 0+    it "complete ex12" $ do+      countUnrenamed (analyseRenames . initAnalysis $ ex12) `shouldBe` 0++    it "complete exScope1" $ do+      countUnrenamed (analyseRenames . initAnalysis $ exScope1) `shouldBe` 0+    it "complete exScope2" $ do+      countUnrenamed (analyseRenames . initAnalysis $ exScope2) `shouldBe` 0++    it "functions 1" $ do+      let entry = extractNameMap' ex3+      length (filter (=="f1") (elems entry)) `shouldBe'` 1++  describe "Identity" $ do+    it "unrename-rename 1" $ do+      let entry = unrename' ex1+      entry `shouldBe'` ex1++    it "unrename-rename 2" $ do+      let entry = unrename' ex2+      entry `shouldBe'` ex2++    it "unrename-rename 3" $ do+      let entry = unrename' ex3+      entry `shouldBe'` ex3++    it "unrename-rename 4" $ do+      let entry = unrename' ex4+      entry `shouldBe'` ex4++  describe "Shadowing" $ do+    it "exScope1 testing non-shadowing of subprogram names" $ do+      let entry = extractNameMap' exScope1+      let keys = M.keys entry+      length keys `shouldBe` 1++    it "exScope2 testing shadowing of variables" $ do+      let entry = extractNameMap' exScope2+      length (filter (=="x") (elems entry)) `shouldBe` 2++  describe "Ordering" $ do+    it "exScope3 testing out-of-order definitions" $ do+      let entry = extractNameMap' exScope3+      length (filter (=="f1") (elems entry)) `shouldBe` 1+      length (filter (=="f2") (elems entry)) `shouldBe` 1+      length (filter (=="s1") (elems entry)) `shouldBe` 1+      length (filter (=="s2") (elems entry)) `shouldBe` 1++--------------------------------------------------++ex1 = ProgramFile mi77 [ ex1pu1 ]+ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing++ex2 = ProgramFile mi77 [ ex2pu1 ]+ex2pu1 = PUMain () u (Just "main") ex2pu1bs Nothing+ex2pu1bs =+  [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u+      [ DeclVariable () u (varGen "a") Nothing Nothing+      , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing+      , DeclVariable () u (varGen "c") Nothing Nothing+      , DeclVariable () u (varGen "d") Nothing Nothing ]))+  , BlStatement () u Nothing (StDimension () u (AList () u+      [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ]))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "c") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "d") (AList () u [ ixSinGen 1 ])) (intGen 1)) ]++ex3 = ProgramFile mi77 [ ex3pu1, ex3pu2 ]+ex3pu1 = PUMain () u (Just "main") ex3pu1bs Nothing+ex3pu1bs =+  [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u+      [ DeclVariable () u (varGen "a") Nothing Nothing+      , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing+      , DeclVariable () u (varGen "c") Nothing Nothing+      , DeclVariable () u (varGen "d") Nothing Nothing ]))+  , BlStatement () u Nothing (StDimension () u (AList () u+      [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ]))+  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u+      [ DeclVariable () u (varGen "c") Nothing Nothing ]))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "c") (AList () u [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (varGen "d") (ExpBinary () u Addition (varGen "d") (intGen 1))) ]+ex3pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "d", varGen "b"]) Nothing (ex3pu1bs ++ [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "d")) ]) Nothing++ex4 = ProgramFile mi77 [ ex4pu1, ex4pu2 ]+ex4pu1 = PUMain () u (Just "main") ex4pu1bs Nothing+ex4pu1bs =+  [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u+      [ DeclVariable () u (varGen "f1") Nothing Nothing+      , DeclVariable () u (varGen "r") Nothing Nothing ]))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpValue () u (ValVariable "r"))+      (ExpFunctionCall () u (ExpValue () u (ValVariable "f1"))+                            (Just $ AList () u [ Argument () u Nothing $ intGen 1 ]))) ]+ex4pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing++ex5 = ProgramFile mi77 [ ex5pu1, ex5pu2 ]+ex5pu1 = PUMain () u (Just "main") ex5pu1bs Nothing+ex5pu1bs = []+ex5pu2 = PUModule () u "ex5mod" ex5pu2bs (Just [ex5pu2pu1])+ex5pu2bs = []+ex5pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing+++ex6 = ProgramFile mi77 [ ex6pu1, ex6pu2 ]+ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing+ex6pu1bs = []+ex6pu2 = PUModule () u "ex6mod" ex6pu2bs (Just [ex6pu2pu1])+ex6pu2bs = []+ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [Argument () u Nothing (varGen "x")]))) ] (Just [ex5pu2pu1])++parseF90 = resetSrcSpan . flip fortran90Parser "" . unlines++ex8 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module m1"+  , "  implicit none"+  , "contains"+  , "  integer function foo ()"+  , "    foo = 0"+  , "  end function foo"+  , "end module m1"+  , ""+  , "module m2"+  , "  implicit none"+  , "contains"+  , "  integer function foo2 (x)"+  , "    use m1"+  , "    integer :: x"+  , "    foo2 = foo () + x"+  , "  end function foo2"+  , "end module m2"+  , ""+  , "module m3"+  , "  implicit none"+  , "contains"+  , "  integer function foo () result (r)"+  , "    r = 1"+  , "  end function foo"+  , "end module m3"+  , ""+  , "program main"+  , "  use m1"+  , "  integer :: x"+  , "  x = foo ()"+  , "end program main"+  ]++ex9 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module m1"+  , "  implicit none"+  , "  integer :: x"+  , "contains"+  , "  integer function f () result (x)"+  , "    integer :: x"+  , "    x = 0"+  , "  end function f"+  , "  subroutine s ()"+  , "    x = 0"+  , "  end subroutine s"+  , "end module m1"+  ]++ex10 = ProgramFile mi77 [ ex10pu1 ]+ex10pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex10pu1bs Nothing+ex10pu1bs =+  [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ]++ex11 = ProgramFile mi77 [ ex11pu1 ]+ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing+ex11pu1bs =+  [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ]++ex12 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module m1"+  , "  implicit none"+  , "  integer :: z"+  , "contains"+  , "  integer function foo ()"+  , "    foo = 0"+  , "  end function foo"+  , "end module m1"+  , ""+  , "module m2"+  , "  implicit none"+  , "contains"+  , "  integer function foo2 (x)"+  , "    use m1"+  , "    integer :: x"+  , "    foo2 = foo () + x"+  , "  end function foo2"+  , "end module m2"+  , ""+  , "module m3"+  , "  implicit none"+  , "contains"+  , "  integer function foo () result (r)"+  , "    r = 1"+  , "  end function foo"+  , "end module m3"+  , ""+  , "program main"+  , "  use m1, only: z"+  , "  use m3, only: foo"+  , "  integer :: x"+  , "  x = foo ()"+  , "end program main"+  ]+++exScope1 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "program scope1"+  -- local variables cannot take on the name of subprogram, therefore+  -- this declaration must be simply redeclaring the function x.+  , "  integer :: x"+  , ""+  , "  print *, x()" -- function use prior to definition is OK+  , ""+  , "end program scope1"+  , "integer function x ()"+  , "  x = 1"+  , "end function x"+  , ""+  ]++exScope2 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module scope2"+  , "  integer :: x"+  , "contains"+  , "  subroutine s1 ()"+  , "    ! this is variable shadowing"+  , "    integer :: x"+  , "    x = 1"+  , "    print *, x"+  , "    call s2 ()"+  , "    print *, x"+  , "  contains"+  , "    subroutine s2"+  , "      ! reference to outside variable"+  , "      x = 2"+  , "    end subroutine s2"+  , "  end subroutine s1"+  , "end module scope2"+  , ""+  , "program main"+  , "  use scope2"+  , "  x = 0"+  , "  print *, x"+  , "  call s1 ()"+  , "  print *, x"+  , "  ! should print 0 at end"+  , "end program main"+  ]++exScope3 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module m1"+  , "  implicit none"+  , "  integer :: x"+  , "contains"+  , ""+  , "  subroutine s1 ()"+  , "    call s2 (f1(x))"+  , "  end subroutine s1"+  , ""+  , "  integer function f1(x)"+  , "    integer :: x, f2"+  , "    f1 = f2(x)"+  , "  end function f1"+  , ""+  , ""+  , "end module m1"+  , ""+  , "program main"+  , "  use m1"+  , "  implicit none"+  , "  call s1()"+  , "  print *, f1(x)"+  , "end program main"+  , ""+  , "subroutine s2 (x)"+  , "  integer :: x, f2"+  , "  x = f2 (x)"+  , "end subroutine s2"+  , ""+  , "function f2(x)"+  , "  integer :: x, f2"+  , "  f2 = x + 1"+  , "end function f2"+  ]++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,160 @@+module Language.Fortran.Analysis.TypesSpec where++import Test.Hspec+import TestUtil++import Data.Map ((!))++import Data.Data+import Language.Fortran.AST+import Language.Fortran.Analysis.Types+import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming)+import Language.Fortran.Analysis+import qualified Language.Fortran.Parser.Fortran90 as F90+import Language.Fortran.ParserMonad+import qualified Data.ByteString.Char8 as B++import Debug.Trace++inferTable :: Data a => ProgramFile a -> TypeEnv+inferTable = underRenaming (snd . analyseTypes)++fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file++spec :: Spec+spec = do+  describe "Global type inference" $ do+    it "types integer returning function" $ do+      let entry = inferTable ex1 ! "f1"+      entry `shouldBe` IDType (Just TypeInteger) (Just CTFunction)++    it "types multiples program units" $ do+      let mapping = inferTable ex2+      mapping ! "f1" `shouldBe` IDType (Just TypeInteger) (Just CTFunction)+      mapping ! "s1" `shouldBe` IDType Nothing (Just CTSubroutine)++    it "types ENTRY points within subprograms" $ do+      let mapping = inferTable ex3+      mapping ! "e1" `shouldBe` IDType Nothing (Just CTSubroutine)+      mapping ! "e2" `shouldBe` IDType Nothing (Just CTSubroutine)+      mapping ! "e3" `shouldBe` IDType Nothing (Just CTSubroutine)++  describe "Local type inference" $ do+    it "infers from type declarations" $ do+      let mapping = inferTable ex4+      mapping ! "x" `shouldBe` IDType (Just TypeInteger) (Just CTVariable)+      mapping ! "y" `shouldBe` IDType (Just TypeInteger) (Just CTArray)+      mapping ! "c" `shouldBe` IDType (Just TypeCharacter) (Just CTVariable)+      mapping ! "log" `shouldBe` IDType (Just TypeLogical) (Just CTVariable)++    it "infers from dimension declarations" $ do+      let mapping = inferTable ex5+      mapping ! "x" `shouldBe` IDType Nothing (Just CTArray)+      mapping ! "y" `shouldBe` IDType Nothing (Just CTArray)++    it "infers from function statements" $ do+      let mapping = inferTable ex6+      mapping ! "a" `shouldBe` IDType (Just TypeInteger) (Just CTArray)+      mapping ! "b" `shouldBe` IDType (Just TypeInteger) (Just CTArray)+      mapping ! "c" `shouldBe` IDType (Just TypeInteger) (Just CTFunction)+      mapping ! "d" `shouldBe` IDType Nothing (Just CTFunction)++    describe "Intrinsics type analysis" $ do+      it "disambiguates intrinsics from functions and variables" $ do+        let mapping = inferTable intrinsics1+        idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic+        idCType (mapping ! "dabs") `shouldBe` Just CTFunction+        idCType (mapping ! "cabs") `shouldBe` Just CTArray++ex1 = ProgramFile mi77 [ ex1pu1 ]+ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing++ex2 = ProgramFile mi77 [ ex2pu1, ex1pu1 ]+ex2pu1 = PUSubroutine () u (None () u False) "s1" Nothing [] Nothing++ex3 = ProgramFile mi77 [ ex3pu1 ]+ex3pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex3pu1bs Nothing+ex3pu1bs =+  [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ]++ex4 = ProgramFile mi77 [ ex4pu1 ]+ex4pu1 = PUMain () u Nothing ex4pu1bs Nothing+ex4pu1bs =+  [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing+      (AList () u+        [ DeclVariable () u (varGen "x") Nothing Nothing+        , DeclArray () u (varGen "y")+            (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10) ]) Nothing Nothing ]))+  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing+      (AList () u [ DeclVariable () u (varGen "c") Nothing Nothing ]))+  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeLogical Nothing) Nothing+      (AList () u [ DeclVariable () u (varGen "log") Nothing Nothing ])) ]++ex5 = ProgramFile mi77 [ ex5pu1 ]+ex5pu1 = PUBlockData () u (Just "bd") ex5pu1bs+ex5pu1bs =+  [ BlStatement () u Nothing (StDimension () u (AList () u+      [ DeclArray () u (varGen "x") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing+      , DeclArray () u (varGen "y") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing])) ]++{-+- program Main+- integer a, b(1), c+- dimension a(1)+- a(1) = 1+- b(1) = 1+- c(x) = 1+- d(x) = 1+- end+-}+ex6 = ProgramFile mi77 [ ex6pu1 ]+ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing+ex6pu1bs =+  [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u+      [ DeclVariable () u (varGen "a") Nothing Nothing+      , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing+      , DeclVariable () u (varGen "c") Nothing Nothing ]))+  , BlStatement () u Nothing (StDimension () u (AList () u+      [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ]))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "a") (fromList () [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "b") (fromList () [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "c") (fromList () [ ixSinGen 1 ])) (intGen 1))+  , BlStatement () u Nothing (StExpressionAssign () u+      (ExpSubscript () u (varGen "d") (fromList () [ ixSinGen 1 ])) (intGen 1)) ]++ex11 = ProgramFile mi77 [ ex11pu1 ]+ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing+ex11pu1bs =+  [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing)+  , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ]+++intrinsics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [+    "module intrinsics"+  , "contains"+  , "  subroutine main()"+  , "    real :: x"+  , "    integer :: y = 1"+  , "    real :: cabs(3)"+  , "    x = dabs(y)"+  , "    x = cabs(y)"+  , "    x = abs(y)"+  , "    print *, x"+  , "  end subroutine main"+  , "  real function dabs(a)"+  , "    integer :: a"+  , "    dabs = a"+  , "  end function dabs"+  , "end module intrinsics"+  ]++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,63 @@+module Language.Fortran.AnalysisSpec where++import Test.Hspec+import TestUtil++import Language.Fortran.Parser.Fortran77+import Language.Fortran.Lexer.FixedForm (initParseState)+import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe)+import Language.Fortran.AST+import Language.Fortran.Analysis+import Data.Graph.Inductive+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.List+import Data.Maybe+import qualified Data.ByteString.Char8 as B++pParser :: String -> ProgramFile (Analysis ())+pParser source = initAnalysis+               . fromParseResultUnsafe+               $ extended77Parser (B.pack source) "<unknown>"++spec :: Spec+spec =+  describe "Analysis" $ do+    describe "anal1" $ do+      it "lhsExprs" $ do+        let pf = stripAnalysis $ pParser programAnal1+        lhsExprs pf `shouldMatchList'` programAnal1LhsExprs++programAnal1LhsExprs =+  [ ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 1 ])+  , ExpSubscript () u (ExpValue () u (ValVariable "a"))+      (AList () u [ IxSingle () u Nothing $+                             ExpSubscript () u (varGen "a")+                                          (AList () u [ ixSinGen 2 ])])+  , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 4 ])+  , ExpValue () u (ValVariable "f")+  , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 6 ])+  , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 5 ]) ]++programAnal1 = unlines $ map (replicate 6 ' '++) [+      "program anal1"+    , "integer a, f"+    , "dimension a(10)"+    , "a(1) = f(a(6))"+    , "a(a(2)) = a(10)"+    , "call s(1)"+    , "call s(a(4))"+    , "call s(f(a(5)))"+    , "end"+    , "subroutine s(x)"+    , "integer x"+    , "end"+    , "function f(x)"+    , "integer x, f"+    , "f = x"+    , "end"+  ]++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,281 @@+module Language.Fortran.Lexer.FixedFormSpec where++import Language.Fortran.ParserMonad+import Language.Fortran.Lexer.FixedForm++import Test.Hspec+import Test.Hspec.QuickCheck+import TestUtil++import Control.Monad.State.Lazy+import Control.Exception++import Data.List (isPrefixOf)+import qualified Data.ByteString.Char8 as B++lex66 :: String -> Maybe Token+lex66 = collectToLex Fortran66++safeLex66 :: String -> Maybe Token+safeLex66 = collectToLexSafe Fortran66++lex77 :: String -> Maybe Token+lex77 = collectToLex Fortran77++collectToLex :: FortranVersion -> String -> Maybe Token+collectToLex version srcInput = dropUntil2 $ collectFixedTokens version (B.pack srcInput)+  where+    dropUntil2 [] = Nothing+    dropUntil2 [_] = Nothing+    dropUntil2 [a,_] = Just a+    dropUntil2 (x:xs) = dropUntil2 xs++collectToLexSafe :: FortranVersion -> String -> Maybe Token+collectToLexSafe version srcInput = dropUntil2 $ collectFixedTokensSafe version (B.pack srcInput)+  where+    dropUntil2 (Just [a,_]) = Just a+    dropUntil2 (Just (x:xs)) = dropUntil2 $ Just xs+    dropUntil2 _ = Nothing++collectFixedTokens' v = collectFixedTokens v . B.pack++spec :: Spec+spec =+  describe "Fortran Fixed Form Lexer" $ do+    describe "Fortran 77" $+      describe "String" $ do+        it "lexes 'hello'" $+          resetSrcSpan (lex77 "      c = 'hello'") `shouldBe` resetSrcSpan (Just $ TString u "hello")++        it "lexes 'he''llo'" $+          resetSrcSpan (lex77 "      c = 'he''llo'") `shouldBe` resetSrcSpan (Just $ TString u "he'llo")++        it "lexes 'he''''ll''o'" $+          resetSrcSpan (lex77 "      c = 'he''''ll''o'") `shouldBe` resetSrcSpan (Just $ TString u "he''ll'o")++        it "lexes '''hello'''" $+          resetSrcSpan (lex77 "      c = '''hello'''") `shouldBe` resetSrcSpan (Just $ TString u "'hello'")++        it "lexes 'hello world'" $+          resetSrcSpan (lex77 "      c = 'hello world'") `shouldBe` resetSrcSpan (Just $ TString u "hello world")++        it "lexes 'hello world'" $+          resetSrcSpan (collectFixedTokens' Fortran77 "      c = 'x' // 'o'") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "x", TSlash u, TSlash u, TString u "o", TEOF u]++    describe "Fortran 66" $ do+      prop "lexes Label, Comment, Newline or EOF in the first six columns or returns Nothing " $+        \x -> isPrefixOf "      " x || case safeLex66 x of+                Nothing -> True+                Just (TLabel _ _) -> True+                Just (TComment _ _) -> True+                Just (TEOF _) -> True+                Just (TNewline _) -> True+                _ -> False++      it "lexes alphanumeric identifier" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      e42 =") `shouldBe` resetSrcSpan [TId u "e42", TOpAssign u, TEOF u]++      it "lexes exponent" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 42 e42") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "42", TExponent u "e42", TEOF u]++      it "lexes 'function foo()'" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      function foo()") `shouldBe` resetSrcSpan [TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]++      it "lexes 'end'" $+        resetSrcSpan (lex66 "      end") `shouldBe` resetSrcSpan (Just $ TEnd u)++      it "lexes identifier" $+        resetSrcSpan (lex66 "      a = mistr") `shouldBe` resetSrcSpan (Just $ TId u "mistr")++      it "lexes comment if first column is C" $+        resetSrcSpan (lex66 "c this is a comment") `shouldBe` resetSrcSpan (Just $ TComment u " this is a comment")++      it "lexes empty comment" $+        resetSrcSpan (lex66 "c") `shouldBe` resetSrcSpan (Just $ TComment u "")++      it "lexes comment with one char" $+        resetSrcSpan (lex66 "ca") `shouldBe` resetSrcSpan (Just $ TComment u "a")++      it "should not lex from the next line" $+        resetSrcSpan (safeLex66 "cxxx\nselam") `shouldNotBe` resetSrcSpan (Just $ TComment u "xxxselam")++      -- This is commented out as identifiers are longer than what the standard says.+      it "lexes three tokens"  $ do+        pending+        resetSrcSpan (collectFixedTokens' Fortran66 "      function end format") `shouldBe` resetSrcSpan [TFunction u, TId u "endfor", TId u "mat", TEOF u]++      it "lexes multiple comments in a line" $+        resetSrcSpan (collectFixedTokens' Fortran66 "csomething\ncsomething else\n\nc\ncc\n") `shouldBe`+          resetSrcSpan [TComment u "something", TNewline u, TComment u "something else", TNewline u, TNewline u, TComment u "", TNewline u, TComment u "c", TNewline u, TEOF u]++      it "lexes example1" $+        resetSrcSpan (collectFixedTokens' Fortran66 example1) `shouldBe` resetSrcSpan example1Expectation++      it "lexes end of file" $+        resetSrcSpan (lex66 "") `shouldBe` Nothing++      it "lexes '3 + 2'" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 3 + 2") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "3", TOpPlus u , TInt u "2", TEOF u]++      it "should lex continuation lines properly" $+        resetSrcSpan (collectFixedTokens' Fortran66 continuationExample) `shouldBe` resetSrcSpan [ TType u "integer", TId u "ix", TNewline u, TId u "ix", TOpAssign u, TInt u "42", TNewline u, TEnd u, TNewline u, TEOF u ]++      it "lexes 'ASSIGN 100 TO FOO'" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      ASSIGN 100 TO FOO") `shouldBe` resetSrcSpan [TAssign u, TInt u "100", TTo u, TId u "foo", TEOF u]++      it "lexes 'DO 100 dovar = 1, 10'" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      DO 100 dovar = 1, 10")+          `shouldBe`+          resetSrcSpan [TDo u, TInt u "100", TId u "dovar", TOpAssign u, TInt u "1", TComma u, TInt u "10", TEOF u]++    describe "lexN" $+      it "`lexN 5` parses lexes next five characters" $+        (lexemeMatch . aiLexeme) (evalParse (lexN 5 >> getAlex) (initParseState (B.pack "helloWorld") Fortran66 "")) `shouldBe` reverse "hello"++    describe "lexHollerith" $ do+      it "lexes Hollerith '7hmistral'" $+        resetSrcSpan (lex66 "      x = 7hmistral") `shouldBe` resetSrcSpan (Just $ THollerith u "mistral")++      it "becomes case sensitive" $+        resetSrcSpan (collectFixedTokens' Fortran66 "      format (5h a= 1)") `shouldBe` resetSrcSpan [ TFormat u, TBlob u "(5ha=1)", TEOF u ]++    it "lexes if statement '        IF (IY) 5,6,6'" $+      resetSrcSpan (collectFixedTokens' Fortran66 "      IF (IY) 5,6,6") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "iy", TRightPar u, TInt u "5", TComma u, TInt u "6", TComma u, TInt u "6", TEOF u]++    it "lexes if then statement '      if (x) then'" $+      resetSrcSpan (collectFixedTokens' Fortran77 "      if (x) then") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "x", TRightPar u, TThen u, TEOF u]++    it "lexes if variable decl '      INTEGER IF'" $  -- yes, really..+      resetSrcSpan (collectFixedTokens' Fortran77 "      INTEGER IF")+        `shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u]++    describe "Fortran 77 Legacy" $ do+      it "lexes inline comments" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer foo ! bar")+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u]++      it "lexes continuation lines separated by comments" $ do+        let src = unlines [ "      integer foo,"+                          , "C hello"+                          , "     +        bar"+                          ]+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]+        let src = unlines [ "      integer foo, ! hello"+                          , "     +        bar"+                          ]+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]+        let src = unlines [ "      integer foo,"+                          , ""+                          , "     +        bar"+                          ]+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]+        let src = unlines [ "      integer foo,"+                          , "  " -- the space is intentional+                          , "     +        bar"+                          ]+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]++      it "lexes the older TYPE statement" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      type *, 'hello'")+          `shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u]++      it "lexes width-specific type declarations" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 i")+          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TId u "i", TEOF u]++        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 function foo()")+          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]++        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*4 s")+          `shouldBe` resetSrcSpan [TType u "character", TStar u, TInt u "4", TId u "s", TEOF u]++        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*(*) s")+          `shouldBe` resetSrcSpan [TType u "character", TStar u, TLeftPar u, TStar u, TRightPar u, TId u "s", TEOF u]++        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character s*(*)")+          `shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u]++      it "lexes strings case-sensitively" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = 'Hello'")+          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u]++      it "lexes strings delimited by '\"'" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = \"hello\"")+          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u]++      it "lexes Hollerith constants" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hmistral")+          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "mistral", TEOF u]++        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hshort\n")+          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short  ", TNewline u, TEOF u]++      it "lexes BOZ constants" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i, j, k / b'0101', o'0755', z'ab01' /")+          `shouldBe` resetSrcSpan [ TType u "integer", TId u "i", TComma u, TId u "j", TComma u, TId u"k"+                                  , TSlash u, TBozInt u "b'0101'", TComma u, TBozInt u "o'0755'", TComma u, TBozInt u "z'ab01'", TSlash u+                                  , TEOF u ]++      it "lexes non-standard identifiers" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer _this_is_a_long_identifier$")+          `shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u]++      it "lexes ';' as a line-terminator" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i; integer j")+          `shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u]++      it "lexes subscripts in assignments" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x(0,0) = 0")+          `shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u]++      it "lexes labeled DO WHILE blocks" $ do+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      do 10 while (.true.)")+          `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u ".true.", TRightPar u, TEOF u]+++      it "lexes structure/union/map blocks" $ do+        let src = unlines [ "      structure /foo/"+                          , "        union"+                          , "          map"+                          , "            integer i"+                          , "            real r"+                          , "          end map"+                          , "        end union"+                          , "      end structure"]+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)+          `shouldBe` resetSrcSpan [ TStructure u, TSlash u, TId u "foo", TSlash u, TNewline u+                                  , TUnion u, TNewline u+                                  , TMap u, TNewline u+                                  , TType u "integer", TId u "i", TNewline u+                                  , TType u "real", TId u "r", TNewline u+                                  , TEndMap u, TNewline u+                                  , TEndUnion u, TNewline u+                                  , TEndStructure u, TNewline u+                                  , TEOF u ]++example1 = unlines [+  "      intEGerix",+  "1         iX= 42",+  " 200    ix =IX* ix",+  " 10   wrITe (*,*), ix",+  "        EnD" ]++continuationExample = unlines [+  "      inte",+  "     .ger i",+  "     .x",+  "      ix = 4",+  "     .2",+  "      end"]++example1Expectation = [+  TType u "integer", TId u "ix", TNewline u,+  TLabel u "1", TId u "ix", TOpAssign u, TInt u "42", TNewline u,+  TLabel u "200", TId u "ix", TOpAssign u, TId u "ix", TStar u, TId u "ix", TNewline u,+  TLabel u "10", TWrite u, TLeftPar u, TStar u, TComma u, TStar u, TRightPar u, TComma u, TId u "ix", TNewline u,+  TEnd u, TNewline u,+  TEOF u]

@@ -0,0 +1,263 @@+module Language.Fortran.Lexer.FreeFormSpec where++import Test.Hspec+import TestUtil++import Data.Maybe (fromJust)++import Language.Fortran.ParserMonad (FortranVersion(..))+import Language.Fortran.Lexer.FreeForm (collectFreeTokens, Token(..))+import qualified Data.ByteString.Char8 as B++import Debug.Trace++collectF90 :: String -> [ Token ]+collectF90 = collectFreeTokens Fortran90 . B.pack++pseudoAssign token = fmap ($u) [ flip TId "i", TOpAssign, token, TEOF ]++spec :: Spec+spec =+  describe "Fortran Free Form Lexer" $+    describe "Fortran 90" $ do+      describe "Character sensitivity" $ do+        it "lexes lower case tokens" $+          shouldBe' (collectF90 "integer id") $+                    fmap ($u) [ TInteger, flip TId "id", TEOF ]++        it "lexes mixed case tokens" $+          shouldBe' (collectF90 "InTEgeR ID") $+                    fmap ($u) [ TInteger, flip TId "id", TEOF ]++      describe "Identifier" $ do+        it "lexes long ID names" $+          shouldBe' (collectF90 "program long_id_name") $+                    fmap ($u) [ TProgram, flip TId "long_id_name", TEOF ]++        it "treats 'if' as ID if used in assignment" $+          shouldBe' (collectF90 "if = 20") $+                    fmap ($u) [ flip TId "if", TOpAssign+                              , flip TIntegerLiteral "20", TEOF ]++        it "'result' is an identifier in spec. context" $+          shouldBe' (collectF90 "integer :: result") $+                    fmap ($u) [ TInteger, TDoubleColon , flip TId "result"+                              , TEOF ]++      describe "Types" $ do+        it "lexes length and kind selectors" $+          shouldBe' (collectF90 "integer (KIND=1, LEN=1) :: kind, len") $+                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign+                              , flip TIntegerLiteral "1", TComma, TLen+                              , TOpAssign, flip TIntegerLiteral "1", TRightPar+                              , TDoubleColon , flip TId "kind", TComma+                              , flip TId "len", TEOF ]+++        it "lexes simple type tokens" $+          shouldBe' (collectF90 "character x") $+                    fmap ($u) [ TCharacter, flip TId "x", TEOF ]++        it "lexes simple type tokens in function" $+          shouldBe' (collectF90 "character function x") $+                    fmap ($u) [ TCharacter, TFunction, flip TId "x", TEOF ]++        it "lexes character type with F77 length syntax (1)" $+          shouldBe' (collectF90 "character * (*) function x") $+                    fmap ($u) [ TCharacter, TStar, TLeftPar, TStar, TRightPar, TFunction, flip TId "x", TEOF ]++        it "lexes character type with F77 length syntax (2)" $+          shouldBe' (collectF90 "character * 20 function x") $+                    fmap ($u) [ TCharacter, TStar, flip TIntegerLiteral "20", TFunction, flip TId "x", TEOF ]++        it "lexes derived type tokens in function" $+          shouldBe' (collectF90 "type (x) function x") $+                    fmap ($u) [ TType, TLeftPar, flip TId "x", TRightPar+                              , TFunction, flip TId "x", TEOF ]++        it "lexes interleaved type recursive tokens" $+          shouldBe' (collectF90 "integer (KIND=10*2) recursive function x") $+                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign+                              , flip TIntegerLiteral "10" , TStar+                              , flip TIntegerLiteral "2", TRightPar, TRecursive+                              , TFunction, flip TId "x", TEOF ]++        it "lexes interleaved type recursive tokens (reversed)" $+          shouldBe' (collectF90 "recursive integer (KIND=10*2) function x") $+                    fmap ($u) [ TRecursive, TInteger, TLeftPar, TKind, TOpAssign+                              , flip TIntegerLiteral "10" , TStar+                              , flip TIntegerLiteral "2", TRightPar, TFunction+                              , flip TId "x", TEOF ]++      describe "Function" $ do+        it "lexes 'function fx ( a, b, c )'" $+          shouldBe' (collectF90 "function fx ( a, b )") $+                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar, flip TId "a"+                              , TComma, flip TId "b", TRightPar, TEOF ]++        it "lexes functions with specific result" $+          shouldBe' (collectF90 "function fx (array) result (c_sum)") $+                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar+                              , flip TId "array", TRightPar, TResult, TLeftPar+                              , flip TId "c_sum", TRightPar, TEOF ]++        it "lexes recursive functions" $+          shouldBe' (collectF90 "recursive function fx (array)") $+                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar+                              , flip TId "array", TRightPar, TEOF ]++        it "lexes recursive functions with result specified" $+          shouldBe' (collectF90 "RECURSIVE FUNCTION FX (ARRAY) RESULT (C_SUM)") $+                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar+                              , flip TId "array", TRightPar, TResult, TLeftPar+                              , flip TId "c_sum", TRightPar, TEOF ]++      describe "Attribute" $ do+        it "lexes PARAMETER attribute" $+          shouldBe' (collectF90 "integer, parameter :: x") $+                    fmap ($u) [ TInteger, TComma, TParameter, TDoubleColon+                              , flip TId "x", TEOF ]++        it "lexes INTENT attribute" $+          shouldBe' (collectF90 "integer, intent (inout) :: x") $+                    fmap ($u) [ TInteger, TComma, TIntent, TLeftPar, TInOut+                              , TRightPar, TDoubleColon , flip TId "x", TEOF ]++        it "lexes DIMENSION attribute" $+          shouldBe' (collectF90 "double precision, dimension (3:10) :: x") $+                    fmap ($u) [ TDoublePrecision, TComma, TDimension, TLeftPar+                              , flip TIntegerLiteral "3", TColon+                              , flip TIntegerLiteral "10" , TRightPar+                              , TDoubleColon , flip TId "x", TEOF ]++        it "lexes variable declaration with multiple attributes" $+          shouldBe' (collectF90 "double precision, save, dimension(2), allocatable :: y") $+                    fmap ($u) [ TDoublePrecision, TComma, TSave, TComma+                              , TDimension, TLeftPar, flip TIntegerLiteral "2"+                              , TRightPar, TComma, TAllocatable, TDoubleColon+                              , flip TId "y", TEOF ]+      describe "Character" $ do+        it "lexes single quote literal" $+          shouldBe' (collectF90 "character c = 'heL\"Lo ''daRLing'") $+                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign+                              , flip TString "heL\"Lo 'daRLing", TEOF ]++        it "lexes double quote literal" $+          shouldBe' (collectF90 "character c = \"heL'Lo \"\"daRLing\"") $+                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign+                              , flip TString "heL'Lo \"daRLing", TEOF ]++      describe "Module" $ do+        it "lexes module statement" $+          shouldBe' (collectF90 "module Hello_mod") $+                    fmap ($u) [ TModule, flip TId "hello_mod", TEOF ]++        it "lexes use statement" $+          shouldBe' (collectF90 "use Hello_mod, hello => hi") $+                    fmap ($u) [ TUse, flip TId "hello_mod", TComma+                              , flip TId "hello", TArrow, flip TId "hi", TEOF ]++        it "lexes use statement with only" $+          shouldBe' (collectF90 "use Hello_mod, only: a, b => c") $+                    fmap ($u) [ TUse, flip TId "hello_mod", TComma, TOnly+                              , TColon, flip TId "a", TComma, flip TId "b"+                              , TArrow, flip TId "c", TEOF ]++      describe "Label" $+        it "lexes simple label" $+          shouldBe' (collectF90 "010 print *, 'hello'") $+                    fmap ($u) [ flip TIntegerLiteral "010", TPrint, TStar, TComma+                              , flip TString "hello", TEOF ]++      describe "Conditional" $ do+        it "lexes logical if with array assignment" $+          shouldBe' (collectF90 "if (.true.) a(1) = 42") $+                    fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral ".true."+                              , TRightPar, flip TId "a", TLeftPar+                              , flip TIntegerLiteral "1", TRightPar, TOpAssign+                              , flip TIntegerLiteral "42", TEOF ]++        it "lexes block if statement" $+          shouldBe' (collectF90 "if (a > b) then") $+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"+                              , TRightPar, TThen, TEOF ]++        it "lexes arithmetic if statement" $+          shouldBe' (collectF90 "if (a) 10, 11, 12") $+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TRightPar+                              , flip TIntegerLiteral "10", TComma+                              , flip TIntegerLiteral "11", TComma+                              , flip TIntegerLiteral "12" , TEOF ]++        it "lexes logical if statement" $+          shouldBe' (collectF90 "if (a > b) print *, 'hello'") $+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"+                              , TRightPar, TPrint, TStar, TComma+                              , flip TString "hello", TEOF ]++      describe "Lexes numeric values" $ do+        it "lexes integer" $+          shouldBe' (collectF90 "i = 42") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        describe "Real" $ do+          it "lexes real (1)" $+            shouldBe' (collectF90 "i = 10.5e2") $+                      pseudoAssign $ flip TRealLiteral "10.5e2"++          it "lexes real (2)" $+            shouldBe' (collectF90 "i = 10.") $+                      pseudoAssign $ flip TRealLiteral "10."++          it "lexes real (3)" $+            shouldBe' (collectF90 "i = .42") $+                      pseudoAssign $ flip TRealLiteral ".42"++          it "lexes real (3)" $+            shouldBe' (collectF90 "i = 42d-3") $+                      pseudoAssign $ flip TRealLiteral "42d-3"++          it "resolves disambiguity when xxx. follows relational operator" $+            shouldBe' (collectF90 "if (10.EQ. 20)") $+                      fmap ($u) [ TIf, TLeftPar, flip TIntegerLiteral "10"+                                , TOpEQ, flip TIntegerLiteral "20"+                                , TRightPar, TEOF ]++      describe "Continuation" $ do+        it "Single continuation char without space" $+          shouldBe' (collectF90 "i = &\n42") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        it "Single continuation char with space" $+          shouldBe' (collectF90 "i = &   \n \t   42") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        it "Double continuation (1)" $+          shouldBe' (collectF90 "i = &\n  & 42") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        it "Double continuation (2)" $+          shouldBe' (collectF90 "i = 4&\n  &2") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        it "Continuation with comment" $+          shouldBe' (collectF90 "i = 4&\n  ! hello\n  &2") $+                    pseudoAssign $ flip TIntegerLiteral "42"++        it "Continuation with inline comment" $+          shouldBe' (collectF90 "i = &  ! hi \n  42") $+                    pseudoAssign $ flip TIntegerLiteral "42"++      describe "Comment" $ do+        it "Full line comment" $+          shouldBe' (collectF90 "! = & ! hi \n") $+                    ($u) <$> [ flip TComment " = & ! hi ", TNewline , TEOF ]++        it "Inline comment" $+          shouldBe' (collectF90 "i = 10 ! = & ! hi \n") $+                    ($u) <$> [ flip TId "i", TOpAssign+                             , flip TIntegerLiteral "10"+                             , flip TComment " = & ! hi ", TNewline , TEOF ]+        it "Empty comment" $+          shouldBe' (collectF90 "!\n") $+                    ($u) <$> [ flip TComment "", TNewline , TEOF ]

@@ -0,0 +1,9 @@+module Language.Fortran.Parser.Fortran2003Spec where++import Test.Hspec++spec :: Spec+spec = +  describe "Fortran 2003 Parser" $ do+    it "TODO" $ do+      pending

@@ -0,0 +1,9 @@+module Language.Fortran.Parser.Fortran2008Spec where++import Test.Hspec++spec :: Spec+spec = +  describe "Fortran 2008 Parser" $ do+    it "TODO" $ do+      pending

@@ -0,0 +1,221 @@+module Language.Fortran.Parser.Fortran66Spec(spec) where++import Test.Hspec+import TestUtil++import Control.Monad.State.Lazy+import Prelude hiding (LT)++import Language.Fortran.Parser.Fortran66+import Language.Fortran.Lexer.FixedForm+import Language.Fortran.ParserMonad+import Language.Fortran.AST+import qualified Data.ByteString.Char8 as B++import Data.Typeable++eParser :: String -> Expression ()+eParser sourceCode =+  case evalParse statementParser parseState of+    (StExpressionAssign _ _ _ e) -> e+  where+    paddedSourceCode = B.pack $ "      a = " ++ sourceCode+    parseState =  initParseState paddedSourceCode Fortran66 "<unknown>"++sParser :: String -> Statement ()+sParser sourceCode =+  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran66 "<unknown>"++spec :: Spec+spec =+  describe "Fortran 66 Parser" $ do+    describe "Expressions" $ do+      describe "Arithmetic expressions" $ do+        describe "Real numbers" $ do+          it "parses 'hello" $ do+            let expectedExp = varGen "hello"+            eParser "hello" `shouldBe'` expectedExp++          it "parses '3.14" $ do+            let expectedExp = ExpValue () u (ValReal "3.14")+            eParser "3.14" `shouldBe'` expectedExp++          it "parses '.14" $ do+            let expectedExp = ExpValue () u (ValReal ".14")+            eParser ".14" `shouldBe'` expectedExp++          it "parses '3." $ do+            let expectedExp = ExpValue () u (ValReal "3.")+            eParser "3." `shouldBe'` expectedExp++          it "parses '3E12" $ do+            let expectedExp = ExpValue () u (ValReal "3e12")+            eParser "3E12" `shouldBe'` expectedExp++          it "parses '3.14d12" $ do+            let expectedExp = ExpValue () u (ValReal "3.14d12")+            eParser "3.14d12" `shouldBe'` expectedExp++          it "parses '.14d+1" $ do+            let expectedExp = ExpValue () u (ValReal ".14d+1")+            eParser ".14d+1" `shouldBe'` expectedExp++        it "parses '3'" $ do+          let expectedExp = intGen 3+          eParser "3" `shouldBe'` expectedExp++        it "parses '-3'" $ do+          let expectedExp = ExpUnary () u Minus $ intGen 3+          eParser "-3" `shouldBe'` expectedExp++        it "parses '3 + 2'" $ do+          let expectedExp = ExpBinary () u Addition (intGen 3) (intGen 2)+          eParser "3 + 2" `shouldBe'` expectedExp++        it "parses '3 + -2'" $ do+          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))+          eParser "3 + -2" `shouldBe'` expectedExp++        it "parses '3 + -2 + 42'" $ do+          let expectedExp = ExpBinary () u Addition (ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))) (intGen 42)+          eParser "3 + -2 + 42" `shouldBe'` expectedExp++        it "parses 'f(y, 24)'" $ do+          let subs = [ IxSingle () u Nothing $ varGen "y", ixSinGen 24 ]+          let expectedExp = ExpSubscript () u (varGen "f") (fromList () subs)+          eParser "f(y, 24)" `shouldBe'` expectedExp++        it "parses '3 + 4 * 12'" $ do+          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpBinary () u Multiplication (intGen 4) (intGen 12))+          eParser "3 + 4 * 12" `shouldBe'` expectedExp++      describe "Logical expressions" $+        it "parses '.true. .and. .false.'" $ do+          let expectedExp = ExpBinary () u And valTrue valFalse+          eParser ".true. .and. .false." `shouldBe'` expectedExp++      describe "Relational expressions" $+        it "parses '(3 * 2) .lt. 42'" $ do+          let expectedExp = ExpBinary () u LT (ExpBinary () u Multiplication (intGen 3) (intGen 2)) (intGen 42)+          eParser "(3 * 2) .lt. 42" `shouldBe'` expectedExp++      describe "Other expressions" $+        it "parses 'a(2 * x - 3, 10)'" $ do+          let firstEl = ExpBinary () u Subtraction (ExpBinary () u Multiplication (intGen 2) (varGen "x")) (intGen 3)+              expectedExp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing firstEl, ixSinGen 10])+          eParser "a(2 * x - 3, 10)" `shouldBe'` expectedExp++    describe "Statements" $ do+      it "parses 'EXTERNAL f, g, h'" $ do+        let procGen s = ExpValue () u (ValVariable s)+        let expectedSt = StExternal () u (AList () u [procGen "f", procGen "g", procGen "h"])+        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 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 st = StCommon () u (AList () u comGrs)+        sParser "      COMMON // a, b /hello/ x, y, z" `shouldBe'` st++      it "parses 'EQUIVALENCE (a,b), (x,y,z)'" $ do+        let ls = [ AList () u [varGen "a", varGen "b"]+                 , AList () u [varGen "x", varGen "y", varGen "z"] ]+        let st = StEquivalence () u (AList () u ls)+        sParser "      EQUIVALENCE (a,b), (x,y,z)" `shouldBe'` st++      it "parses 'DATA a/1,2,3/,x/42/'" $ do+        let dGrs = [ DataGroup () u (AList () u [varGen "a"]) (AList () u [intGen 1, intGen 2, intGen 3])+                   , DataGroup () u (AList () u [varGen "x"]) (AList () u [intGen 42]) ]+        let st = StData () u $ AList () u dGrs+        sParser "      DATA a/1,2,3/, x/42/" `shouldBe'` st++      describe "FORMAT" $ do+        it "parses 'FORMAT ()'" $ do+          let expectedSt = StFormatBogus () u "()"+          sParser "      FORMAT ()" `shouldBe'` expectedSt++        it "parses 'FORMAT (///)'" $ do+          let expectedSt = StFormatBogus () u "(///)"+          sParser "      FORMAT (///)" `shouldBe'` expectedSt++        it "parses 'FORMAT (2i5/5hhello)'" $ do+          let expectedSt = StFormatBogus () u "(2i5/5hhello)"+          sParser "      FORMAT (2i5/5hhello)" `shouldBe'` expectedSt++        it "parses 'FORMAT (/(i5))'" $ do+          let expectedSt = StFormatBogus () u "(/(i5))"+          sParser "      FORMAT (/(i5))" `shouldBe'` expectedSt++      describe "CALL" $ do+        it "parses 'CALL me" $ do+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) Nothing+          sParser "      CALL me" `shouldBe'` expectedSt++        it "parses 'CALL me(baby)" $ do+          let args = AList () u [ Argument () u Nothing $ varGen "baby" ]+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) $ Just args+          sParser "      CALL me(baby)" `shouldBe'` expectedSt++      it "parses 'stop'" $ do+        let expectedSt = StStop () u Nothing+        sParser "      stop" `shouldBe'` expectedSt++      it "parses 'integer i, j(2,2), k'" $ do+        let dimDecls = replicate 2 $ DimensionDeclarator () u Nothing (Just $ intGen 2)+            declarators = [ DeclVariable () u (varGen "i") Nothing Nothing+                          , DeclArray () u (varGen "j") (AList () u dimDecls) Nothing Nothing+                          , DeclVariable () u (varGen "k") Nothing Nothing ]+            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ AList () u declarators+        sParser "      integer i, j(2,2), k" `shouldBe'` st++      let controlPairs = AList () u [ ControlPair () u Nothing (intGen 6), ControlPair () u Nothing (labelGen 10) ]+      let writeSt = StWrite () u controlPairs (Just $ AList () u [ varGen "i" ])++      describe "WRITE" $ do+        it "parses 'write (6)'" $ do+          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) Nothing+          sParser "      write (6)" `shouldBe'` expectedSt++        it "parses 'write (6) i'" $ do+          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) (Just $ AList () u [ varGen "i" ])+          sParser "      write (6) i" `shouldBe'` expectedSt++        it "parses 'write (6,10) i'" $+          sParser "      write (6,10) i" `shouldBe'` writeSt++      describe "IF" $ do+        it "parses 'if (10 .LT. x) write (6,10) i'" $ do+          let cond = ExpBinary () u LT (intGen 10) (varGen "x")+          let expectedSt = StIfLogical () u cond writeSt+          sParser "      if (10 .LT. x) write (6,10) i" `shouldBe'` expectedSt++        it "parses 'if (10 - 5) 10, 20, 30'" $ do+          let cond = ExpBinary () u Subtraction (intGen 10) (intGen 5)+          let expectedSt = StIfArithmetic () u cond (labelGen 10) (labelGen 20) (labelGen 30)+          sParser "      if (10 - 5) 10, 20, 30" `shouldBe'` expectedSt++        it "parses 'IF (IY) 5,6,6" $ do+          let expectedSt = StIfArithmetic () u (varGen "iy") (labelGen 5) (labelGen 6) (labelGen 6)+          sParser "      IF (IY) 5,6,6" `shouldBe'` expectedSt++      describe "ASSIGNMENT" $ do+        it "parses 'f = 1'" $ do+          let expectedSt = StExpressionAssign () u (varGen "f") (intGen 1)+          sParser "      f = 1" `shouldBe'` expectedSt++        it "parses 'f = a(1,2)'" $ do+          let indicies = fromList () [ ixSinGen 1, ixSinGen 2 ]+          let rhs = ExpSubscript () u (varGen "a") indicies+          let expectedSt = StExpressionAssign () u (varGen "f") rhs+          sParser "      f = a(1,2)" `shouldBe'` expectedSt++      it "parses 'do 42 i = 10, 1, 1'" $ do+        let st = StExpressionAssign () u (varGen "i") (intGen 10)+        let doSpec = DoSpecification () u st (intGen 1) (Just $ intGen 1)+        let expectedSt = StDo () u Nothing (Just $ labelGen 42) (Just doSpec)+        sParser "      do 42 i = 10, 1, 1" `shouldBe'` expectedSt

@@ -0,0 +1,306 @@+module Language.Fortran.Parser.Fortran77Spec where++import Test.Hspec+import TestUtil++import Language.Fortran.Parser.Fortran77+import Language.Fortran.Lexer.FixedForm (initParseState)+import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe)+import Language.Fortran.AST+import qualified Data.ByteString.Char8 as B++eParser :: String -> Expression ()+eParser sourceCode =+  case evalParse statementParser parseState of+    (StExpressionAssign _ _ _ e) -> e+  where+    paddedSourceCode = B.pack $ "      a = " ++ sourceCode+    parseState =  initParseState paddedSourceCode Fortran77 "<unknown>"++sParser :: String -> Statement ()+sParser sourceCode =+  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77 "<unknown>"++slParser :: String -> Statement ()+slParser sourceCode =+  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "<unknown>"++iParser :: String -> [Block ()]+iParser sourceCode =+  fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "<unknown>"++pParser :: String -> ProgramFile ()+pParser source = fromParseResultUnsafe $ fortran77Parser (B.pack source) "<unknown>"++spec :: Spec+spec =+  describe "Fortran 77 Parser" $ do+    describe "IO" $ do+      it "parses 'print *, 9000" $ do+        let expectedSt = StPrint () u starVal $ Just (AList () u [ intGen 9000 ])+        sParser "      print *, 9000" `shouldBe'` expectedSt++      it "parses 'write (UNIT=6, FORMAT=*)" $ do+        let cp1 = ControlPair () u (Just "unit") (intGen 6)+        let cp2 = ControlPair () u (Just "format") starVal+        let expectedSt = StWrite () u (AList () u [cp1, cp2]) Nothing+        sParser "      write (UNIT=6, FORMAT=*)" `shouldBe'` expectedSt++      it "parses 'endfile i" $+        sParser "      endfile i" `shouldBe'` StEndfile2 () u (varGen "i")++      it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do+        let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)+        let doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)+        let impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]+        let impliedDo = ExpImpliedDo () u impliedDoVars doSpec+        let iolist = AList () u [ impliedDo ]+        let expectedSt = StRead2 () u starVal (Just iolist)+        sParser "      read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt++    it "parses '(x, y(i), i = 1, 10, 2)'" $ do+      let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)+      let doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)+      let impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]+      let impliedDo = ExpImpliedDo () u impliedDoVars doSpec+      eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo++    it "parses main program unit" $ do+      let decl = DeclVariable () u (varGen "x") Nothing Nothing+      let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])+      let bl = BlStatement () u Nothing st+      let pu = ProgramFile mi77 [ PUMain () u (Just "hello") [ bl ] Nothing ]+      pParser exampleProgram1 `shouldBe'` pu++    it "parses block data unit" $ do+      let decl = DeclVariable () u (varGen "x") Nothing Nothing+      let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])+      let bl = BlStatement () u Nothing st+      let pu = ProgramFile mi77 [ PUBlockData () u (Just "hello") [ bl ] ]+      pParser exampleProgram2 `shouldBe'` pu++    it "parses 'intrinsic cosh, sin'" $ do+      let fun1 = ExpValue () u (ValVariable "cosh")+      let fun2 = ExpValue () u (ValVariable "sin")+      let st = StIntrinsic () u (AList () u [ fun1, fun2 ])+      sParser "      intrinsic cosh, sin" `shouldBe'` st++    it "parses 'intrinsic real" $ do+      let fun = ExpValue () u (ValVariable "real")+      let st = StIntrinsic () u (AList () u [ fun ])+      sParser "      intrinsic real" `shouldBe'` st++    describe "CHARACTER" $ do+      it "parses character literal assignment" $ do+        let rhs = ExpValue () u (ValString "hello 'baby")+        let st = StExpressionAssign () u (varGen "xyz") rhs+        sParser "      xyz = 'hello ''baby'" `shouldBe'` st++      it "string concatenation" $ do+        let str1 = ExpValue () u (ValString "hello ")+        let str2 = ExpValue () u (ValString "world")+        let exp = ExpBinary () u Concatenation str1 str2+        eParser "'hello ' // 'world'" `shouldBe'` exp++    describe "Subscript like" $ do+      it "parses vanilla subscript" $ do+        let exp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing $ varGen "x", IxSingle () u Nothing $ intGen 2, IxSingle () u Nothing $ intGen 3 ])+        eParser "a(x, 2, 3)" `shouldBe'` exp++      it "parses array declarator" $ do+        let dimDecls = [ DimensionDeclarator () u (Just $ intGen 1) (Just $ intGen 2)+                       , DimensionDeclarator () u Nothing (Just $ intGen 15)+                       , DimensionDeclarator () u (Just $ varGen "x") (Just $ starVal) ]+        let decl = DeclArray () u (varGen "a") (AList () u dimDecls) Nothing Nothing+        let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])+        sParser "      integer a(1:2, 15, x:*)" `shouldBe'` st++      it "parses character substring" $ do+        let indicies = [ ixSinGen 1, ixSinGen 2, ixSinGen 3 ]+        let subExp = ExpSubscript () u (varGen "a")  (AList () u indicies)+        let range = IxRange () u Nothing (Just $ intGen 10) Nothing+        let exp = ExpSubscript () u subExp (AList () u [ range ])+        eParser "a(1, 2, 3)(:10)" `shouldBe'` exp++      it "parses simpler substring" $ do+        let exp = ExpSubscript () u (varGen "a") (AList () u [ ixRanGen 5 10 ])+        eParser "a(5:10)" `shouldBe'` exp++      it "parses simpler substring" $ do+        let range = IxRange () u (Just $ intGen 5) Nothing Nothing+        let exp = ExpSubscript () u (varGen "a") (AList () u [ range ])+        eParser "a(5:)" `shouldBe'` exp++    describe "GOTO" $ do+      it "parses computed GOTO with integer expression" $ do+        let exp = ExpBinary () u Multiplication (intGen 42) (intGen 24)+        let st = StGotoComputed () u (AList () u [labelGen 10, labelGen 20, labelGen 30]) exp+        sParser "      GOTO (10, 20, 30), 42 * 24" `shouldBe'` st++      let gotoSt = StGotoAssigned () u (varGen "v") (Just (AList () u [labelGen 10, labelGen 20, labelGen 30]))+      it "parses assigned GOTO with comma" $+        sParser "      GOTO v, (10, 20, 30)" `shouldBe'` gotoSt++      it "parses assigned GOTO without comma" $+        sParser "      GOTO v (10, 20, 30)" `shouldBe'` gotoSt++    describe "IMPLICIT" $ do+      it "parses 'implicit none'" $ do+        let st = resetSrcSpan $ StImplicit () u Nothing+        sParser "      implicit none" `shouldBe'` st++      it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do+        let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"]+        let selector = Selector () u (Just $ intGen 30) Nothing+        let imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just selector)) $ AList () u impEls+        let imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"]+        let st = StImplicit () u $ Just $ AList () u [imp1, imp2]+        sParser "      implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st++    it "parses 'parameter (pi = 3.14, b = 'X' // 'O', d = k) '" $ do+      let sts = [ DeclVariable () u (varGen "pi") Nothing (Just $ realGen 3.14)+                , let e = ExpBinary () u Concatenation (strGen "X") (strGen "O")+                  in DeclVariable () u (varGen "b") Nothing (Just e)+                , DeclVariable () u (varGen "d") Nothing (Just $ varGen "k") ]+      let st = StParameter () u (AList () u sts)+      sParser "      parameter (pi = 3.14, b = 'X' // 'O', d = k)" `shouldBe'` st++    it "parses 'pause 'hello world''" $ do+      let st = StPause () u $ Just $ strGen "hello world"+      sParser "      pause 'hello world'" `shouldBe'` st++    describe "SAVE" $ do+      it "parses 'save /cb/, var, /key/'" $ do+        let saveArgs = [ varGen "cb", varGen "var", varGen "key" ]+        let st = StSave () u (Just $ AList () u saveArgs)+        sParser "      save /cb/, var, /key/" `shouldBe'` st++      it "parses 'save'" $+        sParser "      save" `shouldBe'` StSave () u Nothing++    it "parses '.true. .eqv. f(42) .neqv. x'" $ do+      let arg2 = ExpSubscript () u (varGen "f") $ AList () u [ ixSinGen 42 ]+      let arg3 = varGen "x"+      let subexp = ExpBinary () u Equivalent valTrue arg2+      let exp = ExpBinary () u NotEquivalent subexp arg3+      eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp++    it "parses 'entry me (a,b,*)'" $ do+      let func = ExpValue () u (ValVariable "me")+      let args = [ varGen "a", varGen "b", starVal ]+      let st = StEntry () u func (Just $ AList () u args) Nothing+      sParser "      entry me (a,b,*)" `shouldBe'` st++    it "parses 'character a*8'" $ do+      let decl = DeclVariable () u (varGen "a") (Just $ intGen 8) Nothing+      let typeSpec = TypeSpec () u TypeCharacter Nothing+      let st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])+      sParser "      character a*8" `shouldBe'` st++    it "parses included files" $ do+      let decl = DeclVariable () u (varGen "a") Nothing Nothing+      let typeSpec = TypeSpec () u TypeInteger Nothing+      let st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])+      let bl = BlStatement () u Nothing st+      iParser "      integer a" `shouldBe'` [bl]++    describe "Legacy Extensions" $ do+      it "parses structure/union/map blocks" $ do+        let src = init+                $ unlines [ "      structure /foo/"+                          , "        union"+                          , "          map"+                          , "            integer i"+                          , "          end map"+                          , "          map"+                          , "            real r"+                          , "          end map"+                          , "        end union"+                          , "      end structure"]+        let ds = [ UnionMap () u $ AList () u+                   [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $+                    AList () u [DeclVariable () u (varGen "i") Nothing Nothing]]+                 , UnionMap () u $ AList () u+                   [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $+                    AList () u [DeclVariable () u (varGen "r") Nothing Nothing]]+                 ]+        let st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]+        resetSrcSpan (slParser src) `shouldBe` st++      it "parses character declarations with unspecfied lengths" $ do+        let src = "      character s*(*)"+        let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $+                 AList () u [DeclVariable () u+                               (ExpValue () u (ValVariable "s"))+                               (Just (ExpValue () u ValStar))+                               Nothing]+        resetSrcSpan (slParser src) `shouldBe` st++      it "parses array initializers" $ do+        let src = "      integer xs(3) / 1, 2, 3 /"+        let inits = [ExpValue () u (ValInteger "1"), ExpValue () u (ValInteger "2"), ExpValue () u (ValInteger "3")]+        let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $+                 AList () u [DeclArray () u+                               (ExpValue () u (ValVariable "xs"))+                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "3")))])+                               Nothing+                               (Just (ExpInitialisation () u $ AList () u inits))]+        resetSrcSpan (slParser src) `shouldBe` st++        let src = "      character xs(2)*5 / 'hello', 'world' /"+        let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]+        let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $+                 AList () u [DeclArray () u+                               (ExpValue () u (ValVariable "xs"))+                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])+                               (Just (ExpValue () u (ValInteger "5")))+                               (Just (ExpInitialisation () u $ AList () u inits))]+        resetSrcSpan (slParser src) `shouldBe` st++        let src = "      character xs*5(2) / 'hello', 'world' /"+        let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]+        let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $+                 AList () u [DeclArray () u+                               (ExpValue () u (ValVariable "xs"))+                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])+                               (Just (ExpValue () u (ValInteger "5")))+                               (Just (ExpInitialisation () u $ AList () u inits))]+        resetSrcSpan (slParser src) `shouldBe` st++      it "parses subscripts in assignments" $ do+        let mkIdx i = IxSingle () u Nothing (ExpValue () u (ValInteger i))++        let src = "      x(0,1) = 0"+        let tgt = ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0", mkIdx "1"])+        let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))+        resetSrcSpan (slParser src) `shouldBe` st++        let src = "      x(0).foo = 0"+        let tgt = ExpDataRef () u (ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0"])) (ExpValue () u (ValVariable "foo"))+        let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))+        resetSrcSpan (slParser src) `shouldBe` st++        let src = "      x.foo = 0"+        let tgt = ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))+        let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))+        resetSrcSpan (slParser src) `shouldBe` st++        let src = "      x.foo(0) = 0"+        let tgt = ExpSubscript () u (ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))) (AList () u [mkIdx "0"])+        let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))+        resetSrcSpan (slParser src) `shouldBe` st++exampleProgram1 = unlines+  [ "      program hello"+  , "      integer x"+  , "      end" ]++exampleProgram2 = unlines+  [ "      block data hello"+  , "      integer x"+  , "      end" ]++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,538 @@+module Language.Fortran.Parser.Fortran90Spec (spec) where++import Prelude hiding (GT)++import TestUtil+import Test.Hspec++import Language.Fortran.AST+import Language.Fortran.ParserMonad+import Language.Fortran.Lexer.FreeForm+import Language.Fortran.Parser.Fortran90+import qualified Data.List as List+import qualified Data.ByteString.Char8 as B++eParser :: String -> Expression ()+eParser sourceCode =+  case evalParse statementParser parseState of+    (StExpressionAssign _ _ _ e) -> e+  where+    paddedSourceCode = B.pack $ "      a = " ++ sourceCode+    parseState =  initParseState paddedSourceCode Fortran90 "<unknown>"++sParser :: String -> Statement ()+sParser sourceCode =+  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"++fParser :: String -> ProgramUnit ()+fParser sourceCode =+  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"++{- Useful for parser debugging; Lexes the given source code.+fTok :: String -> [Token]+fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode+-}++{-+ - Given a list of values, find every combination of those values:+ - combination [1,2] = [[], [1], [2], [1,2], [2,1]]+ -}+combination :: [a] -> [[a]]+combination = foldr ((++) . List.permutations) [] . List.subsequences++spec :: Spec+spec =+  describe "Fortran 90 Parser" $ do+    describe "Function" $ do+      let puFunction = PUFunction () u+      let fType = Nothing+      let fOpt = None () u False+      let fName = "f"+      let fArgs = Nothing+      let fRes = Nothing+      let fBody = []+      let fSub = Nothing++      describe "End" $ do+        it "parses simple functions ending with \"end function [function name]\"" $ do+          let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+          let fStr = init $ unlines ["function f()"+                               , "end function f" ]+          fParser fStr `shouldBe'` expected++        it "parses simple functions ending with \"end\"" $ do+          let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+          let fStr = init $ unlines ["function f()"+                               , "end" ]+          fParser fStr `shouldBe'` expected++        it "parses simple functions ending with \"end function\"" $ do+          let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+          let fStr = init $ unlines ["function f()"+                               , "end function" ]+          fParser fStr `shouldBe'` expected+++        it "parses functions with return type specs" $ do+          let fType = Just $ TypeSpec () u TypeInteger Nothing+          let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+          let fStr = init $ unlines ["integer function f()"+                               , "end function f" ]+          fParser fStr `shouldBe'` expected++      it "parses recursive functions" $ do+        let fOpt = None () u True+        let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+        let fStr = init $ unlines ["recursive function f()", "end"]+        fParser fStr `shouldBe'` expected+++      it "parses functions with a list of arguments" $ do+        let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]                                                     +        let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+        let fStr = init $ unlines ["function f(x, y, z)"+                             , "end function f" ]+        fParser fStr `shouldBe'` expected++      it "parses functions with a result variable" $ do+        let fRes = Just $ varGen "i"+        let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+        let fStr = init $ unlines ["function f() result(i)"+                             , "end function f" ]+        fParser fStr `shouldBe'` expected++      it "parses functions with function bodies" $ do+        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)+        let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])                                                      +        let f2 = StExpressionAssign () u (varGen "i") decrementRHS+        let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]+        let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+        let fStr = init $ unlines ["function f()"+                             , "  print *, i"                                                                          +                             , "  i = (i - 1)"                                                                         +                             , "end function f" ]+        fParser fStr `shouldBe'` expected++      it "parses complex functions" $ do+        let fType = Just $ TypeSpec () u TypeInteger Nothing+        let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]                                                     +        let fRes = Just $ varGen "i"                                                                                      +        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)+        let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])                                                      +        let f2 = StExpressionAssign () u (varGen "i") decrementRHS+        let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]+        let expected = puFunction fType fOpt fName fArgs fRes fBody fSub+        let fStr = init $ unlines [ "integer function f(x, y, z) result(i)"                                                 +                             , "  print *, i"                                                                          +                             , "  i = (i - 1)"                                                                         +                             , "end function f" ]                                                                      +        fParser fStr `shouldBe'` expected++    describe "Expression" $ do+      it "parses logial literals with kind" $ do+        let expected = ExpValue () u (ValLogical ".true._kind")+        eParser ".true._kind" `shouldBe'` expected++      it "parses array initialisation exp" $ do+        let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]+        eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list++      describe "Custom operator" $ do+        let unOp = UnCustom ".inverse."+        let unExp = ExpUnary () u unOp $ intGen 42++        it "parses unary custom operator" $+          eParser ".inverse. 42" `shouldBe'` unExp++        let binOp = BinCustom ".xor."+        it "parses binary custom operator" $ do+          let expected = ExpBinary () u binOp (intGen 24) (intGen 42)+          eParser "24 .xor. 42" `shouldBe'` expected++        it "parses mixed unary custom operator" $ do+          let binExp = ExpBinary () u binOp unExp (intGen 24)+          eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp++        it "parses data ref" $ do+          let range = fromList () [ IxSingle () u Nothing $ intGen 10 ]+          let sub = ExpSubscript () u (varGen "y") range+          let innerRefExp = ExpDataRef () u (varGen "x") sub+          let exp = ExpDataRef () u innerRefExp (varGen "z")+          eParser "x % y(10) % z" `shouldBe'` exp++        it "parses section subscript" $ do+          let range = [ IxSingle () u Nothing $ intGen 10+                      , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2)+                      , IxSingle () u Nothing $ varGen "y" ]+          let exp = ExpSubscript () u (varGen "x") (fromList () range)+          eParser "x (10, : 1 : 2, y)" `shouldBe'` exp++    describe "Statement" $ do+      it "data ref assignment" $ do+        let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ]+        let subs = ExpSubscript () u (varGen "x") indicies+        let lhs = ExpDataRef () u subs (varGen "y")+        let st = StExpressionAssign () u lhs (intGen 1)+        sParser "x(1) % y = 1" `shouldBe'` st++      it "parses pause statements" $ do+        let stPause = StPause () u Nothing+        let stStr = "PAUSE"+        sParser stStr `shouldBe'` stPause+        +      it "parses pause statements with expression" $ do+        let stPause = StPause () u (Just (strGen "MESSAGE"))+        let stStr = "PAUSE \"MESSAGE\""+        sParser stStr `shouldBe'` stPause++      it "parses declaration with attributes" $ do+        let typeSpec = TypeSpec () u TypeReal Nothing+        let attrs = AList () u [ AttrExternal () u+                               , AttrIntent () u Out+                               , AttrDimension () u $ AList () u+                                  [ DimensionDeclarator () u+                                      (Just $ intGen 3) (Just $ intGen 10)+                                  ]+                               ]+        let declarators = AList () u+              [ DeclVariable () u (varGen "x") Nothing Nothing+              , DeclVariable () u (varGen "y") Nothing Nothing ]+        let expected = StDeclaration () u typeSpec (Just attrs) declarators+        let stStr = "real, external, intent (out), dimension (3:10) :: x, y"+        sParser stStr `shouldBe'` expected++      it "parses declaration with old syntax" $ do+        let typeSpec = TypeSpec () u TypeLogical Nothing+        let declarators = AList () u+              [ DeclVariable () u (varGen "x") Nothing Nothing+              , DeclVariable () u (varGen "y") Nothing Nothing ]+        let expected = StDeclaration () u typeSpec Nothing declarators+        let stStr = "logical x, y"+        sParser stStr `shouldBe'` expected++      it "parses declaration with initialisation" $ do+        let typeSpec = TypeSpec () u TypeComplex Nothing+        let init = ExpValue () u (ValComplex (intGen 24) (realGen 42.0))+        let declarators = AList () u+              [ DeclVariable () u (varGen "x") Nothing (Just init) ]+        let expected = StDeclaration () u typeSpec Nothing declarators+        let stStr = "complex :: x = (24, 42.0)"+        sParser stStr `shouldBe'` expected++      it "parses declaration of custom type" $ do+        let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing+        let declarators = AList () u+              [ DeclVariable () u (varGen "x") Nothing Nothing ]+        let expected = StDeclaration () u typeSpec Nothing declarators+        let stStr = "type (MeineType) :: x"+        sParser stStr `shouldBe'` expected++      it "parses declaration type with kind selector" $ do+        let selector = Selector () u Nothing (Just $ varGen "hello")+        let typeSpec = TypeSpec () u TypeInteger (Just selector)+        let declarators = AList () u+              [ DeclVariable () u (varGen "x") Nothing Nothing ]+        let expected = StDeclaration () u typeSpec Nothing declarators+        let stStr = "integer (hello) :: x"+        sParser stStr `shouldBe'` expected++      it "parses intent statement" $ do+        let stStr = "intent (inout) :: a"+        let expected = StIntent () u InOut (fromList () [ varGen "a" ])+        sParser stStr `shouldBe'` expected++      it "parses optional statement" $ do+        let stStr = "optional x"+        let expected = StOptional () u (fromList () [ varGen "x" ])+        sParser stStr `shouldBe'` expected++      it "parses public statement" $ do+        let stStr = "public :: x"+        let expected = StPublic () u (Just $ fromList () [ varGen "x" ])+        sParser stStr `shouldBe'` expected++      it "parses public assignment" $ do+        let expected = StPublic () u (Just $ fromList () [ assVal ])+        sParser "public :: assignment (=)" `shouldBe'` expected++      it "parses private statement" $+        sParser "private" `shouldBe'` StPrivate () u Nothing++      it "parses private operator" $ do+        let expected = StPrivate () u (Just $ fromList () [ opGen "*" ])+        sParser "private operator ( * )" `shouldBe'` expected++      it "parses save statement" $ do+        let list = [ varGen "hello", varGen "bye" ]+        let expected = StSave () u (Just $ fromList () list)+        let stStr = "save /hello/, bye"+        sParser stStr `shouldBe'` expected++      it "parses parameter statement" $ do+        let ass1 = DeclVariable () u (varGen "x") Nothing (Just $ intGen 10)+        let ass2 = DeclVariable () u (varGen "y") Nothing (Just $ intGen 20)+        let expected = StParameter () u (fromList () [ ass1, ass2 ])+        sParser "parameter (x = 10, y = 20)" `shouldBe'` expected++      describe "Implicit" $ do+        it "parses implicit none" $ do+          let st = StImplicit () u Nothing+          sParser "implicit none" `shouldBe'` st++        it "parses implicit with single" $ do+          let typeSpec = TypeSpec () u TypeCharacter Nothing+          let impEls = [ ImpCharacter () u "k" ]+          let impLists = [ ImpList () u typeSpec (fromList () impEls) ]+          let st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit character (k)" `shouldBe'` st++        it "parses implicit with range" $ do+          let typeSpec = TypeSpec () u TypeLogical Nothing+          let impEls = [ ImpRange () u "x" "z" ]+          let impLists = [ ImpList () u typeSpec (fromList () impEls) ]+          let st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit logical (x-z)" `shouldBe'` st++        it "parses implicit statement" $ do+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing+          let typeSpec2 = TypeSpec () u TypeInteger Nothing+          let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]+          let impEls2 = [ ImpRange () u "x" "z" ]+          let impLists = [ ImpList () u typeSpec1 (fromList () impEls1)+                         , ImpList () u typeSpec2 (fromList () impEls2) ]+          let st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st++      describe "Data" $ do+        it "parses vanilla" $ do+          let nlist = fromList () [ varGen "x", varGen "y" ]+          let vlist = fromList () [ intGen 1, intGen 2 ]+          let list = [ DataGroup () u nlist vlist ]+          let expected = StData () u (fromList () list)+          let stStr = "data x,y/1,2/"+          sParser stStr `shouldBe'` expected++        describe "Delimeter" $ do+          let [ nlist1, vlist1 ] =+                map (fromList () . return) [ varGen "x", intGen 1 ]+          let [ nlist2, vlist2 ] =+                map (fromList () . return) [ varGen "y", intGen 2 ]+          let list = [ DataGroup () u nlist1 vlist1+                     , DataGroup () u nlist2 vlist2 ]+          let expected = StData () u (fromList () list)++          it "parses comma delimited init groups" $+            sParser "data x/1/, y/2/" `shouldBe'` expected++          it "parses non-comma delimited init groups" $+            sParser "data x/1/ y/2/" `shouldBe'` expected++      describe "Namelist" $ do+        let groupNames = [ ExpValue () u (ValVariable "something")+                         , ExpValue () u (ValVariable "other") ]+        let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]+                     , fromList () [ varGen "y" ] ]+        let st = StNamelist () u $+              fromList () [ Namelist () u (head groupNames) (head itemss)+                          , Namelist () u (last groupNames) (last itemss) ]++        it "parses namelist statement (comma delimited) (1)" $+          sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st++        it "parses namelist statement (2)" $+          sParser "namelist /something/a,b,c/other/y" `shouldBe'` st++      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 st = StCommon () u $ fromList ()+              [ CommonGroup () u Nothing (fromList () [ varGen "q" ])+              , CommonGroup () u (Just $ head commonNames) (head itemss)+              , CommonGroup () u (Just $ last commonNames) (last itemss) ]++        it "parses common statement (comma delimited) (1)" $+          sParser "common q /something/a,b,c, /other/y" `shouldBe'` st++        it "parses common statement (2)" $+          sParser "common q /something/a,b,c /other/y" `shouldBe'` st++      it "parses equivalence statement" $ do+        let eqALists = fromList ()+              [ fromList ()+                  [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ]+                    in ExpSubscript () u (varGen "a") indicies+                  , varGen "x"+                  ]+              , fromList ()+                  [ varGen "y"+                  , varGen "z"+                  , let indicies = fromList () [ IxRange () u (Just $ intGen 1)+                                                              (Just $ intGen 42)+                                                              Nothing ]+                    in ExpSubscript () u (varGen "d") indicies+                  ]+              ]+        let st = StEquivalence () u eqALists+        sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st++      describe "Dynamic allocation" $ do+        it "parses allocate statement" $ do+          let controlPair = ControlPair () u (Just "stat") (varGen "a")+          let allocs = fromList ()+                [ varGen "x"+                , ExpDataRef () u (varGen "st") (varGen "part")+                ]+          let s = StAllocate () u allocs (Just controlPair)+          sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s++        it "parses deallocate statement" $ do+          let allocs = fromList ()+                [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ]+                  in ExpSubscript () u (varGen "smt") indicies+                ]+          let s = StDeallocate () u allocs Nothing+          sParser "deallocate (smt ( 20 ))" `shouldBe'` s++        it "parses nullify statement" $ do+          let s = StNullify () u (fromList () [ varGen "x" ])+          sParser "nullify (x)" `shouldBe'` s++      it "parses pointer assignment" $ do+        let src = ExpDataRef () u (varGen "x") (varGen "y")+        let st = StPointerAssign () u src (varGen "exp")+        sParser "x % y => exp" `shouldBe'` st++      describe "Where" $ do+        it "parses where statement" $ do+          let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp")+          let pred = ExpBinary () u GT (varGen "temp") (intGen 100)+          let assignment = StExpressionAssign () u (varGen "temp") exp+          let st = StWhere () u pred assignment+          sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st++        describe "Where block" $ do+          it "parses where construct statement" $+            sParser "where (.true.)" `shouldBe'` StWhereConstruct () u valTrue++          it "parses elsewhere statement" $+            sParser "elsewhere" `shouldBe'` StElsewhere () u++          it "parses endwhere statement" $+            sParser "endwhere" `shouldBe'` StEndWhere () u++    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++      it "parses else-if statement" $+        sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue++      it "parses end if statement" $+        sParser "end if" `shouldBe'` StEndif () u Nothing++      it "parses logical if statement" $ do+        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")+        let stIf = StIfLogical () u valTrue assignment+        sParser "if (.true.) a = b" `shouldBe'` stIf++      it "parses arithmetic if statement" $ do+        let stIf = StIfArithmetic () u (varGen "x") (intGen 1)+                                                    (intGen 2)+                                                    (intGen 3)+        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++    describe "Do" $ do+      it "parses do statement with label" $ do+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)+        let doSpec = DoSpecification () u assign (intGen 42) Nothing+        let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)+        sParser "do 24, i = 0, 42" `shouldBe'` st++      it "parses do statement without label" $ do+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)+        let doSpec = DoSpecification () u assign (intGen 42) Nothing+        let st = StDo () u Nothing Nothing (Just doSpec)+        sParser "do i = 0, 42" `shouldBe'` st++      it "parses infinite do" $ do+        let st = StDo () u Nothing Nothing Nothing+        sParser "do" `shouldBe'` st++      it "parses end do statement" $ do+        let st = StEnddo () u (Just "constructor")+        sParser "end do constructor" `shouldBe'` st++      it "parses end do while statement" $ do+        let st = StDoWhile () u (Just "name") Nothing valTrue+        sParser "name: do while (.true.)" `shouldBe'` st++    describe "Goto" $ do+      it "parses vanilla goto" $ do+        let st = StGotoUnconditional () u (intGen 999)+        sParser "goto 999" `shouldBe'` st++      it "parses computed goto" $ do+        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]+        let st = StGotoComputed () u list (intGen 20)+        sParser "goto (10, 20, 30) 20" `shouldBe'` st++      it "parses assigned goto" $ do+        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]+        let st = StGotoAssigned () u (varGen "i") (Just list)+        sParser "goto i, (10, 20, 30)" `shouldBe'` st++      it "parses label assignment" $ do+        let st = StLabelAssign () u (intGen 20) (varGen "l")+        sParser "assign 20 to l" `shouldBe'` st++    describe "IO" $ do+      it "parses vanilla print" $ do+        let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ])+        sParser "print *, hex" `shouldBe'` st++      it "parses write with implied do" $ do+        let cp1 = ControlPair () u Nothing (intGen 10)+        let cp2 = ControlPair () u (Just "format") (varGen "x")+        let ciList = fromList () [ cp1, cp2 ]+        let assign = StExpressionAssign () u (varGen "i") (intGen 1)+        let doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2)+        let alist = fromList () [ varGen "i", varGen "j" ]+        let outList = fromList () [ ExpImpliedDo () u alist doSpec ]+        let st = StWrite () u ciList (Just outList)+        sParser "write (10, FORMAT = x) (i, j,  i = 1, 42, 2)" `shouldBe'` st++    it "parses use statement" $ do+      let renames = fromList ()+            [ UseRename () u (varGen "sprod") (varGen "prod")+            , UseRename () u (varGen "a") (varGen "b") ]+      let st = StUse () u (varGen "stats_lib") Permissive (Just renames)+      sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st