fortran-src 0.9.0 → 0.10.0

raw patch · 56 files changed

+1947/−1279 lines, 56 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• README.md +5/−3
• app/Main.hs +3/−1
• fortran-src.cabal +11/−5
• src/Language/Fortran/AST.hs +481/−234
• src/Language/Fortran/AST/AList.hs +47/−4
• src/Language/Fortran/AST/Annotated.hs +18/−0
• src/Language/Fortran/AST/Boz.hs +0/−97
• src/Language/Fortran/AST/Common.hs +3/−0
• src/Language/Fortran/AST/Literal.hs +23/−0
• src/Language/Fortran/AST/Literal/Boz.hs +139/−0
• src/Language/Fortran/AST/Literal/Complex.hs +60/−0
• src/Language/Fortran/AST/Literal/Real.hs +97/−0
• src/Language/Fortran/AST/RealLit.hs +0/−95
• src/Language/Fortran/Analysis.hs +7/−6
• src/Language/Fortran/Analysis/BBlocks.hs +77/−57
• src/Language/Fortran/Analysis/DataFlow.hs +1/−1
• src/Language/Fortran/Analysis/SemanticTypes.hs +2/−1
• src/Language/Fortran/Analysis/Types.hs +13/−18
• src/Language/Fortran/Parser.hs +14/−2
• src/Language/Fortran/Parser/Fixed/Fortran66.y +10/−5
• src/Language/Fortran/Parser/Fixed/Fortran77.y +66/−59
• src/Language/Fortran/Parser/Fixed/Lexer.x +2/−2
• src/Language/Fortran/Parser/Fixed/Utils.hs +1/−1
• src/Language/Fortran/Parser/Free/Fortran2003.y +103/−88
• src/Language/Fortran/Parser/Free/Fortran90.y +71/−56
• src/Language/Fortran/Parser/Free/Fortran95.y +96/−89
• src/Language/Fortran/Parser/Free/Lexer.x +3/−3
• src/Language/Fortran/Parser/LexerUtils.hs +1/−1
• src/Language/Fortran/Parser/ParserUtils.hs +57/−0
• src/Language/Fortran/PrettyPrint.hs +75/−51
• src/Language/Fortran/Rewriter.hs +1/−2
• src/Language/Fortran/Transformation/Disambiguation/Function.hs +9/−7
• src/Language/Fortran/Transformation/Grouping.hs +4/−4
• src/Language/Fortran/Util/FirstParameter.hs +15/−0
• src/Language/Fortran/Util/Position.hs +21/−8
• src/Language/Fortran/Util/SecondParameter.hs +15/−0
• test-data/f77-include/no-newline/foo.f +1/−0
• test/Language/Fortran/AST/BozSpec.hs +0/−20
• test/Language/Fortran/AST/Literal/BozSpec.hs +48/−0
• test/Language/Fortran/AST/Literal/RealSpec.hs +29/−0
• test/Language/Fortran/AST/RealLitSpec.hs +0/−29
• test/Language/Fortran/Analysis/RenamingSpec.hs +14/−2
• test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs +2/−2
• test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +25/−21
• test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs +28/−18
• test/Language/Fortran/Parser/Fixed/LexerSpec.hs +1/−1
• test/Language/Fortran/Parser/Free/Common.hs +152/−12
• test/Language/Fortran/Parser/Free/Fortran2003Spec.hs +7/−7
• test/Language/Fortran/Parser/Free/Fortran90Spec.hs +4/−104
• test/Language/Fortran/Parser/Free/Fortran95Spec.hs +10/−110
• test/Language/Fortran/Parser/Free/LexerSpec.hs +1/−1
• test/Language/Fortran/PrettyPrintSpec.hs +29/−40
• test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +6/−6
• test/Language/Fortran/Transformation/GroupingSpec.hs +4/−4
• test/TestUtil.hs +6/−2

@@ -1,3 +1,32 @@+### 0.10.0 (Jul 13, 2022)+  * Fix parsing kind parameters like `a_1` on literals. Previously, that would+    be parsed as a kind parameter on a kind parameter. Now we don't do that,+    following gfortran's behaviour.+    * Kind parameter representation is changed to explicitly say if it's an+      integer kind or named constant kind, rather than reusing `Expression`.+  * BOZ literals+    * add some syntactic info (to enable checking standards conformance)+    * export `bozAsTwosComp` function for reading as two's complement integer+  * allow named constants in complex literals+  * document `FirstParameter`, `SecondParameter` behaviour/safety, fix erroneous+    instances+  * fiddle with record selectors for some AST nodes (for better Aeson instances)+  * pair IF/CASE conditions with their blocks, rather than splitting between two+    lists+  * `ExpFunctionCall` and `StCall` store procedure arguments in `AList` (`[a]`)+    instead of `Maybe AList` (`Maybe [a]`)+    * Matching is safer because empty lists are always `[]` instead of `Nothing`+      or `Just []`. Construction for empty lists is more awkward.+    * A better solution would be to use an `AList`-like that also stores extra+      syntactic information.+  * refactored a number of small AST nodes+    * `ImpElement`+    * `ForallHeader`+  * add Hackage documentation to many individual AST constructors and fields+  * improve include parser interface #227+  * improve newline handling for block parsers #228+  * fix some source span misses #225+ ### 0.9.0 (Feb 14, 2022)   * Restructure parsing-related modules for code deduplication and better user     experience.

@@ -56,9 +56,11 @@ ```  ## Building-fortran-src supports building with Stack or Cabal. You should be able to build-and use without any system dependencies other than GHC itself. Haskell library-dependencies are listed in `package.yaml`.+You will need the GMP library plus header files: on many platforms, this will be+via the package `libgmp-dev`.++Haskell library dependencies are listed in `package.yaml`. fortran-src supports+building with Stack or Cabal.  fortran-src supports **GHC 8.4 through GHC 9.0**. We regularly test at least the minimum and maximum supported GHCs. Releases prior to/newer than those may have

@@ -104,7 +104,9 @@       contents <- flexReadFile path       mods <- decodeModFiles' $ includeDirs opts       let version   = fromMaybe (deduceFortranVersion path) (fortranVersion opts)-          parsedPF  = fromRight' $ (Parser.byVerWithMods mods version) path contents+          parsedPF  = case (Parser.byVerWithMods mods version) path contents of+                        Left  a -> error $ show a+                        Right a -> a           outfmt    = outputFormat opts           mmap      = combinedModuleMap mods           tenv      = combinedTypeEnv mods

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.9.0+version:        0.10.0 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end. category:       Language@@ -26,6 +26,7 @@     README.md     CHANGELOG.md     test-data/f77-include/foo.f+    test-data/f77-include/no-newline/foo.f     test-data/rewriter/replacementsmap-columnlimit/001_foo.f     test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected     test-data/rewriter/replacementsmap-columnlimit/002_other.f@@ -71,8 +72,12 @@       Language.Fortran.Analysis.Types       Language.Fortran.AST       Language.Fortran.AST.AList-      Language.Fortran.AST.Boz-      Language.Fortran.AST.RealLit+      Language.Fortran.AST.Annotated+      Language.Fortran.AST.Common+      Language.Fortran.AST.Literal+      Language.Fortran.AST.Literal.Boz+      Language.Fortran.AST.Literal.Complex+      Language.Fortran.AST.Literal.Real       Language.Fortran.Intrinsics       Language.Fortran.LValue       Language.Fortran.Parser@@ -87,6 +92,7 @@       Language.Fortran.Parser.Free.Utils       Language.Fortran.Parser.LexerUtils       Language.Fortran.Parser.Monad+      Language.Fortran.Parser.ParserUtils       Language.Fortran.PrettyPrint       Language.Fortran.Rewriter       Language.Fortran.Rewriter.Internal@@ -202,8 +208,8 @@       Language.Fortran.Analysis.SemanticTypesSpec       Language.Fortran.Analysis.TypesSpec       Language.Fortran.AnalysisSpec-      Language.Fortran.AST.BozSpec-      Language.Fortran.AST.RealLitSpec+      Language.Fortran.AST.Literal.BozSpec+      Language.Fortran.AST.Literal.RealSpec       Language.Fortran.Parser.Fixed.Fortran66Spec       Language.Fortran.Parser.Fixed.Fortran77.IncludeSpec       Language.Fortran.Parser.Fixed.Fortran77.ParserSpec

@@ -1,29 +1,21 @@-{-# LANGUAGE DefaultSignatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for Out (NonEmpty a) --- |------ This module holds the data types used to represent Fortran code of various--- versions.------ fortran-src supports Fortran 66 through to Fortran 2003, and uses the same--- types to represent them. The Fortran standard was largely refined as it grew,--- often assimilating popular compiler extensions for the previous standard. We--- try to be as permissible as reasonable when parsing; similarly, this AST--- keeps close to the syntax, and includes statements, expressions, types etc.--- only applicable to certain (newer) versions of Fortran.------ Useful Fortran standard references:------   * Fortran 77 ANSI standard: ANSI X3.9-1978---   * Fortran 90 ANSI standard: ANSI X3.198-1992 (also ISO/IEC 1539:1991)---   * Fortran 90 Handbook (J. Adams)------ (The Fortran 66 ANSI standard lacks detail, and isn't as useful as the later--- standards for implementing the language.)------ /Note:/ some comments aren't reflected in the Haddock documentation, so you--- may also wish to view this file's source.+{- | Data types for representing Fortran code (for various versions of Fortran). +The same representation is used for all supported Fortran standards. Constructs+only available in certain versions are gated by the parsers (and the pretty+printer). In general, the definitions here are highly permissible, partly to+allow for all the oddities of older standards & extensions.++Useful Fortran standard references:++  * Fortran 2018 standard: WD 1539-1 J3/18-007r1+  * Fortran 2008 standard: WD 1539-1 J3/10-007r1+  * Fortran 90 standard: ANSI X3.198-1992 (also ISO/IEC 1539:1991)+  * Fortran 90 Handbook (J. Adams)+  * Fortran 77 standard: ANSI X3.9-1978+-}+ module Language.Fortran.AST   (   -- * AST nodes and types@@ -35,6 +27,8 @@   , Expression(..)   , Index(..)   , Value(..)+  , KindParam(..)+  , ComplexPart(..)   , UnaryOp(..)   , BinaryOp(..) @@ -45,7 +39,6 @@   , Selector(..)   , Declarator(..)   , DeclaratorType(..)-  , declaratorType   , DimensionDeclarator(..)    -- ** Annotated node list (re-export)@@ -59,6 +52,7 @@   , ProcInterface(..)   , Comment(..)   , ForallHeader(..)+  , ForallHeaderPart(..)   , Only(..)   , MetaInfo(..)   , Prefixes@@ -84,7 +78,6 @@   , FlushSpec(..)   , DoSpecification(..)   , ProgramUnitName(..)-  , Kind    -- * Node annotations & related typeclasses   , A0@@ -110,28 +103,34 @@   , updateProgramUnitBody   , programUnitSubprograms +  -- * Re-exports+  , NonEmpty(..)+   ) where  import Prelude hiding ( init ) +import Language.Fortran.AST.Common ( Name ) import Language.Fortran.AST.AList-import Language.Fortran.AST.RealLit-import Language.Fortran.AST.Boz ( Boz )+import Language.Fortran.AST.Literal+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Boz ( Boz )+import Language.Fortran.AST.Literal.Complex import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.SecondParameter+import Language.Fortran.AST.Annotated import Language.Fortran.Version  import Data.Data import Data.Binary import Control.DeepSeq import Text.PrettyPrint.GenericPretty+import Data.List.NonEmpty ( NonEmpty(..) )  -- | The empty annotation. type A0 = () -type Name = String- -------------------------------------------------------------------------------- -- Basic AST nodes --------------------------------------------------------------------------------@@ -161,16 +160,19 @@   | ClassStar   | ClassCustom String   | TypeByte-  deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary BaseType+  deriving stock (Ord, Eq, Show, Data, Generic)+  deriving anyclass (Binary)  -- | The type specification of a declaration statement, containing the syntactic --   type name and kind selector. -- -- See HP's F90 spec pg.24.-data TypeSpec a = TypeSpec a SrcSpan BaseType (Maybe (Selector a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data TypeSpec a = TypeSpec+  { typeSpecAnno :: a+  , typeSpecSpan :: SrcSpan+  , typeSpecBaseType :: BaseType+  , typeSpecSelector :: Maybe (Selector a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  -- | The "kind selector" of a declaration statement. --@@ -183,60 +185,77 @@ -- The upshot is, length is invalid for non-CHARACTER types, and the parser -- guarantees that it will be Nothing. For CHARACTER types, both maybe or may -- not be present.-data Selector a =-  Selector a SrcSpan-    (Maybe (Expression a)) -- ^ length (if present)-    (Maybe (Expression a)) -- ^ kind (if present)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)--type Kind = Int+data Selector a = Selector+  { selectorAnno :: a+  , selectorSpan :: SrcSpan+  , selectorLength :: Maybe (Expression a)+  , selectorKind   :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  data MetaInfo = MetaInfo { miVersion :: FortranVersion, miFilename :: String }-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving stock (Eq, Show, Data, Generic)  -- Program structure definition-data ProgramFile a = ProgramFile MetaInfo [ ProgramUnit a ]-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data ProgramFile a = ProgramFile+  { programFileMeta :: MetaInfo+  , programFileProgramUnits :: [ ProgramUnit a ]+  } deriving stock (Eq, Show, Data, Generic, Functor)  pfSetFilename :: String -> ProgramFile a -> ProgramFile a pfSetFilename fn (ProgramFile mi pus) = ProgramFile (mi { miFilename = fn }) pus pfGetFilename :: ProgramFile a -> String pfGetFilename (ProgramFile mi _) = miFilename mi +-- | A Fortran program unit. _(F2008 2.2)_+--+-- A Fortran program is made up of many program units.+--+-- Related points from the Fortran 2008 specification:+--+--   * There must be exactly one main program, and any number of other program+--     units.+--   * Note 2.3: There may be at most 1 unnamed block data program unit. data ProgramUnit a =-    PUMain+    PUMain                          -- ^ Main program       a SrcSpan-      (Maybe Name) -- Program name-      [Block a] -- Body-      (Maybe [ProgramUnit a]) -- Subprograms-  | PUModule+      (Maybe Name)                  -- ^ Program name+      [Block a]                     -- ^ Body+      (Maybe [ProgramUnit a])       -- ^ Subprograms++  | PUModule                        -- ^ Module       a SrcSpan-      Name -- Program name-      [Block a] -- Body-      (Maybe [ProgramUnit a]) -- Subprograms-  | PUSubroutine+      Name                          -- ^ Program name+      [Block a]                     -- ^ Body+      (Maybe [ProgramUnit a])       -- ^ Subprograms++  | PUSubroutine                    -- ^ Subroutine subprogram (procedure)       a SrcSpan-      (PrefixSuffix a) -- Subroutine options-      Name-      (Maybe (AList Expression a)) -- Arguments-      [Block a] -- Body-      (Maybe [ProgramUnit a]) -- Subprograms-  | PUFunction+      (PrefixSuffix a)              -- ^ Options (elemental, pure etc.)+      Name                          -- ^ Name+      (Maybe (AList Expression a))  -- ^ Arguments+      [Block a]                     -- ^ Body+      (Maybe [ProgramUnit a])       -- ^ Subprograms++  | PUFunction                      -- ^ Function subprogram (procedure)       a SrcSpan-      (Maybe (TypeSpec a)) -- Return type-      (PrefixSuffix a) -- Function Options-      Name-      (Maybe (AList Expression a)) -- Arguments-      (Maybe (Expression a)) -- Result-      [Block a] -- Body-      (Maybe [ProgramUnit a]) -- Subprograms-  | PUBlockData+      (Maybe (TypeSpec a))          -- ^ Return type+      (PrefixSuffix a)              -- ^ Options (elemental, pure etc.)+      Name                          -- ^ Name+      (Maybe (AList Expression a))  -- ^ Arguments+      (Maybe (Expression a))        -- ^ Result+      [Block a]                     -- ^ Body+      (Maybe [ProgramUnit a])       -- ^ Subprograms++  | PUBlockData                     -- ^ Block data (named or unnamed).       a SrcSpan-      (Maybe Name)+      (Maybe Name)                  -- ^ Optional block       [Block a] -- Body-  | PUComment a SrcSpan (Comment a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor) +  | PUComment                       -- ^ Program unit-level comment+      a SrcSpan+      (Comment a)+  deriving stock (Eq, Show, Data, Generic, Functor)+ type Prefixes a = Maybe (AList Prefix a) type Suffixes a = Maybe (AList Suffix a) type PrefixSuffix a = (Prefixes a, Suffixes a)@@ -253,7 +272,7 @@ data Prefix a = PfxRecursive a SrcSpan               | PfxElemental a SrcSpan               | PfxPure a SrcSpan-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  -- see C1241 & C1242 (Fortran2003) validPrefixSuffix :: PrefixSuffix a -> Bool@@ -267,7 +286,7 @@     sfxs = aStrip' msfxs  data Suffix a = SfxBind a SrcSpan (Maybe (Expression a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _)              = bs@@ -299,33 +318,37 @@ programUnitSubprograms PUComment{}                 = Nothing  newtype Comment a = Comment String-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  data Block a =-    BlStatement a SrcSpan+    BlStatement                              -- ^ Statement+                a SrcSpan                 (Maybe (Expression a))       -- ^ Label-                (Statement a)                -- ^ Statement+                (Statement a)                -- ^ Wrapped statement -  | BlForall    a SrcSpan+  | BlForall                                 -- ^ FORALL array assignment syntax+                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+  | BlIf                                     -- ^ IF block construct+                a SrcSpan                 (Maybe (Expression a))       -- ^ Label                 (Maybe String)               -- ^ Construct name-                [ Maybe (Expression a) ]     -- ^ Conditions-                [ [ Block a ] ]              -- ^ Bodies+                (NonEmpty (Expression a, [Block a])) -- ^ IF, ELSE IF clauses+                (Maybe [Block a])            -- ^ ELSE block                 (Maybe (Expression a))       -- ^ Label to END IF -  | BlCase      a SrcSpan+  | BlCase                                   -- ^ SELECT CASE construct+                a SrcSpan                 (Maybe (Expression a))       -- ^ Label                 (Maybe String)               -- ^ Construct name                 (Expression a)               -- ^ Scrutinee-                [ Maybe (AList Index a) ]    -- ^ Case ranges-                [ [ Block a ] ]              -- ^ Bodies+                [(AList Index a, [Block a])] -- ^ CASE clauses+                (Maybe [Block a])            -- ^ CASE default                 (Maybe (Expression a))       -- ^ Label to END SELECT    | BlDo        a SrcSpan@@ -344,45 +367,83 @@                 [ Block a ]                  -- ^ Body                 (Maybe (Expression a))       -- ^ Label to END DO -  | BlAssociate a SrcSpan-                (Maybe (Expression a))       -- Label-                (Maybe String)               -- Construct name-                (AList (ATuple Expression Expression) a) -- Expression abbreviations-                [ Block a ]                  -- Body-                (Maybe (Expression a))       -- Label to END IF+  | BlAssociate   -- ^ The first 'Expression' in the abbreviation tuple is always an-  --   @ExpValue _ _ (ValVariable id)@. Also guaranteed nonempty.+  --   @ExpValue _ _ (ValVariable id)@. Also guaranteed nonempty. TODO+                a SrcSpan+                (Maybe (Expression a))       -- ^ Label+                (Maybe String)               -- ^ Construct name+                (AList (ATuple Expression Expression) a) -- ^ Expression abbreviations+                [ Block a ]                  -- ^ Body+                (Maybe (Expression a))       -- ^ Label    | BlInterface a SrcSpan-                (Maybe (Expression a))       -- ^ label-                Bool                         -- ^ abstract?-                [ ProgramUnit a ]            -- ^ Routine decls. in the interface+                (Maybe (Expression a))       -- ^ Label+                Bool                         -- ^ Is this an abstract interface?+                [ ProgramUnit a ]            -- ^ Interface procedures                 [ Block a ]                  -- ^ Module procedures -  | BlComment a SrcSpan (Comment a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  | BlComment                                -- ^ Block-level comment+                a SrcSpan+                (Comment a)+  deriving stock (Eq, Show, Data, Generic, Functor)  data Statement a  =-    StDeclaration         a SrcSpan (TypeSpec a) (Maybe (AList Attribute a)) (AList Declarator a)-  | StStructure           a SrcSpan (Maybe String) (AList StructureItem a)+    StDeclaration+    -- ^ Declare variable(s) at a given type.+        a SrcSpan+        (TypeSpec a)                -- ^ Type specification+        (Maybe (AList Attribute a)) -- ^ Attributes+        (AList Declarator a)        -- ^ Declarators++  | StStructure+    -- ^ A structure (pre-F90 extension) declaration.+        a SrcSpan+        (Maybe String)          -- ^ Structure name+        (AList StructureItem a) -- ^ Structure fields+   | StIntent              a SrcSpan Intent (AList Expression a)   | StOptional            a SrcSpan (AList Expression a)   | StPublic              a SrcSpan (Maybe (AList Expression a))   | StPrivate             a SrcSpan (Maybe (AList Expression a))   | StProtected           a SrcSpan (Maybe (AList Expression a))-  | StSave                a SrcSpan (Maybe (AList Expression a))++  | StSave+    -- ^ SAVE statement: variable retains its value between invocations+        a SrcSpan+        (Maybe (AList Expression a))+        -- ^ Save the given variables, or all saveable items in the program unit+        --   if 'Nothing'+   | StDimension           a SrcSpan (AList Declarator a)+    -- ^ DIMENSION attribute as statement.+   | StAllocatable         a SrcSpan (AList Declarator a)+    -- ^ ALLOCATABLE attribute statement.+   | StAsynchronous        a SrcSpan (AList Declarator a)+    -- ^ ASYNCHRONOUS attribute statement.+   | StPointer             a SrcSpan (AList Declarator a)+    -- ^ POINTER attribute statement.+   | StTarget              a SrcSpan (AList Declarator a)+    -- ^ TARGET attribute statement.+   | StValue               a SrcSpan (AList Declarator a)+    -- ^ VALUE attribute statement.+   | StVolatile            a SrcSpan (AList Declarator a)+    -- ^ VOLATILE attribute statement.+   | StData                a SrcSpan (AList DataGroup a)   | StAutomatic           a SrcSpan (AList Declarator a)   | StStatic              a SrcSpan (AList Declarator a)   | StNamelist            a SrcSpan (AList Namelist a)+   | StParameter           a SrcSpan (AList Declarator a)+    -- ^ PARAMETER attribute as statement.+   | StExternal            a SrcSpan (AList Expression a)   | StIntrinsic           a SrcSpan (AList Expression a)   | StCommon              a SrcSpan (AList CommonGroup a)@@ -390,22 +451,44 @@   | StEquivalence         a SrcSpan (AList (AList Expression) a)   | 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))+  | StEntry+        a SrcSpan+        (Expression a)               -- ^ name (guaranteed @ExpValue ValVariable@)+        (Maybe (AList Expression a)) -- ^ argument variables+        (Maybe (Expression a))       -- ^ optional result variable (guaranteed @ExpValue ValVariable@) -  | StInclude             a SrcSpan (Expression a) (Maybe [Block a])-  -- ^ Nothing indicates an yet-to-be processed include. (The F77 parser parses-  -- Nothing, then fills out each include statement in a post-parse step.)+  | StInclude+        a SrcSpan+        (Expression a) -- ^ file name to include. guaranteed @ExpValue ValString@+        (Maybe [Block a]) -- ^ First parsed to 'Nothing', then potentially "expanded out" in a post-parse step.    | 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)-  | StCycle               a SrcSpan (Maybe (Expression a))+  | StCycle               a SrcSpan (Maybe (Expression a)) -- ^ guaranteed @ExpValue ValVariable@   | StExit                a SrcSpan (Maybe (Expression a))-  | StIfLogical           a SrcSpan (Expression a) (Statement a) -- Statement should not further recurse+  | StIfLogical+        a SrcSpan+        (Expression a) -- ^ condition+        (Statement a)  -- ^ statement (should not further recurse)   | StIfArithmetic        a SrcSpan (Expression a) (Expression a) (Expression a) (Expression a)-  | StSelectCase          a SrcSpan (Maybe String) (Expression a)-  | StCase                a SrcSpan (Maybe String) (Maybe (AList Index a))-  | StEndcase             a SrcSpan (Maybe String)++  | StSelectCase -- ^ CASE construct opener.+        a SrcSpan+        (Maybe String) -- ^ block name+        (Expression a)+        -- ^ CASE expression. Should be one of scalar CHARACTER, INTEGER or LOGICAL.++  | StCase -- ^ inner CASE clause+        a SrcSpan+        (Maybe String) -- ^ block name (must match a corresponding opener)+        (Maybe (AList Index a))+        -- ^ CASE indices (expressions). 'Nothing' means it's CASE DEFAULT.++  | StEndcase -- ^ END SELECT statement+        a SrcSpan+        (Maybe String) -- ^ block name (must match corresponding opener name)+   | StFunction            a SrcSpan (Expression a) (AList Expression a) (Expression a)   | StExpressionAssign    a SrcSpan (Expression a) (Expression a)   | StPointerAssign       a SrcSpan (Expression a) (Expression a)@@ -413,7 +496,7 @@   | StGotoUnconditional   a SrcSpan (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))+  | StCall                a SrcSpan (Expression a) (AList Argument a)   | StReturn              a SrcSpan (Maybe (Expression a))   | StContinue            a SrcSpan   | StStop                a SrcSpan (Maybe (Expression a))@@ -422,7 +505,16 @@   | 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))++  | StTypePrint+    -- ^ Special TYPE "print" statement (~F77 syntactic sugar for PRINT/WRITE)+    --+    -- Not to be confused with the TYPE construct in later standards for+    -- defining derived data types.+        a SrcSpan+        (Expression a) -- ^ format identifier+        (Maybe (AList Expression a)) -- ^ variables etc. to print+   | StOpen                a SrcSpan (AList ControlPair a)   | StClose               a SrcSpan (AList ControlPair a)   | StFlush               a SrcSpan (AList FlushSpec a)@@ -433,66 +525,154 @@   | StBackspace2          a SrcSpan (Expression a)   | StEndfile             a SrcSpan (AList ControlPair a)   | StEndfile2            a SrcSpan (Expression a)-  | StAllocate            a SrcSpan (Maybe (TypeSpec a)) (AList Expression a) (Maybe (AList AllocOpt a))-  | StNullify             a SrcSpan (AList Expression a)-  | StDeallocate          a SrcSpan (AList Expression a) (Maybe (AList AllocOpt a))-  | StWhere               a SrcSpan (Expression a) (Statement a)-  | StWhereConstruct      a SrcSpan (Maybe String) (Expression a)-  | StElsewhere           a SrcSpan (Maybe String) (Maybe (Expression a))-  | StEndWhere            a SrcSpan (Maybe String)-  | StUse                 a SrcSpan (Expression a) (Maybe ModuleNature) Only (Maybe (AList Use a))-  | StModuleProcedure     a SrcSpan (AList Expression a)-  | StProcedure           a SrcSpan (Maybe (ProcInterface a)) (Maybe (Attribute a)) (AList ProcDecl a)-  | StType                a SrcSpan (Maybe (AList Attribute a)) String-  | StEndType             a SrcSpan (Maybe String)++  | StAllocate -- ^ ALLOCATE: associate pointers with targets+        a SrcSpan+        (Maybe (TypeSpec a))+        (AList Expression a) -- ^ pointers (variables/references)+        (Maybe (AList AllocOpt a))+  | StNullify -- ^ NULLIFY: disassociate pointers from targets+        a SrcSpan+        (AList Expression a) -- ^ pointers (variables/references)+  | StDeallocate -- ^ DEALLOCATE: disassociate pointers from targets+        a SrcSpan+        (AList Expression a) -- ^ pointers (variables/references)+        (Maybe (AList AllocOpt a))++  | StWhere+        a SrcSpan+        (Expression a) -- ^ must be LOGICAL+        (Statement a) -- ^ guaranteed to be 'StExpressionAssign'++  | StWhereConstruct -- ^ begin WHERE block+        a SrcSpan+        (Maybe String) -- ^ block name+        (Expression a) -- ^ must be LOGICAL+  | StElsewhere -- ^ WHERE clause. compare to IF, IF ELSE+        a SrcSpan+        (Maybe String) -- ^ block name+        (Maybe (Expression a)) -- ^ must be LOGICAL+  | StEndWhere -- ^ end WHERE block+        a SrcSpan+        (Maybe String) -- ^ block name++  | StUse+    -- ^ Import definitions (procedures, types) from a module. /(F2018 14.2.2)/+    --+    -- If a module nature isn't provided and there are both intrinsic and+    -- nonintrinsic modules with that name, the nonintrinsic module is selected.+        a SrcSpan+        (Expression a)+        -- ^ name of module to use, guaranteed to be @ExpValue ValVariable@+        (Maybe ModuleNature)  -- ^ optional explicit module nature+        Only+        (Maybe (AList Use a)) -- ^ definitions to import (including renames)++  | StModuleProcedure+        a SrcSpan+        (AList Expression a)+        -- ^ procedure names, guaranteed @ExpValue ValVariable@+  | StProcedure           a SrcSpan (Maybe (ProcInterface a)) (Maybe (AList Attribute a)) (AList ProcDecl a)++  | StType -- ^ TYPE ... = begin a DDT (derived data type) definition block+        a SrcSpan+        (Maybe (AList Attribute a)) -- ^ attributes (subset permitted)+        String                      -- ^ DDT name++  | StEndType+    -- ^ END TYPE [ type-name ] = end a DDT definition block+        a SrcSpan+        (Maybe String) -- ^ optional type name (must match corresponding opener)+   | StSequence            a SrcSpan-  | StForall              a SrcSpan (Maybe String) (ForallHeader a)-  | StForallStatement     a SrcSpan (ForallHeader a) (Statement a)-  | StEndForall           a SrcSpan (Maybe String)-  | StImport              a SrcSpan (AList Expression a)++  | StForall -- ^ FORALL ... = begin a FORALL block+        a SrcSpan+        (Maybe String)   -- ^ block name+        (ForallHeader a) -- ^ FORALL header syntax+  | StEndForall+    -- ^ END FORALL [ construct-name ]+        a SrcSpan+        (Maybe String) -- ^ block name++  | StForallStatement -- ^ FORALL statement - essentially an inline FORALL block+        a SrcSpan+        (ForallHeader a) -- ^ FORALL header syntax+        (Statement a)    -- ^ guaranteed 'StExpressionAssign' or 'StPointerAssign'++  | StImport+        a SrcSpan+        (AList Expression a) -- ^ guaranteed @ExpValue ValVariable@+   | StEnum                a SrcSpan   | StEnumerator          a SrcSpan (AList Declarator a)   | StEndEnum             a SrcSpan   -- Following is a temporary solution to a complicated FORMAT statement   -- parsing problem.   | StFormatBogus         a SrcSpan String-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  -- R1214 proc-decl is procedure-entity-name [=> null-init]-data ProcDecl a = ProcDecl a SrcSpan (Expression a) (Maybe (Expression a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data ProcDecl a = ProcDecl+  { procDeclAnno       :: a+  , procDeclSpan       :: SrcSpan+  , procDeclEntityName :: Expression a+  , procDeclInitName   :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  -- R1212 proc-interface is interface-name or declaration-type-spec data ProcInterface a = ProcInterfaceName a SrcSpan (Expression a)                      | ProcInterfaceType a SrcSpan (TypeSpec a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor) +-- | Part of a FORALL statement. Introduced in Fortran 95. data ForallHeader a = ForallHeader-    -- List of tuples: index-name, start subscript, end subscript, optional stride-    [(Name, Expression a, Expression a, Maybe (Expression a))]-    -- An optional expression for scaling-    (Maybe (Expression a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  { forallHeaderAnno    :: a+  , forallHeaderSpan    :: SrcSpan+  , forallHeaderHeaders :: [ForallHeaderPart a]+  , forallHeaderScaling :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor) +data ForallHeaderPart a = ForallHeaderPart+  { forallHeaderPartAnno   :: a+  , forallHeaderPartSpan   :: SrcSpan+  , forallHeaderPartName   :: Name+  , forallHeaderPartStart  :: Expression a+  , forallHeaderPartEnd    :: Expression a+  , forallHeaderPartStride :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)+ data Only = Exclusive | Permissive-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving stock (Eq, Show, Data, Generic)  data ModuleNature = ModIntrinsic | ModNonIntrinsic-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving stock (Eq, Show, Data, Generic) +-- | Part of USE statement. /(F2018 14.2.2)/+--+-- Expressions may be names or operators. data Use a =-    UseRename a SrcSpan (Expression a) (Expression a)-  | UseID a SrcSpan (Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+    UseRename+        a SrcSpan+        (Expression a) -- ^ local name+        (Expression a) -- ^ use name+  | UseID+        a SrcSpan+        (Expression a) -- ^ name+  deriving stock (Eq, Show, Data, Generic, Functor)  -- TODO potentially should throw Maybe String into ArgumentExpression too?-data Argument a = Argument a SrcSpan (Maybe String) (ArgumentExpression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data Argument a = Argument+  { argumentAnno :: a+  , argumentSpan :: SrcSpan+  , argumentName :: Maybe String+  , argumentExpr :: ArgumentExpression a+  } deriving stock (Eq, Show, Data, Generic, Functor)  data ArgumentExpression a   = ArgExpr              (Expression a)   | ArgExprVar a SrcSpan Name-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  argExprNormalize :: ArgumentExpression a -> Expression a argExprNormalize = \case ArgExpr         e -> e@@ -519,51 +699,105 @@   | AttrTarget a SrcSpan   | AttrValue a SrcSpan   | AttrVolatile a SrcSpan-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  data Intent = In | Out | InOut-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving stock (Eq, Show, Data, Generic) -data ControlPair a = ControlPair a SrcSpan (Maybe String) (Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data ControlPair a = ControlPair+  { controlPairAnno :: a+  , controlPairSpan :: SrcSpan+  , controlPairName :: Maybe String+  , controlPairExpr :: Expression a+  } deriving stock (Eq, Show, Data, Generic, Functor) +-- | Part of ALLOCATE statement.+--+-- There are restrictions on how ALLOCATE options can be combined. See F2018+-- 9.7.1, or:+-- https://www.intel.com/content/www/us/en/develop/documentation/fortran-compiler-oneapi-dev-guide-and-reference/top/language-reference/a-to-z-reference/a-to-b/allocate-statement.html data AllocOpt a =-    AOStat a SrcSpan (Expression a)-  | AOErrMsg a SrcSpan (Expression a)+    AOStat   -- ^ (output) status of allocation+        a SrcSpan+        (Expression a) -- ^ scalar integer variable+  | AOErrMsg -- ^ (output) error condition if present+        a SrcSpan+        (Expression a) -- ^ scalar character variable   | AOSource a SrcSpan (Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor) -data ImpList a = ImpList a SrcSpan (TypeSpec a) (AList ImpElement a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+-- | List of names for an IMPLICIT statement.+data ImpList a = ImpList+  { impListAnno :: a+  , impListSpan :: SrcSpan+  , impListType :: TypeSpec a+  , impListElements :: AList ImpElement a+  } deriving stock (Eq, Show, Data, Generic, Functor) -data ImpElement a =-    ImpCharacter    a SrcSpan String-  | ImpRange        a SrcSpan String String-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data ImpElement a = ImpElement+  { impElementAnno :: a+  , impElementSpan :: SrcSpan+  , impElementFrom :: Char+  , impElementTo   :: Maybe Char+  } deriving stock (Eq, Show, Data, Generic, Functor) --- | Note that the 'Declarator's in common group definitions do not contain---   initializing expressions.-data CommonGroup a =-  CommonGroup a SrcSpan (Maybe (Expression a)) (AList Declarator a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+-- | A single COMMON block definition.+--+-- The 'Declarator's here shall not contain initializing expressions.+data CommonGroup a = CommonGroup+  { commonGroupAnno :: a+  , commonGroupSpan :: SrcSpan+  , commonGroupName :: Maybe (Expression a)+  , commonGroupVars :: AList Declarator a+  } deriving stock (Eq, Show, Data, Generic, Functor) -data Namelist a =-  Namelist a SrcSpan (Expression a) (AList Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data Namelist a = Namelist+  { namelistAnno :: a+  , namelistSpan :: SrcSpan+  , namelistName :: Expression a+  , namelistVars :: AList Expression a+  } deriving stock (Eq, Show, Data, Generic, Functor) -data DataGroup a =-  DataGroup a SrcSpan (AList Expression a) (AList Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+-- | The part of a DATA statement describing a single set of initializations.+--+-- The initializer list must be compatible with the name list. Generally, that+-- means either the lengths must be equal, or the name list is the singleton+-- list referring to an array, and the initializer list is compatible with that+-- array's shape.+data DataGroup a = DataGroup+  { dataGroupAnno         :: a+  , dataGroupSpan         :: SrcSpan+  , dataGroupNames        :: AList Expression a+  , dataGroupInitializers :: AList Expression a+  } deriving stock (Eq, Show, Data, Generic, Functor) +-- | Field types in pre-Fortran 90 non-standard structure/record/union+--   extension.+--+-- Structures were obsoleted by derived types in later standards.+--+-- The outer structure is stored in 'StStructure'. 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) String (AList StructureItem a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+    StructFields    -- ^ Regular field+        a SrcSpan+        (TypeSpec a)                -- ^ Type+        (Maybe (AList Attribute a)) -- ^ Attributes+        (AList Declarator a)        -- ^ Declarators+  | StructUnion     -- ^ Union field+        a SrcSpan+        (AList UnionMap a) -- ^ Union fields+  | StructStructure -- ^ Substructure (nested/inline record/structure)+        a SrcSpan+        (Maybe String)          -- ^ Substructure name+        String                  -- ^ Field name+        (AList StructureItem a) -- ^ Substructure fields+  deriving stock (Eq, Show, Data, Generic, Functor) -data UnionMap a =-  UnionMap a SrcSpan (AList StructureItem a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data UnionMap a = UnionMap+  { unionMapAnno   :: a+  , unionMapSpan   :: SrcSpan+  , unionMapFields :: AList StructureItem a+  } deriving stock (Eq, Show, Data, Generic, Functor)  data FormatItem a =     FIFormatList            a             SrcSpan   (Maybe String) (AList FormatItem a)@@ -574,18 +808,33 @@   | FIFieldDescriptorAIL    a             SrcSpan   (Maybe Integer)   Char          Integer   | FIBlankDescriptor       a             SrcSpan   Integer   | FIScaleFactor           a             SrcSpan   Integer-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor) -data FlushSpec a =-    FSUnit a SrcSpan (Expression a)-  | FSIOStat a SrcSpan (Expression a)-  | FSIOMsg a SrcSpan (Expression a)-  | FSErr a SrcSpan (Expression a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+-- | Part of the newer (Fortran 2003?) FLUSH statement.+--+-- See: https://www.ibm.com/docs/en/xl-fortran-aix/15.1.0?topic=attributes-flush-fortran-2003+data FlushSpec a+  = FSUnit+        a SrcSpan+        (Expression a) -- ^ scalar integer expression+  | FSIOStat+        a SrcSpan+        (Expression a) -- ^ scalar integer variable+  | FSIOMsg+        a SrcSpan+        (Expression a) -- ^ scalar character variable+  | FSErr+        a SrcSpan+        (Expression a) -- ^ statement label+    deriving stock (Eq, Show, Data, Generic, Functor) -data DoSpecification a =-  DoSpecification a SrcSpan (Statement a) (Expression a) (Maybe (Expression a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data DoSpecification a = DoSpecification+  { doSpecAnno      :: a+  , doSpecSpan      :: SrcSpan+  , doSpecInitial   :: Statement a -- ^ Guaranteed to be 'StExpressionAssign'+  , doSpecLimit     :: Expression a+  , doSpecIncrement :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  data Expression a =     ExpValue         a SrcSpan (Value a)@@ -598,7 +847,7 @@   -- ^ Array indexing   | ExpDataRef       a SrcSpan (Expression a) (Expression a)   -- ^ @%@ notation for variables inside data types-  | ExpFunctionCall  a SrcSpan (Expression a) (Maybe (AList Argument a))+  | ExpFunctionCall  a SrcSpan (Expression a) (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)@@ -606,7 +855,7 @@   -- ^ Array initialisation   | ExpReturnSpec    a SrcSpan (Expression a)   -- ^ Function return value specification-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor)  data Index a =     IxSingle a SrcSpan (Maybe String) (Expression a)@@ -614,36 +863,37 @@             (Maybe (Expression a)) -- ^ Lower index             (Maybe (Expression a)) -- ^ Upper index             (Maybe (Expression a)) -- ^ Stride-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+  deriving stock (Eq, Show, Data, Generic, Functor) --- All recursive Values+-- | Values and literals. data Value a-  = ValInteger           String (Maybe (Expression a))+  = ValInteger           String  (Maybe (KindParam a))   -- ^ The string representation of an integer literal-  | ValReal              RealLit (Maybe (Expression a))+  | ValReal         RealLit (Maybe (KindParam a))   -- ^ The string representation of a real literal-  | ValComplex           (Expression a) (Expression a)-  -- ^ The real and imaginary parts of a complex value-  | ValString            String+  | ValComplex      (ComplexLit a)+  -- ^ The real and imaginary parts of a complex literal @(real, imag)@.+  | ValString       String   -- ^ A string literal-  | ValBoz               Boz+  | ValBoz          Boz   -- ^ A BOZ literal constant-  | ValHollerith         String+  | ValHollerith    String   -- ^ A Hollerith literal-  | ValVariable          Name+  | ValVariable     Name   -- ^ The name of a variable-  | ValIntrinsic         Name+  | ValIntrinsic    Name   -- ^ The name of a built-in function-  | ValLogical           Bool (Maybe (Expression a))+  | ValLogical      Bool (Maybe (KindParam a))   -- ^ A boolean value-  | ValOperator          String+  | ValOperator     String   -- ^ User-defined operators in interfaces   | ValAssignment   -- ^ Overloaded assignment in interfaces-  | ValType              String+  | ValType         String   | ValStar   | ValColon                   -- see R402 / C403 in Fortran2003 spec.-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+    deriving stock    (Eq, Show, Data, Generic, Functor)+    deriving anyclass (NFData, Out)  -- | Declarators. R505 entity-decl from F90 ISO spec. --@@ -659,21 +909,19 @@ -- Only CHARACTERs may specify a length. However, a nonstandard syntax feature -- uses non-CHARACTER lengths as a kind parameter. We parse regardless of type -- and warn during analysis.-data Declarator a-  = Declarator a SrcSpan-               (Expression a)         -- ^ Variable-               (DeclaratorType a)     -- ^ Declarator type (dimensions if array)-               (Maybe (Expression a)) -- ^ Length (character)-               (Maybe (Expression a)) -- ^ Initial value-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data Declarator a = Declarator+  { declaratorAnno     :: a+  , declaratorSpan     :: SrcSpan+  , declaratorVariable :: Expression a+  , declaratorType     :: DeclaratorType a+  , declaratorLength   :: Maybe (Expression a)+  , declaratorInitial  :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  data DeclaratorType a   = ScalarDecl   | ArrayDecl (AList DimensionDeclarator a)-  deriving (Eq, Show, Data, Typeable, Generic, Functor)--declaratorType :: Declarator a -> DeclaratorType a-declaratorType (Declarator _ _ _ dt _ _) = dt+  deriving stock (Eq, Show, Data, Generic, Functor)  -- | Set a 'Declarator''s initializing expression only if it has none already. setInitialisation :: Declarator a -> Expression a -> Declarator a@@ -682,16 +930,19 @@ setInitialisation d _ = d  -- | Dimension declarator stored in @dimension@ attributes and 'Declarator's.-data DimensionDeclarator a =-  DimensionDeclarator a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+data DimensionDeclarator a = DimensionDeclarator+  { dimDeclAnno :: a+  , dimDeclSpan :: SrcSpan+  , dimDeclLower :: Maybe (Expression a)+  , dimDeclUpper :: Maybe (Expression a)+  } deriving stock (Eq, Show, Data, Generic, Functor)  data UnaryOp =     Plus   | Minus   | Not   | UnCustom String-  deriving (Eq, Ord, Show, Data, Typeable, Generic)+  deriving stock (Eq, Ord, Show, Data, Generic)  instance Binary UnaryOp @@ -714,23 +965,10 @@   | Equivalent   | NotEquivalent   | BinCustom String-  deriving (Eq, Ord, Show, Data, Typeable, Generic)+  deriving stock (Eq, Ord, Show, Data, Generic)  instance Binary BinaryOp --- Retrieving SrcSpan and Annotation from nodes-class Annotated f where-  getAnnotation :: f a -> a-  setAnnotation :: a -> f a -> f a-  modifyAnnotation :: (a -> a) -> f a -> f a-  default getAnnotation :: (FirstParameter (f a) a) => f a -> a-  getAnnotation = getFirstParameter--  default setAnnotation :: (FirstParameter (f a) a) => a -> f a -> f a-  setAnnotation = setFirstParameter--  modifyAnnotation f x = setAnnotation (f (getAnnotation x)) x- instance FirstParameter (ProgramUnit a) a instance FirstParameter (Prefix a) a instance FirstParameter (Suffix a) a@@ -759,6 +997,8 @@ instance FirstParameter (DimensionDeclarator a) a instance FirstParameter (ControlPair a) a instance FirstParameter (AllocOpt a) a+instance FirstParameter (ForallHeader a) a+instance FirstParameter (ForallHeaderPart a) a  instance SecondParameter (ProgramUnit a) SrcSpan instance SecondParameter (Prefix a) SrcSpan@@ -788,8 +1028,9 @@ instance SecondParameter (DimensionDeclarator a) SrcSpan instance SecondParameter (ControlPair a) SrcSpan instance SecondParameter (AllocOpt a) SrcSpan+instance SecondParameter (ForallHeader a) SrcSpan+instance SecondParameter (ForallHeaderPart a) SrcSpan -instance Annotated (AList t) instance Annotated ProgramUnit instance Annotated Block instance Annotated Statement@@ -816,6 +1057,8 @@ instance Annotated DimensionDeclarator instance Annotated ControlPair instance Annotated AllocOpt+instance Annotated ForallHeader+instance Annotated ForallHeaderPart  instance Spanned (ProgramUnit a) instance Spanned (Prefix a)@@ -845,6 +1088,8 @@ instance Spanned (DimensionDeclarator a) instance Spanned (ControlPair a) instance Spanned (AllocOpt a)+instance Spanned (ForallHeader a)+instance Spanned (ForallHeaderPart a)  instance Spanned (ProgramFile a) where   getSpan (ProgramFile _ pus) =@@ -875,7 +1120,7 @@   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 (BlIf a s _ mn clauses elseBlock el) l = BlIf a s (Just l) mn clauses elseBlock 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 tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el   setLabel b _ = b@@ -885,7 +1130,7 @@   | NamelessBlockData   | NamelessComment   | NamelessMain-  deriving (Ord, Eq, Show, Data, Typeable, Generic)+  deriving stock (Ord, Eq, Show, Data, Generic)  instance Binary ProgramUnitName instance NFData ProgramUnitName@@ -944,7 +1189,6 @@ instance Out a => Out (Index a) instance Out a => Out (DoSpecification a) instance Out a => Out (FlushSpec a)-instance Out a => Out (Value a) instance Out a => Out (TypeSpec a) instance Out a => Out (Selector a) instance Out BaseType@@ -956,6 +1200,7 @@ instance Out UnaryOp instance Out BinaryOp instance Out a => Out (ForallHeader a)+instance Out a => Out (ForallHeaderPart a)  -- Classifiers on statement and blocks ASTs @@ -1016,7 +1261,6 @@ instance NFData a => NFData (Expression a) instance NFData a => NFData (TypeSpec a) instance NFData a => NFData (Index a)-instance NFData a => NFData (Value a) instance NFData a => NFData (Comment a) instance NFData a => NFData (Statement a) instance NFData a => NFData (ProcDecl a)@@ -1024,6 +1268,7 @@ instance NFData a => NFData (DoSpecification a) instance NFData a => NFData (Selector a) instance NFData a => NFData (ForallHeader a)+instance NFData a => NFData (ForallHeaderPart a) instance NFData a => NFData (Argument a) instance NFData a => NFData (ArgumentExpression a) instance NFData a => NFData (Use a)@@ -1051,3 +1296,5 @@ instance NFData Only instance NFData ModuleNature instance NFData Intent++instance Out a => Out (NonEmpty a)

@@ -3,8 +3,9 @@ import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.SecondParameter import Language.Fortran.Util.Position (Spanned, SrcSpan(..), getSpan)+import Language.Fortran.AST.Annotated ( Annotated ) -import Data.Data    (Data, Typeable)+import Data.Data    (Data) import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Text.PrettyPrint.GenericPretty (Out)@@ -16,12 +17,18 @@ -- declarations), we define a dedicated annotated list type to reuse. -- -- Note that the list itself also holds an @a@ annotation.-data AList t a = AList a SrcSpan [t a] deriving (Eq, Show, Data, Typeable, Generic)+data AList t a = AList+  { alistAnno :: a+  , alistSpan :: SrcSpan+  , alistList :: [t a]+  } deriving stock (Eq, Show, Data, Generic)+ instance Functor t => Functor (AList t) where   fmap f (AList a s xs) = AList (f a) s (map (fmap f) xs)  instance FirstParameter (AList t a) a instance SecondParameter (AList t a) SrcSpan+instance Annotated (AList t) instance Spanned (AList t a) instance (Out a, Out (t a)) => Out (AList t a) instance (NFData a, NFData (t a)) => NFData (AList t a)@@ -46,6 +53,9 @@  infixr 5 `aCons` +aEmpty :: a -> SrcSpan -> AList t a+aEmpty a s = AList a s []+ aReverse :: AList t a -> AList t a aReverse (AList a s xs) = AList a s $ reverse xs @@ -61,11 +71,44 @@  -------------------------------------------------------------------------------- -data ATuple t1 t2 a = ATuple a SrcSpan (t1 a) (t2 a)-    deriving (Eq, Show, Data, Typeable, Generic, Functor)+data ATuple t1 t2 a = ATuple+  { atupleAnno :: a+  , atupleSpan :: SrcSpan+  , atupleFst  :: t1 a+  , atupleSnd  :: t2 a+  } deriving stock (Eq, Show, Data, Generic, Functor)  instance FirstParameter (ATuple t1 t2 a) a instance SecondParameter (ATuple t1 t2 a) SrcSpan instance Spanned (ATuple t1 t2 a) instance (Out a, Out (t1 a), Out (t2 a)) => Out (ATuple t1 t2 a) instance (NFData a, NFData (t1 a), NFData (t2 a)) => NFData (ATuple t1 t2 a)++--------------------------------------------------------------------------------++{-++see issue #231++data AListX ext t a = AListX+  { alistxAnno :: a+  , alistxSpan :: SrcSpan+  , alistxList :: [t a]+  , alistxExt  :: ext+  } deriving stock (Eq, Show, Data, Generic)++instance Functor t => Functor (AListX ext t) where+  fmap f (AListX a s xs ext) = AListX (f a) s (map (fmap f) xs) ext++instance FirstParameter (AListX ext t a) a+instance SecondParameter (AListX ext t a) SrcSpan+instance Annotated (AListX ext t)+instance Spanned (AListX ext t a)+instance (Out a, Out (t a), Out ext) => Out (AListX ext t a)+instance (NFData a, NFData (t a), NFData ext) => NFData (AListX ext t a)++data Brackets = Brackets | OmitBrackets+    deriving stock    (Eq, Show, Data, Generic)+    deriving anyclass (NFData, Out)++-}

@@ -0,0 +1,18 @@+{-# LANGUAGE DefaultSignatures #-}++module Language.Fortran.AST.Annotated where++import Language.Fortran.Util.FirstParameter++-- Retrieving SrcSpan and Annotation from nodes+class Annotated f where+  getAnnotation :: f a -> a+  setAnnotation :: a -> f a -> f a+  modifyAnnotation :: (a -> a) -> f a -> f a+  default getAnnotation :: (FirstParameter (f a) a) => f a -> a+  getAnnotation = getFirstParameter++  default setAnnotation :: (FirstParameter (f a) a) => a -> f a -> f a+  setAnnotation = setFirstParameter++  modifyAnnotation f x = setAnnotation (f (getAnnotation x)) x

@@ -1,97 +0,0 @@-{- | Supporting code for handling Fortran BOZ literal constants.--Using the definition from the latest Fortran standards (F2003, F2008), BOZ-constants are bitstrings (untyped!) which have basically no implicit rules. How-they're interpreted depends on context (they are generally limited to DATA-statements and a small handful of intrinsic functions).--Note that currently, we don't store BOZ constants as bitstrings. Storing them in-their string representation is easy and in that form, they're easy to safely-resolve to an integer. An alternate option would be to store them as the-bitstring "B" of BOZ, and only implement functions on that. For simple uses-(integer), I'm doubtful that would provide extra utility or performance, but it-may be more sensible in the future. For now, you may retrieve a bitstring by-converting to a numeric type and using something like 'showIntAtBase', or a-'Bits' instance.--}--module Language.Fortran.AST.Boz where--import           GHC.Generics-import           Data.Data-import           Control.DeepSeq                ( NFData )-import           Text.PrettyPrint.GenericPretty ( Out )--import qualified Data.List as List-import qualified Data.Char as Char-import qualified Numeric   as Num---- | A Fortran BOZ literal constant.------ The prefix defines the characters allowed in the string:------   * @B@: @[01]@---   * @O@: @[0-7]@---   * @Z@: @[0-9 a-f A-F]@-data Boz = Boz-  { bozPrefix :: BozPrefix-  , bozString :: String-  } deriving stock    (Eq, Show, Generic, Data, Typeable, Ord)-    deriving anyclass (NFData, Out)--data BozPrefix-  = BozPrefixB  -- ^ binary (bitstring)-  | BozPrefixO  -- ^ octal-  | BozPrefixZ  -- ^ hex (also with prefix @x@)-    deriving stock    (Eq, Show, Generic, Data, Typeable, Ord)-    deriving anyclass (NFData, Out)---- | UNSAFE. Parses a BOZ literal constant string.------ Looks for prefix or suffix. Strips the quotes from the string (single quotes--- only).-parseBoz :: String -> Boz-parseBoz s =-    case List.uncons s of-      Nothing -> errInvalid-      Just (pc, ps) -> case parsePrefix pc of-                         Just p -> Boz p (shave ps)-                         Nothing -> case parsePrefix (List.last s) of-                                      Just p -> Boz p (shave (init s))-                                      Nothing -> errInvalid-  where-    parsePrefix p-      | p' == 'b'            = Just BozPrefixB-      | p' == 'o'            = Just BozPrefixO-      | p' `elem` ['z', 'x'] = Just BozPrefixZ-      | otherwise            = Nothing-      where p' = Char.toLower p-    errInvalid = error "Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string"-    -- | Remove the first and last elements in a list.-    shave = tail . init---- | Pretty print a BOZ constant. Uses prefix style, and @z@ over nonstandard---   @x@ for hexadecimal.-prettyBoz :: Boz -> String-prettyBoz b = prettyBozPrefix (bozPrefix b) : '\'' : bozString b <> "'"-  where prettyBozPrefix = \case BozPrefixB -> 'b'-                                BozPrefixO -> 'o'-                                BozPrefixZ -> 'z'---- | Resolve a BOZ constant as a natural (positive integer).------ Is actually polymorphic over the output type, but you probably want to--- resolve to 'Integer' or 'Natural' usually.------ We assume the 'Boz' is well-formed, thus don't bother with digit predicates.-bozAsNatural :: (Num a, Eq a) => Boz -> a-bozAsNatural (Boz pfx str) = runReadS $ parser str-  where-    runReadS = fst . head-    parser = case pfx of BozPrefixB -> Num.readInt 2 (const True) binDigitVal-                         -- (on GHC >=9.2, 'Num.readBin')-                         BozPrefixO -> Num.readOct-                         BozPrefixZ -> Num.readHex-    binDigitVal = \case '0' -> 0-                        '1' -> 1-                        _   -> error "Language.Fortran.AST.BOZ.bozAsNatural: invalid BOZ string"

@@ -0,0 +1,3 @@+module Language.Fortran.AST.Common where++type Name = String

@@ -0,0 +1,23 @@+module Language.Fortran.AST.Literal where++import Language.Fortran.AST.Common ( Name )+import Language.Fortran.Util.Position ( SrcSpan, Spanned )+import Language.Fortran.Util.FirstParameter  ( FirstParameter )+import Language.Fortran.Util.SecondParameter ( SecondParameter )+import Language.Fortran.AST.Annotated ( Annotated )++import GHC.Generics                   ( Generic )+import Data.Data                      ( Data, Typeable )+import Control.DeepSeq                ( NFData )+import Text.PrettyPrint.GenericPretty ( Out )++data KindParam a+  = KindParamInt a SrcSpan String -- ^ @[0-9]+@+  | KindParamVar a SrcSpan Name   -- ^ @[a-z][a-z0-9]+@ (case insensitive)+    deriving stock    (Eq, Show, Data, Typeable, Generic, Functor)+    deriving anyclass (NFData, Out)++instance FirstParameter  (KindParam a) a+instance Annotated       KindParam+instance SecondParameter (KindParam a) SrcSpan+instance Spanned         (KindParam a)

@@ -0,0 +1,139 @@+{- | Supporting code for handling Fortran BOZ literal constants.++Using the definition from the latest Fortran standards (F2003, F2008), BOZ+constants are bitstrings (untyped!) which have basically no implicit rules. How+they're interpreted depends on context (they are generally limited to DATA+statements and a small handful of intrinsic functions).++Note that currently, we don't store BOZ constants as bitstrings. Storing them in+their string representation is easy and in that form, they're easy to safely+resolve to an integer. An alternate option would be to store them as the+bitstring "B" of BOZ, and only implement functions on that. For simple uses+(integer), I'm doubtful that would provide extra utility or performance, but it+may be more sensible in the future. For now, you may retrieve a bitstring by+converting to a numeric type and using something like 'showIntAtBase', or a+'Bits' instance.++This type carries _some_ syntactic information that doesn't change meaning. The+expectation is that most users won't want to inspect 'Boz' values, usually just+convert them, so we do it for convenience for checking syntax conformance. Note+that not all info is retained -- which of single or double quotes were used is+not recorded, for example.+-}++module Language.Fortran.AST.Literal.Boz where++import           GHC.Generics+import           Data.Data+import           Control.DeepSeq                ( NFData )+import           Text.PrettyPrint.GenericPretty ( Out )++import qualified Data.List as List+import qualified Data.Char as Char+import qualified Numeric   as Num++import           Data.Bits++-- | A Fortran BOZ literal constant.+--+-- The prefix defines the characters allowed in the string:+--+--   * @B@: @[01]@+--   * @O@: @[0-7]@+--   * @Z@: @[0-9 a-f A-F]@+data Boz = Boz+  { bozPrefix :: BozPrefix+  , bozString :: String++  , bozPrefixWasPostfix :: Conforming+  -- ^ Was the prefix actually postfix i.e. @'123'z@? This is non-standard+  --   syntax, disabled by default in gfortran. Syntactic info.+  } deriving stock    (Show, Generic, Data, Typeable, Ord)+    deriving anyclass (NFData, Out)++-- | Tests prefix & strings match, ignoring conforming/nonconforming flags.+instance Eq Boz where+    b1 == b2 =     bozPrefix b1 == bozPrefix b2+                && bozString b1 == bozString b2++data BozPrefix+  = BozPrefixB              -- ^ binary (bitstring)+  | BozPrefixO              -- ^ octal+  | BozPrefixZ Conforming   -- ^ hex, including nonstandard @x@+    deriving stock    (Show, Generic, Data, Typeable, Ord)+    deriving anyclass (NFData, Out)++-- | Ignores conforming/nonconforming flags.+instance Eq BozPrefix where+    p1 == p2 = case (p1, p2) of (BozPrefixB,   BozPrefixB)   -> True+                                (BozPrefixO,   BozPrefixO)   -> True+                                (BozPrefixZ{}, BozPrefixZ{}) -> True+                                _                            -> False++data Conforming = Conforming | Nonconforming+    deriving stock    (Eq, Show, Generic, Data, Typeable, Ord)+    deriving anyclass (NFData, Out)++-- | UNSAFE. Parses a BOZ literal constant string.+--+-- Looks for prefix or postfix. Strips the quotes from the string (single quotes+-- only).+parseBoz :: String -> Boz+parseBoz s =+    case List.uncons s of+      Nothing -> errInvalid+      Just (pc, ps) -> case parsePrefix pc of+                         Just p -> Boz p (shave ps) Conforming+                         Nothing -> case parsePrefix (List.last s) of+                                      Just p -> Boz p (shave (init s)) Nonconforming+                                      Nothing -> errInvalid+  where+    parsePrefix p+      | p' == 'b' = Just $ BozPrefixB+      | p' == 'o' = Just $ BozPrefixO+      | p' == 'z' = Just $ BozPrefixZ Conforming+      | p' == 'x' = Just $ BozPrefixZ Nonconforming+      | otherwise = Nothing+      where p' = Char.toLower p+    errInvalid = error "Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string"+    -- | Remove the first and last elements in a list.+    shave = tail . init++-- | Pretty print a BOZ constant. Uses prefix style (ignores the postfix field),+--   and @z@ over nonstandard @x@ for hexadecimal.+prettyBoz :: Boz -> String+prettyBoz b = prettyBozPrefix (bozPrefix b) : '\'' : bozString b <> "'"+  where prettyBozPrefix = \case BozPrefixB   -> 'b'+                                BozPrefixO   -> 'o'+                                BozPrefixZ{} -> 'z'++-- | Resolve a BOZ constant as a natural (positive integer).+--+-- Is actually polymorphic over the output type, but you probably want to+-- resolve to 'Integer' or 'Natural' usually.+--+-- We assume the 'Boz' is well-formed, thus don't bother with digit predicates.+bozAsNatural :: (Num a, Eq a) => Boz -> a+bozAsNatural (Boz pfx str _) = runReadS $ parser str+  where+    runReadS = fst . head+    parser = case pfx of BozPrefixB   -> Num.readInt 2 (const True) binDigitVal+                         -- (on GHC >=9.2, 'Num.readBin')+                         BozPrefixO   -> Num.readOct+                         BozPrefixZ{} -> Num.readHex+    binDigitVal = \case '0' -> 0+                        '1' -> 1+                        _   -> error "Language.Fortran.AST.BOZ.bozAsNatural: invalid BOZ string"++-- | Resolve a BOZ constant as a two's complement integer.+--+-- Note that the value will depend on the size of the output type.+bozAsTwosComp :: (Num a, Eq a, FiniteBits a) => Boz -> a+bozAsTwosComp boz =+    if   msbIsSet+    then asNat - (2 ^ bitCount)+    else asNat+  where+    msbIsSet = testBit asNat (bitCount - 1)+    asNat    = bozAsNatural boz+    bitCount = finiteBitSize asNat

@@ -0,0 +1,60 @@+-- | Supporting definitions for COMPLEX literals.++module Language.Fortran.AST.Literal.Complex where++import Language.Fortran.AST.Common ( Name )+import Language.Fortran.AST.Literal ( KindParam )+import Language.Fortran.AST.Literal.Real+import Language.Fortran.Util.Position ( SrcSpan, Spanned )++import GHC.Generics                   ( Generic )+import Data.Data                      ( Data, Typeable )+import Control.DeepSeq                ( NFData )+import Text.PrettyPrint.GenericPretty ( Out )+import Language.Fortran.Util.FirstParameter  ( FirstParameter )+import Language.Fortran.Util.SecondParameter ( SecondParameter )+import Language.Fortran.AST.Annotated ( Annotated )++-- | A COMPLEX literal, composed of a real part and an imaginary part.+--+-- Fortran has lots of rules on how COMPLEX literals are defined and used in+-- various contexts. To support all that, we define the syntactic structure+-- 'ComplexLit' to wrap all the parsing rules. Then during a analysis pass, you+-- may (attempt to) convert these into a more regular type, like a Haskell+-- @(Double, Double)@ tuple.+data ComplexLit a = ComplexLit+  { complexLitAnno     :: a+  , complexLitPos      :: SrcSpan+  , complexLitRealPart :: ComplexPart a+  , complexLitImagPart :: ComplexPart a+  } deriving stock    (Eq, Show, Data, Typeable, Generic, Functor)+    deriving anyclass (NFData, Out)++instance FirstParameter  (ComplexLit a) a+instance Annotated       ComplexLit+instance SecondParameter (ComplexLit a) SrcSpan+instance Spanned         (ComplexLit a)++-- | A part (either real or imaginary) of a complex literal.+--+-- Since Fortran 2003, complex literal parts support named constants, which must+-- be resolved in context at compile time (R422, R423).+--+-- Some compilers also allow constant expressions for the parts, and must+-- evaluate at compile time. That's not allowed in any standard. Apparently,+-- gfortran and ifort don't allow it, while nvfortran does. See:+-- https://fortran-lang.discourse.group/t/complex-constants-and-variables/2909/3+--+-- We specifically avoid supporting that by defining complex parts without being+-- mutually recursive with 'Expression'.+data ComplexPart a+  = ComplexPartReal   a SrcSpan RealLit (Maybe (KindParam a)) -- ^ signed real lit+  | ComplexPartInt    a SrcSpan String  (Maybe (KindParam a)) -- ^ signed int  lit+  | ComplexPartNamed  a SrcSpan Name                          -- ^ named constant+    deriving stock    (Eq, Show, Data, Typeable, Generic, Functor)+    deriving anyclass (NFData, Out)++instance FirstParameter  (ComplexPart a) a+instance Annotated       ComplexPart+instance SecondParameter (ComplexPart a) SrcSpan+instance Spanned         (ComplexPart a)

@@ -0,0 +1,97 @@+{- |+Supporting code for handling Fortran REAL literals.++Fortran REAL literals have some idiosyncrasies that prevent them from lining up+with Haskell's reals immediately. So, we parse into an intermediate data type+that can be easily exported with full precision later. Things we do:++  * Strip explicit positive signs so that signed values either begin with the+    minus sign @-@ or no sign. ('Read' doesn't allow explicit positive signs.)+  * Make exponent explicit by adding the default exponent @E0@ if not present.+  * Make implicit zeroes explicit. @.123 -> 0.123@, @123. -> 123.0@. (Again,+    Haskell literals do not support this.)++For example, the Fortran REAL literal @1D0@ will be parsed into @1.0D0@.+-}++{-# LANGUAGE RecordWildCards #-}++module Language.Fortran.AST.Literal.Real where++import qualified Data.Char as Char+import           GHC.Generics+import           Data.Data+import           Control.DeepSeq                ( NFData )+import           Text.PrettyPrint.GenericPretty ( Out )++-- | A Fortran real literal. (Does not include the optional kind parameter.)+--+-- A real literal is formed of a signed rational significand, and an 'Exponent'.+--+-- See F90 ISO spec pg.27 / R412-416.+--+-- Note that we support signed real literals, even though the F90 spec indicates+-- non-signed real literals are the "default" (signed are only used in a "spare"+-- rule). Our parsers should parse explicit signs as unary operators. There's no+-- harm in supporting signed literals though, especially since the exponent *is*+-- signed.+data RealLit = RealLit+  { realLitSignificand :: String+  -- ^ A string representing a signed decimal.+  -- ^ Approximate regex: @-? ( [0-9]+ \. [0-9]* | \. [0-9]+ )@+  , realLitExponent    :: Exponent+  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- | An exponent is an exponent letter (E, D) and a signed integer.+data Exponent = Exponent+  { exponentLetter :: ExponentLetter+  , exponentNum    :: String+  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- Note: Some Fortran language references include extensions here. HP's F90+-- reference provides a Q exponent letter which sets kind to 16.+data ExponentLetter+  = ExpLetterE -- ^ KIND=4 (float)+  | ExpLetterD -- ^ KIND=8 (double)+  | ExpLetterQ -- ^ KIND=16 ("quad", rare? extension)+    deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- | Prettify a 'RealLit' in a Haskell-compatible way.+prettyHsRealLit :: RealLit -> String+prettyHsRealLit r = realLitSignificand r <> "e" <> exponentNum (realLitExponent r)++readRealLit :: (Fractional a, Read a) => RealLit -> a+readRealLit = read . prettyHsRealLit++-- UNSAFE. Expects a valid Fortran REAL literal.+parseRealLit :: String -> RealLit+parseRealLit r =+    let (significandStr, exponentStr) = span isSignificand r+        realLitExponent = parseExponent exponentStr+        realLitSignificand = normalizeSignificand (stripPositiveSign significandStr)+     in RealLit{..}+  where+    -- | Ensure that the given decimal string is in form @x.y@.+    normalizeSignificand str = case span (/= '.') str of+                                 ([], d)  -> '0':d   --    .456+                                 (i, ".") -> i<>".0" -- 123.+                                 (i, "")  -> i<>".0" -- 123+                                 _        -> str     -- 123.456+    parseExponent "" = Exponent { exponentLetter = ExpLetterE, exponentNum = "0" }+    parseExponent (l:str) =+        let exponentLetter = parseExponentLetter l+            exponentNum = stripPositiveSign str+         in Exponent{..}+    stripPositiveSign = \case+      []  -> []+      c:s -> case c of+               '+' ->   s+               _   -> c:s+    isSignificand ch | Char.isDigit ch                 = True+                     | ch `elem` ['.', '-', '+']  = True+                     | otherwise                  = False+    parseExponentLetter ch = case Char.toLower ch of+                               'e' -> ExpLetterE+                               'd' -> ExpLetterD+                               'q' -> ExpLetterQ+                               _   -> error $ "Language.Fortran.AST.Literal.Real.parseRealLit: invalid exponent letter: " <> [ch]

@@ -1,95 +0,0 @@-{- |-Supporting code for handling Fortran REAL literals.--Fortran REAL literals have some idiosyncrasies that prevent them from lining up-with Haskell's reals immediately. So, we parse into an intermediate data type-that can be easily exported with full precision later. Things we do:--  * Strip explicit positive signs so that signed values either begin with the-    minus sign @-@ or no sign. ('Read' doesn't allow explicit positive signs.)-  * Make exponent explicit by adding the default exponent @E0@ if not present.-  * Make implicit zeroes explicit. @.123 -> 0.123@, @123. -> 123.0@. (Again,-    Haskell literals do not support this.)--}--{-# LANGUAGE RecordWildCards #-}--module Language.Fortran.AST.RealLit where--import qualified Data.Char as Char-import           GHC.Generics-import           Data.Data-import           Control.DeepSeq                ( NFData )-import           Text.PrettyPrint.GenericPretty ( Out )---- | A Fortran real literal. (Does not include the optional kind parameter.)------ A real literal is formed of a signed rational significand, and an 'Exponent'.------ See F90 ISO spec pg.27 / R412-416.------ Note that we support signed real literals, even though the F90 spec indicates--- non-signed real literals are the "default" (signed are only used in a "spare"--- rule). Our parsers should parse explicit signs as unary operators. There's no--- harm in supporting signed literals though, especially since the exponent *is*--- signed.-data RealLit = RealLit-  { realLitSignificand :: String-  -- ^ A string representing a signed decimal.-  -- ^ Approximate regex: @-? ( [0-9]+ \. [0-9]* | \. [0-9]+ )@-  , realLitExponent    :: Exponent-  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)---- | An exponent is an exponent letter (E, D) and a signed integer.-data Exponent = Exponent-  { exponentLetter :: ExponentLetter-  , exponentNum    :: String-  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)---- Note: Some Fortran language references include extensions here. HP's F90--- reference provides a Q exponent letter which sets kind to 16.-data ExponentLetter-  = ExpLetterE -- ^ KIND=4 (float)-  | ExpLetterD -- ^ KIND=8 (double)-  | ExpLetterQ -- ^ KIND=16 ("quad", rare? extension)-    deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)---- | Prettify a 'RealLit' in a Haskell-compatible way.-prettyHsRealLit :: RealLit -> String-prettyHsRealLit r = realLitSignificand r <> "e" <> exponentNum (realLitExponent r)--readRealLit :: (Fractional a, Read a) => RealLit -> a-readRealLit = read . prettyHsRealLit---- UNSAFE. Expects a valid Fortran REAL literal.-parseRealLit :: String -> RealLit-parseRealLit r =-    let (significandStr, exponentStr) = span isSignificand r-        realLitExponent = parseExponent exponentStr-        realLitSignificand = normalizeSignificand (stripPositiveSign significandStr)-     in RealLit{..}-  where-    -- | Ensure that the given decimal string is in form @x.y@.-    normalizeSignificand str = case span (/= '.') str of-                                 ([], d)  -> '0':d   --    .456-                                 (i, ".") -> i<>".0" -- 123.-                                 (i, "")  -> i<>".0" -- 123-                                 _        -> str     -- 123.456-    parseExponent "" = Exponent { exponentLetter = ExpLetterE, exponentNum = "0" }-    parseExponent (l:str) =-        let exponentLetter = parseExponentLetter l-            exponentNum = stripPositiveSign str-         in Exponent{..}-    stripPositiveSign = \case-      []  -> []-      c:s -> case c of-               '+' ->   s-               _   -> c:s-    isSignificand ch | Char.isDigit ch                 = True-                     | ch `elem` ['.', '-', '+']  = True-                     | otherwise                  = False-    parseExponentLetter ch = case Char.toLower ch of-                               'e' -> ExpLetterE-                               'd' -> ExpLetterD-                               'q' -> ExpLetterQ-                               _   -> error $ "Language.Fortran.AST.RealLit.parseRealLit: invalid exponent letter: " <> [ch]

@@ -239,14 +239,14 @@   where     lhsOfStmt :: Statement a -> [Expression a]     lhsOfStmt (StExpressionAssign _ _ e e') = e : onExprs e'-    lhsOfStmt (StCall _ _ _ (Just aexps)) = filter isLExpr argExps ++ concatMap onExprs argExps+    lhsOfStmt (StCall _ _ _ aexps) = filter isLExpr argExps ++ concatMap onExprs argExps        where argExps = map argExtractExpr . aStrip $ aexps     lhsOfStmt s =  onExprs s      onExprs :: (Data a, Data (c a)) => c a -> [Expression a]     onExprs = concatMap lhsOfExp . universeBi     lhsOfExp :: Expression a -> [Expression a]-    lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = fstLvl aexps+    lhsOfExp (ExpFunctionCall _ _ _ aexps) = fstLvl aexps     lhsOfExp _ = []      fstLvl = filter isLExpr . map argExtractExpr . aStrip@@ -297,7 +297,7 @@     lhsOfStmt (StDeclaration _ _ _ _ decls) = concat [ lhsOfDecls decl | decl <- universeBi decls ]     lhsOfStmt (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)       | Just defs <- intrinsicDefs f = defs-    lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . argExtractExpr) (aStrip aexps)+    lhsOfStmt (StCall _ _ _ aexps) = concatMap (match'' . argExtractExpr) (aStrip aexps)     lhsOfStmt s = onExprs s      lhsOfDecls (Declarator _ _ e _ _ (Just e')) = match' e : onExprs e'@@ -307,7 +307,7 @@     onExprs = concatMap lhsOfExp . universeBi      lhsOfExp :: Expression (Analysis a) -> [Name]-    lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = concatMap (match . argExtractExpr) (aStrip aexps)+    lhsOfExp (ExpFunctionCall _ _ _ aexps) = concatMap (match . argExtractExpr) (aStrip aexps)     lhsOfExp _ = []      -- Match and give the varname for LHS of statement@@ -366,9 +366,10 @@     rhsOfDecls _ = [] blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))   | Just uses <- intrinsicUses f = uses-blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps+blockVarUses (BlStatement _ _ _ (StCall _ _ _ aexps)) = allVars aexps blockVarUses (BlDoWhile _ _ e1 _ _ e2 _ _) = maybe [] allVars e1 ++ allVars e2-blockVarUses (BlIf _ _ e1 _ e2 _ _)        = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2+blockVarUses (BlIf _ _ eLabel _ clauses _ _) =+    maybe [] allVars eLabel ++ concatMap allVars (fmap fst clauses) blockVarUses b                             = allVars b  -- | Set of names defined by an AST-block.

@@ -15,16 +15,19 @@ import Control.Monad.State.Lazy hiding (fix) import Control.Monad.Writer hiding (fix) import Text.PrettyPrint.GenericPretty (pretty, Out)+import Text.PrettyPrint               (render) import Language.Fortran.Analysis import Language.Fortran.AST hiding (setName)-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real import Language.Fortran.Util.Position+import Language.Fortran.PrettyPrint import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Graph.Inductive import Data.List (intercalate) import Data.Maybe import Data.Functor.Identity+import qualified Data.List.NonEmpty as NE  -------------------------------------------------- @@ -93,16 +96,20 @@     perBlock' b =       case b of         BlStatement a s e st               -> BlStatement a s (mfill i e) (fill i st)-        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+        BlIf        a s e1 mn bs mb el  ->+          BlIf      a s (mfill i e1) mn (fmap (fillIf i) bs) mb el+        BlCase      a s e1 mn e2 bs mb el ->+          BlCase    a s (mfill i e1) mn (fill i e2) (fmap (fillCaseClause i) bs) mb 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 tl e2 bs el   -> BlDoWhile   a s (mfill i e1) n tl (fill i e2) bs el         _                             -> b       where i = insLabel $ getAnnotation b      mfill i  = fmap (fill i)-    mmfill i = fmap (fmap (fill i)) +    fillCaseClause i (rs, b) = (fill i rs, b)+    fillIf i (e, b) = (fill i e, b)+     fill :: forall f. (Data (f (Analysis a))) => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)     fill Nothing  = id     fill (Just i) = transform perIndex@@ -343,17 +350,22 @@  -------------------------------------------------- +msnoc :: Maybe a -> [a] -> [a]+msnoc Nothing  xs = xs+msnoc (Just x) xs = xs <> [x]+ -- Handle an AST-block element perBlock :: Data a => Block (Analysis a) -> BBlocker (Analysis a) () -- invariant: curNode corresponds to curBB, and is not yet in the graph -- invariant: curBB is in reverse order-perBlock b@(BlIf _ _ _ _ exps bss _) = do+perBlock b@(BlIf _ _ _ _ clauses elseBlock _) = do   processLabel b-  _ <- forM (catMaybes . filter isJust $ exps) processFunctionCalls+  _ <- forM (fmap fst clauses) processFunctionCalls   addToBBlock $ stripNestedBlocks b   (ifN, _) <- closeBBlock    -- go through nested AST-blocks+  let bss = msnoc elseBlock $ map snd $ NE.toList clauses   startEnds <- forM bss $ \ bs -> do     (thenN, endN) <- processBlocks bs     _ <- genBBlock@@ -363,14 +375,16 @@   nxtN   <- gets curNode   let es  = startEnds >>= \ (thenN, endN) -> [(ifN, thenN, ()), (endN, nxtN, ())]   -- if there is no "Else"-statement then we need an edge from ifN -> nxtN-  createEdges $ if any isNothing exps then es else (ifN, nxtN, ()):es+  createEdges $ case elseBlock of Nothing -> (ifN, nxtN, ()):es -- es+                                  Just{}  -> es -perBlock b@(BlCase _ _ _ _ _ inds bss _) = do+perBlock b@(BlCase _ _ _ _ _ clauses defCase _) = do   processLabel b   addToBBlock $ stripNestedBlocks b   (selectN, _) <- closeBBlock    -- go through nested AST-blocks+  let bss = msnoc defCase $ map snd clauses   startEnds <- forM bss $ \ bs -> do     (caseN, endN) <- processBlocks bs     _ <- genBBlock@@ -380,7 +394,8 @@   nxtN   <- gets curNode   let es  = startEnds >>= \ (caseN, endN) -> [(selectN, caseN, ()), (endN, nxtN, ())]   -- if there is no "CASE DEFAULT"-statement then we need an edge from selectN -> nxtN-  createEdges $ if any isNothing inds then es else (selectN, nxtN, ()):es+  createEdges $ case defCase of Nothing -> (selectN, nxtN, ()):es+                                Just{}  -> es  perBlock b@(BlStatement _ _ _ (StGotoComputed _ _ _ exp)) = do   processLabel b@@ -420,53 +435,55 @@   processLabel b >> addToBBlock b >> closeBBlock_ perBlock b@(BlStatement _ _ _ StGotoUnconditional{}) =   processLabel b >> addToBBlock b >> closeBBlock_-perBlock b@(BlStatement _ _ _ (StCall _ _ ExpValue{} Nothing)) = do-  (prevN, callN) <- closeBBlock-  -- put StCall in a bblock by itself-  addToBBlock b-  (_, nextN) <- closeBBlock-  createEdges [ (prevN, callN, ()), (callN, nextN, ()) ]-perBlock (BlStatement a s l (StCall a' s' cn@ExpValue{} (Just aargs))) = do-  let a0 = head . initAnalysis $ [prevAnnotation a]-  let exps = map argExtractExpr . aStrip $ aargs-  (prevN, formalN) <- closeBBlock+perBlock b'@(BlStatement a s l (StCall a' s' cn@ExpValue{} aargs)) = do+    case aStrip aargs of+      []  -> do+        (prevN, callN) <- closeBBlock+        -- put StCall in a bblock by itself+        addToBBlock b'+        (_, nextN) <- closeBBlock+        createEdges [ (prevN, callN, ()), (callN, nextN, ()) ]+      _:_ -> do+        let a0 = head . initAnalysis $ [prevAnnotation a]+        let exps = map argExtractExpr . aStrip $ aargs+        (prevN, formalN) <- closeBBlock -  -- create bblock that assigns formal parameters (n[1], n[2], ...)-  case l of-    Just (ExpValue _ _ (ValInteger l' _)) -> insertLabel l' formalN -- label goes here, if present-    _                                   -> return ()-  let name i   = varName cn ++ "[" ++ show i ++ "]"-  let formal (ExpValue a'' s'' (ValVariable _)) i = genVar a''{ insLabel = Nothing } s'' (name i)-      formal e i                                  = genVar a''{ insLabel = Nothing } s'' (name i)-        where a'' = getAnnotation e; s'' = getSpan e-  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> do-    e' <- processFunctionCalls e -- may generate additional bblocks-    let b = BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' (formal e' i) e')-    addToBBlock $ analyseAllLhsVars1 b+        -- create bblock that assigns formal parameters (n[1], n[2], ...)+        case l of+          Just (ExpValue _ _ (ValInteger l' _)) -> insertLabel l' formalN -- label goes here, if present+          _                                   -> return ()+        let name i   = varName cn ++ "[" ++ show i ++ "]"+        let formal (ExpValue a'' s'' (ValVariable _)) i = genVar a''{ insLabel = Nothing } s'' (name i)+            formal e i                                  = genVar a''{ insLabel = Nothing } s'' (name i)+              where a'' = getAnnotation e; s'' = getSpan e+        forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> do+          e' <- processFunctionCalls e -- may generate additional bblocks+          let b = BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' (formal e' i) e')+          addToBBlock $ analyseAllLhsVars1 b -  (formalN', dummyCallN) <- closeBBlock-  -- formalN' may differ from formalN when additional bblocks were-  -- generated by processFunctionCalls.+        (formalN', dummyCallN) <- closeBBlock+        -- formalN' may differ from formalN when additional bblocks were+        -- generated by processFunctionCalls. -  let dummyArgs = map (\e -> Argument a0 s' Nothing (ArgExpr e))-                      (zipWith formal exps [(1::Integer)..])+        let dummyArgs = map (\e -> Argument a0 s' Nothing (ArgExpr e))+                            (zipWith formal exps [(1::Integer)..]) -  -- create "dummy call" bblock with dummy parameters in the StCall AST-node.-  addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' cn (Just $ fromList a0 dummyArgs))-  (_, returnedN) <- closeBBlock+        -- create "dummy call" bblock with dummy parameters in the StCall AST-node.+        addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' cn (fromList a0 dummyArgs))+        (_, returnedN) <- closeBBlock -  -- re-assign the variables using the values of the formal parameters, if possible-  -- (because call-by-reference)-  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) ->-    -- this is only possible for l-expressions-    (when (isLExpr e) $-      addToBBlock . analyseAllLhsVars1 $-        BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' e (formal e i)))-  (_, nextN) <- closeBBlock+        -- re-assign the variables using the values of the formal parameters, if possible+        -- (because call-by-reference)+        forM_ (zip exps [(1::Integer)..]) $ \ (e, i) ->+          -- this is only possible for l-expressions+          (when (isLExpr e) $+            addToBBlock . analyseAllLhsVars1 $+              BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' e (formal e i)))+        (_, nextN) <- closeBBlock -  -- connect the bblocks-  createEdges [ (prevN, formalN, ()), (formalN', dummyCallN, ())-              , (dummyCallN, returnedN, ()), (returnedN, nextN, ()) ]+        -- connect the bblocks+        createEdges [ (prevN, formalN, ()), (formalN', dummyCallN, ())+                    , (dummyCallN, returnedN, ()), (returnedN, nextN, ()) ]  perBlock b@(BlStatement _ _ _ (StRead _ _ cs _)) = do   let (end, err) = getReadCtrlXfers $ aStrip cs@@ -559,8 +576,10 @@ stripNestedBlocks :: Block a -> Block a stripNestedBlocks (BlDo a s l mn tl ds _ el)     = BlDo a s l mn tl ds [] 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 (BlIf a s l mn clauses elseBlock el) =+    BlIf a s l mn (fmap (\(e, _bs) -> (e, [])) clauses) (fmap (const []) elseBlock) el+stripNestedBlocks (BlCase a s l mn sc clauses caseDef el) =+    BlCase a s l mn sc (fmap (\(r, _bs) -> (r, [])) clauses) (fmap (const []) caseDef) el stripNestedBlocks b                              = b  -- Flatten out function calls within the expression, returning an@@ -576,7 +595,7 @@   let a0 = head . initAnalysis $ [prevAnnotation a]   (prevN, formalN) <- closeBBlock -  let exps = map argExtractExpr (fromMaybe [] (aStrip <$> aargs))+  let exps = map argExtractExpr $ aStrip aargs    -- create bblock that assigns formal parameters (fn[1], fn[2], ...)   let name i   = varName fn ++ "[" ++ show i ++ "]"@@ -592,7 +611,7 @@                       (retV:zipWith formal exps [(1::Integer)..])    -- create "dummy call" bblock with dummy arguments in the StCall AST-node.-  addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' fn (Just $ fromList a0 dummyArgs))+  addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' fn (fromList a0 dummyArgs))   (_, returnedN) <- closeBBlock    -- re-assign the variables using the values of the formal parameters, if possible@@ -783,7 +802,8 @@         StDimension _ _ adecls       -> "dimension " ++ aIntercalate ", " showDecl adecls         StExit{}                     -> "exit"         _                            -> "<unhandled statement: " ++ show (toConstr (fmap (const ()) st)) ++ ">"-showBlock (BlIf _ _ mlab _ (Just e1:_) _ _) = showLab mlab ++ "if " ++ showExpr e1 ++ "\\l"+showBlock (BlIf _ _ mlab _ ((e1, _) :| _) _ _) =+    showLab mlab ++ "if " ++ showExpr e1 ++ "\\l" showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) =     showLab mlab ++ "do " ++ showExpr e1 ++ " <- " ++       showExpr e2 ++ ", " ++@@ -824,12 +844,12 @@     Just (ExpValue _ _ (ValInteger l _)) -> ' ':l ++ replicate (5 - length l) ' '     _ -> error "unhandled showLab" -showValue :: Value a -> Name+showValue :: Value a -> String showValue (ValVariable v)       = v showValue (ValIntrinsic v)      = v showValue (ValInteger v _)      = v showValue (ValReal v _)         = prettyHsRealLit v-showValue (ValComplex e1 e2)    = "( " ++ showExpr e1 ++ " , " ++ showExpr e2 ++ " )"+showValue v@ValComplex{}        = render $ pprint' undefined v showValue (ValString s)         = "\\\"" ++ escapeStr s ++ "\\\"" showValue v                     = "<unhandled value: " ++ show (toConstr (fmap (const ()) v)) ++ ">" 

@@ -33,7 +33,7 @@ import Language.Fortran.Analysis import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode) import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real import qualified Data.Map as M import qualified Data.IntMap.Lazy as IM import qualified Data.IntMap.Strict as IMS

@@ -7,7 +7,6 @@ import           Control.DeepSeq                ( NFData ) import           GHC.Generics                   ( Generic ) import           Language.Fortran.AST           ( BaseType(..)-                                                , Kind                                                 , Expression(..)                                                 , Value(..)                                                 , TypeSpec(..)@@ -18,6 +17,8 @@ import           Text.PrettyPrint.GenericPretty ( Out(..) ) import           Text.PrettyPrint               ( (<+>), parens ) import           Language.Fortran.PrettyPrint   ( Pretty(..) )++type Kind = Int  -- | Semantic type assigned to variables. --

@@ -15,7 +15,8 @@   ) where  import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Complex  import Prelude hiding (lookup, EQ, LT, GT) import Data.Map (insert)@@ -252,7 +253,10 @@ -- them in the first place? (iterate until fixed point?) statement (StFunction _ _ v _ _) = recordCType CTFunction (varName v) -- (part of answer to above is) nullary function statement: foo() = ...-statement (StExpressionAssign _ _ (ExpFunctionCall _ _ v Nothing) _) = recordCType CTFunction (varName v)+statement (StExpressionAssign _ _ (ExpFunctionCall _ _ v args) _) =+  case alistList args of+    []  -> recordCType CTFunction (varName v)+    _:_ -> pure ()  statement (StDimension _ _ declAList) = do   let decls = aStrip declAList@@ -273,9 +277,9 @@ annotateExpression e@(ExpValue _ ss (ValReal r mkp))        = do     k <- deriveRealLiteralKind ss r mkp     return $ setSemType (TReal k) e-annotateExpression e@(ExpValue _ ss (ValComplex e1 e2)) = do-    st <- complexLiteralType ss e1 e2-    return $ setSemType st e+annotateExpression e@(ExpValue _ _ (ValComplex (ComplexLit _a _ss _cr _ci))) = do+    -- TODO check F90 standard for complex lit typing rules (kind params)+    return e annotateExpression e@(ExpValue _ _ ValInteger{})     =     -- FIXME: in >F90, int lits can have kind info on end @_8@, same as real     -- lits. We do parse this into the lit string, it is available to us.@@ -297,14 +301,14 @@ -- -- Logic taken from HP's F90 reference pg.33, written to gfortran's behaviour. -- Stays in the 'Infer' monad so it can report type errors-deriveRealLiteralKind :: SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind+deriveRealLiteralKind :: SrcSpan -> RealLit -> Maybe (KindParam a) -> Infer Kind deriveRealLiteralKind ss r mkp =     case mkp of       Nothing -> case exponentLetter (realLitExponent r) of                    ExpLetterE -> return  4                    ExpLetterD -> return  8                    ExpLetterQ -> return 16-      Just _ {- kp -} -> case exponentLetter (realLitExponent r) of+      Just _kp -> case exponentLetter (realLitExponent r) of                    ExpLetterE -> return 0 -- TODO return k                    _          -> do                      -- badly formed literal, but we'll allow and use the@@ -313,15 +317,6 @@                              <> "can specify explicit kind parameter") ss                      return 0 -- TODO return k --- | Get the type of a COMPLEX literal constant.------ The kind is derived only from the first expression, the second is ignored.-complexLiteralType :: SrcSpan -> Expression a -> Expression a -> Infer SemType-complexLiteralType ss (ExpValue _ _ (ValReal r mkp)) _ = do-    k1 <- deriveRealLiteralKind ss r mkp-    return $ TComplex k1-complexLiteralType _ _ _ = return $ deriveSemTypeFromBaseType TypeComplex- binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType binaryOpType ss op e1 e2 = do   mst1 <- case getIDType e1 of@@ -411,8 +406,8 @@         else return ty     _ -> return emptyType -functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> Maybe (AList Argument (Analysis a)) -> Infer IDType-functionCallType ss (ExpValue _ _ (ValIntrinsic n)) (Just (AList _ _ params)) = do+functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Argument (Analysis a) -> Infer IDType+functionCallType ss (ExpValue _ _ (ValIntrinsic n)) (AList _ _ params) = do   itab <- gets intrinsics   let mRetType = getIntrinsicReturnType n itab   case mRetType of

@@ -36,6 +36,7 @@   -- * F77 with inlined includes   -- $f77includes   , f77lIncludes+  , f77lIncIncludes   ) where  import Language.Fortran.AST@@ -242,8 +243,7 @@     :: [FilePath] -> ModFiles -> String -> B.ByteString     -> IO (ProgramFile A0) f77lIncludes incs mods fn bs = do-    -- includes files have to end with 2 newlines (unknown why, parser related)-    case f77lNoTransform fn (B.snoc bs '\n') of+    case f77lNoTransform fn bs of       Left e -> liftIO $ throwIO e       Right pf -> do         let pf' = pfSetFilename fn pf@@ -253,6 +253,18 @@                                  (defaultTransformation Fortran77Legacy)                                  pf''         return pf'''++-- | Entry point for include files+-- +-- We can't perform full analysis (though it might be possible to do in future)+-- but the AST is enough for certain types of analysis/refactoring+f77lIncIncludes+  :: [FilePath] -> String -> B.ByteString -> IO [Block A0]+f77lIncIncludes incs fn bs =+  case makeParserFixed F77.includesParser Fortran77Legacy fn bs of+    Left e -> liftIO $ throwIO e+    Right bls ->+      evalStateT (descendBiM (f77lIncludesInline incs []) bls) Map.empty  f77lIncludesInner :: Parser [Block A0] f77lIncludesInner = makeParserFixed F77.includesParser Fortran77Legacy

@@ -11,10 +11,11 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.ParserUtils import Language.Fortran.Parser.Fixed.Lexer import Language.Fortran.Parser.Fixed.Utils import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real  import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST @@ -187,8 +188,10 @@ | 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-  { StCall () (getTransSpan $1 $3) $2 (Just $3) }-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }+  { StCall () (getTransSpan $1 $3) $2 $3 }+| call VARIABLE+  { StCall () (getTransSpan $1 $2) $2 (aEmpty () (emptySpan (ssTo (getSpan $2)))) }+  -- ^ (!) empty list 0-span | return { StReturn () (getSpan $1) Nothing } | continue { StContinue () $ getSpan $1 } | stop INTEGER_LITERAL { StStop () (getTransSpan $1 $2) $ Just $2 }@@ -380,7 +383,8 @@  SUBSCRIPT :: { Expression A0 } : VARIABLE '(' ')'-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+  { ExpFunctionCall () (getTransSpan $1 $3) $1 (aEmpty () (getTransSpan $2 $3)) }+  -- ^ (!) empty list spans brackets | VARIABLE '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } @@ -434,7 +438,8 @@ | SIGNED_REAL_LITERAL    { $1 }  COMPLEX_LITERAL :: { Expression A0 }-:  '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+: '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')'+  {% complexLit (getTransSpan $1 $5) $2 $4 }  LOGICAL_LITERAL :: { Expression A0 } : bool { let TBool s b = $1 in ExpValue () s $ ValLogical b Nothing }

@@ -12,13 +12,15 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.ParserUtils import Language.Fortran.Parser.Fixed.Lexer import Language.Fortran.Parser.Fixed.Utils import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real  import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Maybe ( isNothing, fromJust )+import qualified Data.List as List  } @@ -193,16 +195,16 @@ | maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }  PROGRAM_UNIT :: { ProgramUnit A0 }-: 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) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing }-| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN-  { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing }-| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB-  { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $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 BLOCKS NEWLINE ENDPROG+  { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $3) Nothing }+| TYPE_SPEC function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN+  { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $5) Nothing }+| function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN+  { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $4) Nothing }+| subroutine NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDSUB+  { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $4) Nothing }+| blockData BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $2) }+| blockData NAME BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $3) } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) }  END :: { Token }@@ -235,38 +237,35 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name }  INCLUDES :: { [ Block A0 ] }-: maybe(NEWLINE) list(BLOCK) { $2 }+: BLOCKS maybe(NEWLINE) { $1 }  BLOCKS :: { [ Block A0 ] }-: BLOCKS BLOCK { $2 : $1 }+: BLOCKS NEWLINE BLOCK { $3 : $1 }+| BLOCK { [ $1 ] } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-: IF_BLOCK NEWLINE { $1 }-| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }-| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }-| COMMENT_BLOCK { $1 }+: IF_BLOCK { $1 }+| LABEL_IN_6COLUMN STATEMENT { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }+| STATEMENT { BlStatement () (getSpan $1) Nothing $1 }+| comment { let (TComment s c) = $1 in BlComment () s (Comment c) }  IF_BLOCK :: { Block A0 }-: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {-    let (endSpan, endLabel, conds, blocks) = $8-    in BlIf () (getTransSpan $1 endSpan) Nothing Nothing ((Just $3):conds) ((reverse $7):blocks) endLabel-  }-| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {-    let (endSpan, endLabel, conds, blocks) = $9-    in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing ((Just $4):conds) ((reverse $8):blocks) endLabel-  }--ELSE_BLOCKS :: { (SrcSpan, Maybe (Expression A0), [Maybe (Expression A0)], [[Block A0]]) }-: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS-  { let (endSpan, endLabel, conds, blocks) = $9-    in (endSpan, endLabel, Just $4 : conds, reverse $8 : blocks) }-| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif-  { (getSpan $6, $5, [Nothing], [reverse $4]) }-| maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) }+: if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS+  { let (clauses, elseBlock, endSpan, endLabel) = $8+    in  BlIf () (getTransSpan $1 endSpan) Nothing   Nothing (($3, reverse $6) :| clauses) elseBlock endLabel }+| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS+  { let (clauses, elseBlock, endSpan, endLabel) = $9+    in  BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $7) :| clauses) elseBlock endLabel } -COMMENT_BLOCK :: { Block A0 }-: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }+ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) }+: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS+  { let (clauses, elseBlock, endSpan, endLabel) = $9+    in (($4, reverse $7) : clauses, elseBlock, endSpan, endLabel) }+| maybe(LABEL_IN_6COLUMN) else BLOCKS NEWLINE maybe(LABEL_IN_6COLUMN) endif+  { ([], Just (reverse $3), getSpan $6, $5) }+| maybe(LABEL_IN_6COLUMN) endif+  { ([], Nothing,           getSpan $2, $1) }  NEWLINE :: { Token } : NEWLINE newline { $1 }@@ -304,8 +303,10 @@   { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 } | enddo { StEnddo () (getSpan $1) Nothing } | call VARIABLE ARGUMENTS-  { StCall () (getTransSpan $1 $3) $2 $ Just $3 }-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }+  { StCall () (getTransSpan $1 $3) $2 $3 }+| call VARIABLE+  { StCall () (getTransSpan $1 $2) $2 (aEmpty () (emptySpan (ssTo (getSpan $2)))) }+  -- ^ (!) empty list 0-span | return { StReturn () (getSpan $1) Nothing } | return EXPRESSION { StReturn () (getTransSpan $1 $2) $ Just $2 } | save SAVE_ARGS { StSave () (getSpan ($1, $2)) $2 }@@ -550,19 +551,21 @@ | 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-             }+: id+  {% let TId s id = $1+     in  case List.uncons id of+           Just (c, "") -> return $ ImpElement () s c Nothing+           _ -> fail "Implicit argument must be a character." }+| id '-' id+  {% let { TId _ idFrom = $1;+           TId _ idTo   = $3;+           s            = getTransSpan $1 $3 }+     in  case List.uncons idFrom of+           Just (cFrom, "") ->+             case List.uncons idTo of+               Just (cTo, "") -> return $ ImpElement () s cFrom (Just cTo)+               _ -> fail "Implicit argument must be a character."+           _ -> fail "Implicit argument must be a character." }  ELEMENT :: { Expression A0 } : SUBSCRIPT { $1 }@@ -591,7 +594,8 @@ : SIGNED_NUMERIC_LITERAL  { $1 } -- | COMPLEX_LITERAL         { $1 } | VARIABLE                { $1 }-| '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')'+  {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL         { $1 } | STRING                  { $1 } | HOLLERITH               { $1 }@@ -690,8 +694,8 @@ SIMPLE_EXPRESSION :: { Expression A0 } : INTEGER_CONSTANT '*' CONSTANT  { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | CONSTANT { $1 }-| '(' '*' ')' { ExpValue () (getSpan $2) ValStar }-| '(' EXPRESSION ')' { $2 }+| '(' '*' ')' { ExpValue () (getTransSpan $1 $3) ValStar }+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }  CONSTANT :: { Expression A0 } : VARIABLE { $1 }@@ -738,7 +742,7 @@           TId _ name = $2;           intr = ExpFunctionCall () (getTransSpan $1 $5)                    (ExpValue () (getTransSpan $1 $2) (ValIntrinsic ('%':name)))-                   (Just args) }+                   args }     in Argument () (getTransSpan $1 $5) Nothing (ArgExpr intr) } | id '=' EXPRESSION   { let TId span keyword = $1@@ -765,7 +769,7 @@ | EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } | '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } | NUMERIC_LITERAL                   { $1 }-| '(' EXPRESSION ',' EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }+| '(' EXPRESSION ',' EXPRESSION ')' {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL                   { $1 } | HOLLERITH                         { $1 } -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,@@ -787,7 +791,7 @@          } | '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')' {     let expList = AList () (getTransSpan $2 $4) [ $2, $4 ]-          in ExpImpliedDo () (getTransSpan $1 $5) expList $6+          in ExpImpliedDo () (getTransSpan $1 $7) expList $6          } | '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')' {     let { exps =  reverse $6;@@ -816,7 +820,8 @@ | CONSTANT_EXPRESSION RELATIONAL_OPERATOR CONSTANT_EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } | '(' CONSTANT_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } | NUMERIC_LITERAL               { $1 }-| '(' CONSTANT_EXPRESSION ',' CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| '(' CONSTANT_EXPRESSION ',' CONSTANT_EXPRESSION ')'+  {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL               { $1 } | SUBSCRIPT                    { $1 } | HOLLERITH                    { $1 }@@ -835,7 +840,8 @@ | ARITHMETIC_SIGN ARITHMETIC_CONSTANT_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | '(' ARITHMETIC_CONSTANT_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } | NUMERIC_LITERAL               { $1 }-| '(' ARITHMETIC_CONSTANT_EXPRESSION ',' ARITHMETIC_CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| '(' ARITHMETIC_CONSTANT_EXPRESSION ',' ARITHMETIC_CONSTANT_EXPRESSION ')'+  {% complexLit (getTransSpan $1 $5) $2 $4 } | VARIABLE                     { $1 } | SUBSCRIPT                    { $1 } @@ -853,7 +859,8 @@ | SUBSCRIPT '%' VARIABLE   { ExpDataRef () (getTransSpan $1 $3) $1 $3 } | SUBSCRIPT '(' ')'-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+  { ExpFunctionCall () (getTransSpan $1 $3) $1 (aEmpty () (getTransSpan $2 $3)) }+  -- ^ (!) empty list spans brackets | SUBSCRIPT '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } | VARIABLE { $1 }

@@ -31,7 +31,7 @@ import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position import Language.Fortran.Parser.LexerUtils ( readIntOrBoz )-import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Boz  } @@ -888,7 +888,7 @@ vanillaAlexInput fn fv bs = AlexInput   { aiSourceBytes = bs   , aiEndOffset = B.length bs-  , aiPosition = initPosition { filePath = fn }+  , aiPosition = initPosition { posFilePath = fn }   , aiBytes = []   , aiPreviousChar = '\n'   , aiLexeme = initLexeme

@@ -3,7 +3,7 @@  import Language.Fortran.Parser.Fixed.Lexer import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad import Control.Monad.State

@@ -12,12 +12,14 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.ParserUtils ( complexLit ) import Language.Fortran.Parser.Free.Lexer import Language.Fortran.Parser.Free.Utils import Language.Fortran.AST  import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Either ( partitionEithers )+import qualified Data.List as List  } @@ -363,87 +365,93 @@ | COMMENT_BLOCK { $1 }  IF_BLOCK :: { Block A0 }+IF_BLOCK :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;-          (endSpan, conds, blocks, endLabel) = $9;+          (clauses, elseBlock, endSpan, endLabel) = $9;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+     in BlIf () span Nothing    Nothing          (($3, reverse $8)  :| clauses) elseBlock endLabel } |                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { TId startSpan startName = $1;-          (endSpan, conds, blocks, endLabel) = $11;+          (clauses, elseBlock, endSpan, endLabel) = $11;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+     in BlIf () span Nothing    (Just startName) (($5, reverse $10) :| clauses) elseBlock endLabel } | INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;-          (endSpan, conds, blocks, endLabel) = $10;+          (clauses, elseBlock, endSpan, endLabel) = $10;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+     in BlIf () span startLabel Nothing          (($4, reverse $9)  :| clauses) elseBlock endLabel } | INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;           TId _ startName = $2;-          (endSpan, conds, blocks, endLabel) = $12;+          (clauses, elseBlock, endSpan, endLabel) = $12;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }+     in BlIf () span startLabel (Just startName) (($6, reverse $11) :| clauses) elseBlock endLabel } -ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) }+ELSE_BLOCKS : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS-  { let (endSpan, conds, blocks, endLabel) = $10-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+  { let (clauses, elseBlock, endSpan, endLabel) = $10+    in  (($4, reverse $9) : clauses, elseBlock, endSpan, endLabel) } | maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF   { let (endSpan, endLabel) = $6-    in (endSpan, [Nothing], [reverse $5], endLabel) }-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }+    in  ([], Just (reverse $5), endSpan, endLabel) }+| END_IF+  { let (endSpan, endLabel) = $1+    in  ([], Nothing,           endSpan, endLabel) }  END_IF :: { (SrcSpan, Maybe (Expression A0)) }+END_IF : endif { (getSpan $1, Nothing) } | endif id { (getSpan $2, Nothing) } | INTEGER_LITERAL endif { (getSpan $2, Just $1) } | INTEGER_LITERAL endif id { (getSpan $3, Just $1) }  CASE_BLOCK :: { Block A0 }+CASE_BLOCK :                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+  { let { (clauses, defaultCase, endSpan, endLabel) = $7;           span = getTransSpan $1 endSpan }-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+    in BlCase () span Nothing   Nothing          $3 clauses defaultCase endLabel } | INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+  { let { (clauses, defaultCase, endSpan, endLabel) = $8;           span = getTransSpan $1 endSpan }-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+    in BlCase () span (Just $1) Nothing          $4 clauses defaultCase endLabel } |                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+  { let { (clauses, defaultCase, endSpan, endLabel) = $9;           TId s startName = $1;           span = getTransSpan s endSpan }-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+    in BlCase () span Nothing   (Just startName) $5 clauses defaultCase endLabel } | INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+  { let { (clauses, defaultCase, endSpan, endLabel) = $10;           TId s startName = $2;           span = getTransSpan s endSpan }-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }+    in BlCase () span (Just $1) (Just startName) $6 clauses defaultCase endLabel }  -- We store line comments as statements, but this raises an issue: we have -- nowhere to place comments after a SELECT CASE but before a CASE. So we drop -- them. The inner CASES_ rule does /not/ use this, because comments can always -- be parsed as belonging to to the above CASE block.-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES  :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : COMMENT_BLOCK CASES_ { $2 } |               CASES_ { $1 } -CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES_ :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_-  { let (scrutinees, blocks, endLabel, endSpan) = $9-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+  { let (clauses, defaultCase, endSpan, endLabel) = $9+    in  ((fromReverseList $4, reverse $8) : clauses, defaultCase, endSpan, endLabel) } | maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT-  { let (endLabel, endSpan) = $7-    in ([Nothing], [$6], endLabel, endSpan) }+  { let (endSpan, endLabel) = $7+    in ([], Just $6, endSpan, endLabel) } | END_SELECT-  { let (endLabel, endSpan) = $1-    in ([], [], endLabel, endSpan) }+  { let (endSpan, endLabel) = $1+    in ([], Nothing, endSpan, endLabel) } -END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+END_SELECT :: { (SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) endselect maybe(id)-  { ($1, maybe (getSpan $2) getSpan $3) }+  { (maybe (getSpan $2) getSpan $3, $1) }  ASSOCIATE_BLOCK :: { Block A0 } : INTEGER_LITERAL id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE@@ -505,11 +513,11 @@ | {- EMPTY -} { False }  MAYBE_EXPRESSION :: { Maybe (Expression A0) }-: EXPRESSION { Just $1 }+: EXPRESSION  { Just $1 } | {- EMPTY -} { Nothing }  MAYBE_COMMENT :: { Maybe Token }-: comment { Just $1 }+: comment     { Just $1 } | {- EMPTY -} { Nothing }  SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }@@ -568,12 +576,12 @@   { let saveAList = (fromReverseList $3)     in StSave () (getTransSpan $1 saveAList) (Just saveAList) } | save { StSave () (getSpan $1) Nothing }-| procedure '(' MAYBE_PROC_INTERFACE ')' ',' ATTRIBUTE_SPEC '::' PROC_DECLS-  { let declAList = fromReverseList $8-    in StProcedure () (getTransSpan $1 $8) $3 (Just $6) declAList }-| procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_DCOLON PROC_DECLS-  { let declAList = fromReverseList $6-    in StProcedure () (getTransSpan $1 $6) $3 Nothing declAList }++-- according to IBM F2003 docs, dcolon is always required+| procedure '(' MAYBE_PROC_INTERFACE ')' ATTRIBUTE_LIST '::' PROC_DECLS+  { let declAList = fromReverseList $7+    in StProcedure () (getTransSpan $1 $7) $3 (Just (fromReverseList $5)) declAList }+ | dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST   { let declAList = fromReverseList $3     in StDimension () (getTransSpan $1 declAList) declAList }@@ -765,11 +773,14 @@ | backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 } | flush INTEGER_LITERAL { StFlush () (getTransSpan $1 $2) (AList () (getSpan $2) [FSUnit () (getSpan $2) $2]) } | flush '(' FLUSH_SPEC_LIST ')' { StFlush () (getTransSpan $1 $4) (fromReverseList $3) }-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }-| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }+| call VARIABLE+  { StCall () (getTransSpan $1 $2) $2 (aEmpty () (emptySpan (ssTo (getSpan $2)))) }+  -- ^ (!) empty list 0-span+| call VARIABLE '(' ')'+  { StCall () (getTransSpan $1 $4) $2 (aEmpty () (getTransSpan $3 $4)) }+  -- ^ (!) empty list spans brackets | call VARIABLE '(' ARGUMENTS ')'-  { let alist = fromReverseList $4-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }+  { StCall () (getTransSpan $1 $5) $2 (fromReverseList $4) } | return { StReturn () (getSpan $1) Nothing } | return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) } | FORALL { $1 }@@ -827,11 +838,11 @@  {- R928 -} FLUSH_SPEC :: { FlushSpec A0 }-: EXPRESSION { FSUnit () (getSpan $1) $1 }-| unit '=' EXPRESSION   { FSUnit () (getTransSpan $1 $3) $3 }+:            EXPRESSION { FSUnit   () (getSpan $1)         $1 }+| unit   '=' EXPRESSION { FSUnit   () (getTransSpan $1 $3) $3 } | iostat '=' EXPRESSION { FSIOStat () (getTransSpan $1 $3) $3 }-| iomsg '=' EXPRESSION  { FSIOMsg () (getTransSpan $1 $3) $3 }-| err '=' EXPRESSION    { FSErr () (getTransSpan $1 $3) $3 }+| iomsg  '=' EXPRESSION { FSIOMsg  () (getTransSpan $1 $3) $3 }+| err    '=' EXPRESSION { FSErr    () (getTransSpan $1 $3) $3 }  CILIST :: { AList ControlPair A0 } : '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'@@ -989,19 +1000,21 @@ | 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-             }+: id+  {% let TId s id = $1+     in  case List.uncons id of+           Just (c, "") -> return $ ImpElement () s c Nothing+           _ -> fail "Implicit argument must be a character." }+| id '-' id+  {% let { TId _ idFrom = $1;+           TId _ idTo   = $3;+           s            = getTransSpan $1 $3 }+     in  case List.uncons idFrom of+           Just (cFrom, "") ->+             case List.uncons idTo of+               Just (cTo, "") -> return $ ImpElement () s cFrom (Just cTo)+               _ -> fail "Implicit argument must be a character."+           _ -> fail "Implicit argument must be a character." }  PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] } : PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }@@ -1228,8 +1241,7 @@     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) }+| '(' EXPRESSION ',' EXPRESSION ')' {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL                   { $1 } | STRING                            { $1 } | DATA_REF                          { $1 }@@ -1257,7 +1269,8 @@ PART_REF :: { Expression A0 } : VARIABLE { $1 } | VARIABLE '(' ')'-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+  { ExpFunctionCall () (getTransSpan $1 $3) $1 (aEmpty () (getTransSpan $2 $3)) }+  -- ^ (!) empty list spans brackets | VARIABLE '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } | VARIABLE '(' INDICIES ')' '(' INDICIES ')'@@ -1305,41 +1318,40 @@     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-}+: id ':' forall FORALL_HEADER+    { let (TId s1 id) = $1+      in  StForall () (getTransSpan s1 $4) (Just id) $4 }+| forall FORALL_HEADER+    { StForall () (getTransSpan $1 $2) Nothing $2 }+| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT+    { StForallStatement () (getTransSpan $1 $3) $2 $3 } -FORALL_HEADER :: { (ForallHeader A0, SrcSpan) }+FORALL_HEADER :: { ForallHeader A0 } -- Standard simple forall header-: '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }+: '(' FORALL_TRIPLET_SPEC ')'+    { ForallHeader () (getTransSpan $1 $3) [$2] Nothing } -- forall header with scale expression | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'-                              { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }+    { ForallHeader () (getTransSpan $1 $7) [$3] (Just $6) } -- multi forall header | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'-                              { (ForallHeader $2 Nothing, getTransSpan $1 $3) }+    { ForallHeader () (getTransSpan $1 $3) $2   Nothing } -- multi forall header with scale | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'-                              { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }+    { ForallHeader () (getTransSpan $1 $5) $2   (Just $4) }  FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE-  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }+  :: { [ForallHeaderPart A0] } : '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 } | {- empty -}                                                          { [] } -FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }-: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }-| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }+FORALL_TRIPLET_SPEC :: { ForallHeaderPart A0 }+: id '=' EXPRESSION ':' EXPRESSION+    { let TId idSpan idName = $1+      in ForallHeaderPart () (getTransSpan idSpan $5) idName $3 $5 Nothing   }+| id '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION+    { let TId idSpan idName = $1+      in  ForallHeaderPart () (getTransSpan idSpan $7) idName $3 $5 (Just $7) }  FORALL_ASSIGNMENT_STMT :: { Statement A0 } : EXPRESSION_ASSIGNMENT_STATEMENT { $1 }@@ -1403,9 +1415,12 @@   { let TLogicalLiteral s b = $1      in ExpValue () s (ValLogical b (Just $3)) } -KIND_PARAM :: { Expression A0 }-: INTEGER_LITERAL { $1 }-| VARIABLE        { $1 }+KIND_PARAM :: { KindParam A0 }+: INTEGER_LITERAL_PLAIN { let (i, ss)                        = $1 in KindParamInt () ss i }+| VARIABLE              { let ExpValue () ss (ValVariable v) = $1 in KindParamVar () ss v }++INTEGER_LITERAL_PLAIN :: { (String, SrcSpan) }+: int { let TIntegerLiteral s i = $1 in (i, s) }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -12,12 +12,14 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.ParserUtils ( complexLit ) import Language.Fortran.Parser.Free.Lexer import Language.Fortran.Parser.Free.Utils import Language.Fortran.AST  import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Either ( partitionEithers )+import qualified Data.List as List  } @@ -309,94 +311,100 @@ | COMMENT_BLOCK { $1 }  IF_BLOCK :: { Block A0 }+IF_BLOCK :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;-          (endSpan, conds, blocks, endLabel) = $9;+          (clauses, elseBlock, endSpan, endLabel) = $9;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+     in BlIf () span Nothing    Nothing          (($3, reverse $8)  :| clauses) elseBlock endLabel } |                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { TId startSpan startName = $1;-          (endSpan, conds, blocks, endLabel) = $11;+          (clauses, elseBlock, endSpan, endLabel) = $11;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+     in BlIf () span Nothing    (Just startName) (($5, reverse $10) :| clauses) elseBlock endLabel } | INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;-          (endSpan, conds, blocks, endLabel) = $10;+          (clauses, elseBlock, endSpan, endLabel) = $10;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+     in BlIf () span startLabel Nothing          (($4, reverse $9)  :| clauses) elseBlock endLabel } | INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;           TId _ startName = $2;-          (endSpan, conds, blocks, endLabel) = $12;+          (clauses, elseBlock, endSpan, endLabel) = $12;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }+     in BlIf () span startLabel (Just startName) (($6, reverse $11) :| clauses) elseBlock endLabel } -ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) }+ELSE_BLOCKS : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS-  { let (endSpan, conds, blocks, endLabel) = $10-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+  { let (clauses, elseBlock, endSpan, endLabel) = $10+    in  (($4, reverse $9) : clauses, elseBlock, endSpan, endLabel) } | maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF   { let (endSpan, endLabel) = $6-    in (endSpan, [Nothing], [reverse $5], endLabel) }-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }+    in  ([], Just (reverse $5), endSpan, endLabel) }+| END_IF+  { let (endSpan, endLabel) = $1+    in  ([], Nothing,           endSpan, endLabel) }  END_IF :: { (SrcSpan, Maybe (Expression A0)) }+END_IF : endif { (getSpan $1, Nothing) } | endif id { (getSpan $2, Nothing) } | INTEGER_LITERAL endif { (getSpan $2, Just $1) } | INTEGER_LITERAL endif id { (getSpan $3, Just $1) }  CASE_BLOCK :: { Block A0 }+CASE_BLOCK :                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+  { let { (clauses, defaultCase, endSpan, endLabel) = $7;           span = getTransSpan $1 endSpan }-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+    in BlCase () span Nothing   Nothing          $3 clauses defaultCase endLabel } | INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+  { let { (clauses, defaultCase, endSpan, endLabel) = $8;           span = getTransSpan $1 endSpan }-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+    in BlCase () span (Just $1) Nothing          $4 clauses defaultCase endLabel } |                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+  { let { (clauses, defaultCase, endSpan, endLabel) = $9;           TId s startName = $1;           span = getTransSpan s endSpan }-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+    in BlCase () span Nothing   (Just startName) $5 clauses defaultCase endLabel } | INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+  { let { (clauses, defaultCase, endSpan, endLabel) = $10;           TId s startName = $2;           span = getTransSpan s endSpan }-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }+    in BlCase () span (Just $1) (Just startName) $6 clauses defaultCase endLabel }  -- We store line comments as statements, but this raises an issue: we have -- nowhere to place comments after a SELECT CASE but before a CASE. So we drop -- them. The inner CASES_ rule does /not/ use this, because comments can always -- be parsed as belonging to to the above CASE block.-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES  :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : COMMENT_BLOCK CASES_ { $2 } |               CASES_ { $1 } -CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES_ :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_-  { let (scrutinees, blocks, endLabel, endSpan) = $9-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+  { let (clauses, defaultCase, endSpan, endLabel) = $9+    in  ((fromReverseList $4, reverse $8) : clauses, defaultCase, endSpan, endLabel) } | maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT-  { let (endLabel, endSpan) = $7-    in ([Nothing], [$6], endLabel, endSpan) }+  { let (endSpan, endLabel) = $7+    in ([], Just $6, endSpan, endLabel) } | END_SELECT-  { let (endLabel, endSpan) = $1-    in ([], [], endLabel, endSpan) }+  { let (endSpan, endLabel) = $1+    in ([], Nothing, endSpan, endLabel) } -END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+END_SELECT :: { (SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) endselect maybe(id)-  { ($1, maybe (getSpan $2) getSpan $3) }+  { (maybe (getSpan $2) getSpan $3, $1) }  MAYBE_EXPRESSION :: { Maybe (Expression A0) }-: EXPRESSION { Just $1 }+: EXPRESSION  { Just $1 } | {- EMPTY -} { Nothing }  MAYBE_COMMENT :: { Maybe Token }-: comment { Just $1 }+: comment     { Just $1 } | {- EMPTY -} { Nothing }  SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }@@ -601,11 +609,13 @@ | 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 { StCall () (getTransSpan $1 $2) $2 (aEmpty () (emptySpan (ssTo (getSpan $2)))) }+  -- ^ (!) empty list 0-span+| call VARIABLE '(' ')'+  { StCall () (getTransSpan $1 $4) $2 (aEmpty () (getTransSpan $3 $4)) }+  -- ^ (!) empty list spans brackets | call VARIABLE '(' ARGUMENTS ')'-  { let alist = fromReverseList $4-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }+  { StCall () (getTransSpan $1 $5) $2 (fromReverseList $4) } | return { StReturn () (getSpan $1) Nothing } | return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) } @@ -800,19 +810,21 @@ | 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-             }+: id+  {% let TId s id = $1+     in  case List.uncons id of+           Just (c, "") -> return $ ImpElement () s c Nothing+           _ -> fail "Implicit argument must be a character." }+| id '-' id+  {% let { TId _ idFrom = $1;+           TId _ idTo   = $3;+           s            = getTransSpan $1 $3 }+     in  case List.uncons idFrom of+           Just (cFrom, "") ->+             case List.uncons idTo of+               Just (cTo, "") -> return $ ImpElement () s cFrom (Just cTo)+               _ -> fail "Implicit argument must be a character."+           _ -> fail "Implicit argument must be a character." }  PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] } : PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }@@ -1020,8 +1032,7 @@     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) }+| '(' EXPRESSION ',' EXPRESSION ')' {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL                   { $1 } | STRING                            { $1 } | DATA_REF                          { $1 }@@ -1049,7 +1060,8 @@ PART_REF :: { Expression A0 } : VARIABLE { $1 } | VARIABLE '(' ')'-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+  { ExpFunctionCall () (getTransSpan $1 $3) $1 (aEmpty () (getTransSpan $2 $3)) }+  -- ^ (!) empty list spans brackets | VARIABLE '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } | VARIABLE '(' INDICIES ')' '(' INDICIES ')'@@ -1147,9 +1159,12 @@   { let TLogicalLiteral s b = $1      in ExpValue () s (ValLogical b (Just $3)) } -KIND_PARAM :: { Expression A0 }-: INTEGER_LITERAL { $1 }-| VARIABLE        { $1 }+KIND_PARAM :: { KindParam A0 }+: INTEGER_LITERAL_PLAIN { let (i, ss)                        = $1 in KindParamInt () ss i }+| VARIABLE              { let ExpValue () ss (ValVariable v) = $1 in KindParamVar () ss v }++INTEGER_LITERAL_PLAIN :: { (String, SrcSpan) }+: int { let TIntegerLiteral s i = $1 in (i, s) }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -12,12 +12,14 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.ParserUtils ( complexLit ) import Language.Fortran.Parser.Free.Lexer import Language.Fortran.Parser.Free.Utils import Language.Fortran.AST  import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Either ( partitionEithers )+import qualified Data.List as List  } @@ -321,37 +323,39 @@ IF_BLOCK :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;-          (endSpan, conds, blocks, endLabel) = $9;+          (clauses, elseBlock, endSpan, endLabel) = $9;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }+     in BlIf () span Nothing    Nothing          (($3, reverse $8)  :| clauses) elseBlock endLabel } |                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { TId startSpan startName = $1;-          (endSpan, conds, blocks, endLabel) = $11;+          (clauses, elseBlock, endSpan, endLabel) = $11;           span = getTransSpan startSpan endSpan }-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }+     in BlIf () span Nothing    (Just startName) (($5, reverse $10) :| clauses) elseBlock endLabel } | INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;-          (endSpan, conds, blocks, endLabel) = $10;+          (clauses, elseBlock, endSpan, endLabel) = $10;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }+     in BlIf () span startLabel Nothing          (($4, reverse $9)  :| clauses) elseBlock endLabel } | INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS   { let { startSpan = getSpan $1;           startLabel = Just $1;           TId _ startName = $2;-          (endSpan, conds, blocks, endLabel) = $12;+          (clauses, elseBlock, endSpan, endLabel) = $12;           span = getTransSpan startSpan endSpan }-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }+     in BlIf () span startLabel (Just startName) (($6, reverse $11) :| clauses) elseBlock endLabel } -ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }+ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } ELSE_BLOCKS : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS-  { let (endSpan, conds, blocks, endLabel) = $10-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }+  { let (clauses, elseBlock, endSpan, endLabel) = $10+    in  (($4, reverse $9) : clauses, elseBlock, endSpan, endLabel) } | maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF   { let (endSpan, endLabel) = $6-    in (endSpan, [Nothing], [reverse $5], endLabel) }-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }+    in  ([], Just (reverse $5), endSpan, endLabel) }+| END_IF+  { let (endSpan, endLabel) = $1+    in  ([], Nothing,           endSpan, endLabel) }  END_IF :: { (SrcSpan, Maybe (Expression A0)) } END_IF@@ -363,53 +367,53 @@ CASE_BLOCK :: { Block A0 } CASE_BLOCK :                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;+  { let { (clauses, defaultCase, endSpan, endLabel) = $7;           span = getTransSpan $1 endSpan }-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }+    in BlCase () span Nothing   Nothing          $3 clauses defaultCase endLabel } | INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;+  { let { (clauses, defaultCase, endSpan, endLabel) = $8;           span = getTransSpan $1 endSpan }-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }+    in BlCase () span (Just $1) Nothing          $4 clauses defaultCase endLabel } |                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;+  { let { (clauses, defaultCase, endSpan, endLabel) = $9;           TId s startName = $1;           span = getTransSpan s endSpan }-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }+    in BlCase () span Nothing   (Just startName) $5 clauses defaultCase endLabel } | INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;+  { let { (clauses, defaultCase, endSpan, endLabel) = $10;           TId s startName = $2;           span = getTransSpan s endSpan }-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }+    in BlCase () span (Just $1) (Just startName) $6 clauses defaultCase endLabel }  -- We store line comments as statements, but this raises an issue: we have -- nowhere to place comments after a SELECT CASE but before a CASE. So we drop -- them. The inner CASES_ rule does /not/ use this, because comments can always -- be parsed as belonging to to the above CASE block.-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES  :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : COMMENT_BLOCK CASES_ { $2 } |               CASES_ { $1 } -CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }+CASES_ :: { ([(AList Index A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_-  { let (scrutinees, blocks, endLabel, endSpan) = $9-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }+  { let (clauses, defaultCase, endSpan, endLabel) = $9+    in  ((fromReverseList $4, reverse $8) : clauses, defaultCase, endSpan, endLabel) } | maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT-  { let (endLabel, endSpan) = $7-    in ([Nothing], [$6], endLabel, endSpan) }+  { let (endSpan, endLabel) = $7+    in ([], Just $6, endSpan, endLabel) } | END_SELECT-  { let (endLabel, endSpan) = $1-    in ([], [], endLabel, endSpan) }+  { let (endSpan, endLabel) = $1+    in ([], Nothing, endSpan, endLabel) } -END_SELECT :: { (Maybe (Expression A0), SrcSpan) }+END_SELECT :: { (SrcSpan, Maybe (Expression A0)) } : maybe(INTEGER_LITERAL) endselect maybe(id)-  { ($1, maybe (getSpan $2) getSpan $3) }+  { (maybe (getSpan $2) getSpan $3, $1) }  MAYBE_EXPRESSION :: { Maybe (Expression A0) }-: EXPRESSION { Just $1 }+: EXPRESSION  { Just $1 } | {- EMPTY -} { Nothing }  MAYBE_COMMENT :: { Maybe Token }-: comment { Just $1 }+: comment     { Just $1 } | {- EMPTY -} { Nothing }  SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }@@ -611,11 +615,14 @@ | 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+  { StCall () (getTransSpan $1 $2) $2 (aEmpty () (emptySpan (ssTo (getSpan $2)))) }+  -- ^ (!) empty list 0-span+| call VARIABLE '(' ')'+  { StCall () (getTransSpan $1 $4) $2 (aEmpty () (getTransSpan $3 $4)) }+  -- ^ (!) empty list spans brackets | call VARIABLE '(' ARGUMENTS ')'-  { let alist = fromReverseList $4-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }+  { StCall () (getTransSpan $1 $5) $2 (fromReverseList $4) } | return { StReturn () (getSpan $1) Nothing } | return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) } | FORALL { $1 }@@ -813,19 +820,21 @@ | 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-             }+: id+  {% let TId s id = $1+     in  case List.uncons id of+           Just (c, "") -> return $ ImpElement () s c Nothing+           _ -> fail "Implicit argument must be a character." }+| id '-' id+  {% let { TId _ idFrom = $1;+           TId _ idTo   = $3;+           s            = getTransSpan $1 $3 }+     in  case List.uncons idFrom of+           Just (cFrom, "") ->+             case List.uncons idTo of+               Just (cTo, "") -> return $ ImpElement () s cFrom (Just cTo)+               _ -> fail "Implicit argument must be a character."+           _ -> fail "Implicit argument must be a character." }  PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] } : PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }@@ -1035,8 +1044,7 @@     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) }+| '(' EXPRESSION ',' EXPRESSION ')' {% complexLit (getTransSpan $1 $5) $2 $4 } | LOGICAL_LITERAL                   { $1 } | STRING                            { $1 } | DATA_REF                          { $1 }@@ -1064,7 +1072,8 @@ PART_REF :: { Expression A0 } : VARIABLE { $1 } | VARIABLE '(' ')'-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+  { ExpFunctionCall () (getTransSpan $1 $3) $1 (aEmpty () (getTransSpan $2 $3)) }+  -- ^ (!) empty list spans brackets | VARIABLE '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } | VARIABLE '(' INDICIES ')' '(' INDICIES ')'@@ -1112,45 +1121,40 @@     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-}+: id ':' forall FORALL_HEADER+    { let (TId s1 id) = $1+      in  StForall () (getTransSpan s1 $4) (Just id) $4 }+| forall FORALL_HEADER+    { StForall () (getTransSpan $1 $2) Nothing $2 }+| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT+    { StForallStatement () (getTransSpan $1 $3) $2 $3 } -FORALL_HEADER-  :: { (ForallHeader A0, SrcSpan) }-FORALL_HEADER :-  -- Standard simple forall header-    '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }-  -- forall header with scale expression-  | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'-                                  { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }-  -- multi forall header-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'-                                  { (ForallHeader $2 Nothing, getTransSpan $1 $3) }-  -- multi forall header with scale-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'-                                  { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }+FORALL_HEADER :: { ForallHeader A0 }+-- Standard simple forall header+: '(' FORALL_TRIPLET_SPEC ')'+    { ForallHeader () (getTransSpan $1 $3) [$2] Nothing }+-- forall header with scale expression+| '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'+    { ForallHeader () (getTransSpan $1 $7) [$3] (Just $6) }+-- multi forall header+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'+    { ForallHeader () (getTransSpan $1 $3) $2   Nothing }+-- multi forall header with scale+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'+    { ForallHeader () (getTransSpan $1 $5) $2   (Just $4) }  FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE-  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE+  :: { [ForallHeaderPart A0] } : '(' 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_TRIPLET_SPEC :: { ForallHeaderPart A0 }+: id '=' EXPRESSION ':' EXPRESSION+    { let TId idSpan idName = $1+      in ForallHeaderPart () (getTransSpan idSpan $5) idName $3 $5 Nothing   }+| id '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION+    { let TId idSpan idName = $1+      in  ForallHeaderPart () (getTransSpan idSpan $7) idName $3 $5 (Just $7) }  FORALL_ASSIGNMENT_STMT :: { Statement A0 } FORALL_ASSIGNMENT_STMT :@@ -1217,9 +1221,12 @@   { let TLogicalLiteral s b = $1      in ExpValue () s (ValLogical b (Just $3)) } -KIND_PARAM :: { Expression A0 }-: INTEGER_LITERAL { $1 }-| VARIABLE        { $1 }+KIND_PARAM :: { KindParam A0 }+: INTEGER_LITERAL_PLAIN { let (i, ss)                        = $1 in KindParamInt () ss i }+| VARIABLE              { let ExpValue () ss (ValVariable v) = $1 in KindParamVar () ss v }++INTEGER_LITERAL_PLAIN :: { (String, SrcSpan) }+: int { let TIntegerLiteral s i = $1 in (i, s) }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -32,8 +32,8 @@ import Language.Fortran.Version import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter-import Language.Fortran.AST.RealLit (RealLit, parseRealLit)-import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Real (RealLit, parseRealLit)+import Language.Fortran.AST.Literal.Boz import Language.Fortran.Parser.LexerUtils ( readIntOrBoz )  }@@ -893,7 +893,7 @@ vanillaAlexInput :: String -> B.ByteString -> AlexInput vanillaAlexInput fn bs = AlexInput   { aiSourceBytes          = bs-  , aiPosition             = initPosition { filePath = fn }+  , aiPosition             = initPosition { posFilePath = fn }   , aiEndOffset            = B.length bs   , aiPreviousChar         = '\n'   , aiLexeme               = initLexeme

@@ -1,7 +1,7 @@ {-| Utils for both lexers. -} module Language.Fortran.Parser.LexerUtils ( readIntOrBoz ) where -import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Boz import Numeric  -- | Read a string as either a signed integer, or a BOZ constant (positive).

@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}++{-| Utils for various parsers (beyond token level).++We can sometimes work around there being free-form and fixed-form versions of+the @LexAction@ monad by requesting the underlying instances instances. We place+such utilities that match that form here.++-}+module Language.Fortran.Parser.ParserUtils where++import Language.Fortran.AST+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Complex+import Language.Fortran.Util.Position++#if !MIN_VERSION_base(4,13,0)+-- Control.Monad.Fail import is redundant since GHC 8.8.1+import Control.Monad.Fail ( MonadFail )+#endif++{- $complex-lit-parsing++Parsing complex literal parts unambiguously is a pain, so instead, we parse any+expression, then case on it to determine if it's valid for a complex literal+part -- and if so, push it into a 'ComplexPart' constructor. This may cause+unexpected behaviour if more bracketing/tuple rules are added!+-}++-- | Try to validate an expression as a COMPLEX literal part.+--+-- $complex-lit-parsing+exprToComplexLitPart :: MonadFail m => Expression a -> m (ComplexPart a)+exprToComplexLitPart e =+    case e' of+      ExpValue a ss val ->+        case val of+          ValReal    r mkp ->+            let r' = r { realLitSignificand = sign <> realLitSignificand r }+             in return $ ComplexPartReal a ss r' mkp+          ValInteger i mkp -> return $ ComplexPartInt a ss (sign<>i) mkp+          ValVariable var  -> return $ ComplexPartNamed a ss var+          _                -> fail $ "Invalid COMPLEX literal @ " <> show ss+      _ -> fail $ "Invalid COMPLEX literal @ " <> show (getSpan e')+  where+    (sign, e') = case e of ExpUnary _ _ Minus e'' -> ("-", e'')+                           ExpUnary _ _ Plus  e'' -> ("", e'')+                           _                      -> ("", e)++-- | Helper for forming COMPLEX literals.+complexLit+    :: MonadFail m => SrcSpan -> Expression A0 -> Expression A0+    -> m (Expression A0)+complexLit ss e1 e2 = do+    compReal <- exprToComplexLitPart e1+    compImag <- exprToComplexLitPart e2+    return $ ExpValue () ss $ ValComplex $ ComplexLit () ss compReal compImag

@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE UndecidableInstances  #-}-{-# OPTIONS_GHC -Wno-orphans #-}  module Language.Fortran.PrettyPrint where @@ -10,10 +9,10 @@ import Prelude hiding (EQ,LT,GT,pred,exp,(<>))  import Language.Fortran.AST-import Language.Fortran.AST.RealLit-import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Boz+import Language.Fortran.AST.Literal.Complex import Language.Fortran.Version-import Language.Fortran.Util.FirstParameter  import Text.PrettyPrint @@ -42,6 +41,16 @@ doc1 <?+> doc2 = if doc1 == empty || doc2 == empty then empty else doc1 <+> doc2 infixl 7 <?+> +-- Helpers+printMaybe :: (a -> Doc) -> Maybe a -> Doc+printMaybe f = \case Just a  -> f a+                     Nothing -> empty++printIndentedBlockWithPre+    :: FortranVersion -> Indentation -> Doc -> [Block a] -> Doc+printIndentedBlockWithPre v i doc b =+    doc <> newline <> pprint v b (incIndentation i)+ newline :: Doc newline = char '\n' @@ -242,48 +251,49 @@         then indent i (pprint' v mLabel <+> pprint' v st <> newline)         else pprint' v mLabel `overlay` indent i (pprint' v st <> newline) -    pprint v (BlIf _ _ mLabel mName conds bodies el) i+    pprint v (BlIf _ _ mLabel mName ((ifPred, thenBlock) :| elseIfs) mElseBlock el) i       | v >= Fortran77 =-        labeledIndent mLabel-          (pprint' v mName <?> colon <+>-          "if" <+> parens (pprint' v firstCond) <+> "then" <> newline) <>-        pprint v firstBody nextI <>-        foldl' (<>) empty (map displayCondBlock restCondsBodies) <>-        labeledIndent el ("end if" <+> pprint' v mName <> newline)+               labeledIndent mLabel displayIfThen+            <> foldl' (<>) empty (map displayElseIf elseIfs)+            <> printMaybe displayElse mElseBlock+            <> labeledIndent el ("end if" <+> pprint' v mName)+            <> newline       | otherwise = tooOld v "Structured if" Fortran77       where-        ((firstCond, firstBody): restCondsBodies) = zip conds bodies-        displayCondBlock (mCond, block) =-          indent i-            (case mCond of {-              Just cond -> "else if" <+> parens (pprint' v cond) <+> "then";-              Nothing -> "else"-            } <> newline) <>-          pprint v block nextI-        nextI = incIndentation i+        displayIfThen =+            displayClause displayIfPred thenBlock+        displayIfPred =+            pprint' v mName <?> colon <+> displayPred "if" ifPred+        displayPred str pred =+            indent i str <+> parens (pprint' v pred) <+> "then"+        displayElseIf (pred, block) =+            displayClause (displayPred "else if" pred) block+        displayElse block =+            displayClause (indent i "else") block+        displayClause = printIndentedBlockWithPre v i         labeledIndent label stDoc =           if v >= Fortran90             then indent i (pprint' v label <+> stDoc)             else pprint' v mLabel `overlay` indent i stDoc -    pprint v (BlCase _ _ mLabel mName scrutinee ranges bodies el) i+    pprint v (BlCase _ _ mLabel mName scrutinee clauses mDefaultCase el) i       | v >= Fortran90 =-        indent i-          (pprint' v mLabel <+>-          pprint' v mName <?> colon <+>-          "select case" <+> parens (pprint' v scrutinee) <> newline) <>-        foldl' (<>) empty (zipWith (curry displayRangeBlock) ranges bodies) <>-        indent i (pprint' v el <+> "end select" <+> pprint' v mName <> newline)+             indent i (pre <+> "select case" <+> parens (pprint' v scrutinee))+          <> newline+          <> foldl' (<>) empty (map displayCase clauses)+          <> printMaybe displayCaseDefault mDefaultCase+          <> indent i (pprint' v el <+> "end select" <+> pprint' v mName)+          <> newline       | otherwise = tooOld v "Select case" Fortran90       where-        displayRangeBlock (mRanges, block) =-          indent nextI-            ("case" <+>-            case mRanges of {-              Just ranges' -> parens (pprint' v ranges');-              Nothing -> "default" } <> newline) <>-          pprint v block (incIndentation nextI)         nextI = incIndentation i+        pre = pprint' v mLabel <+> pprint' v mName <?> colon+        displayCaseDefault =+            displayClause (indent nextI "case default")+        displayCase (ranges, block) =+            displayClause (indent nextI $ "case" <+> displayRanges ranges) block+        displayRanges = parens . pprint' v+        displayClause = printIndentedBlockWithPre v nextI      pprint v (BlInterface _ _ mLabel abstractp pus moduleProcs) i       | v >= Fortran90 =@@ -865,10 +875,10 @@     pprint' _ _ = error "Not yet supported."  instance Pretty (FlushSpec a) where-  pprint' v (FSUnit _ _ e)   = "unit=" <> pprint' v e+  pprint' v (FSUnit _ _ e)   = "unit="   <> pprint' v e   pprint' v (FSIOStat _ _ e) = "iostat=" <> pprint' v e-  pprint' v (FSIOMsg _ _ e)  = "iomsg=" <> pprint' v e-  pprint' v (FSErr _ _ e)    = "err=" <> pprint' v e+  pprint' v (FSIOMsg _ _ e)  = "iomsg="  <> pprint' v e+  pprint' v (FSErr _ _ e)    = "err="    <> pprint' v e  instance Pretty (DoSpecification a) where     pprint' v (DoSpecification _ _ s@StExpressionAssign{} limit mStride) =@@ -915,8 +925,10 @@       pprint' v vars <> char '/' <> pprint' v exps <> char '/'  instance Pretty (ImpElement a) where-    pprint' _ (ImpCharacter _ _ c) = text c-    pprint' _ (ImpRange _ _ beg end) = text beg <> "-" <> text end+    pprint' _ (ImpElement _ _ cFrom mcTo) =+        case mcTo of+          Nothing  -> char cFrom+          Just cTo -> char cFrom <> "-" <> char cTo  instance Pretty (Expression a) where     pprint' v (ExpValue _ _ val)  =@@ -954,8 +966,6 @@     pprint' v (IxRange _ _ low up stride) =        pprint' v low <> colon <> pprint' v up <> colon <?> pprint' v stride --- A subset of Value permit the 'FirstParameter' operation-instance FirstParameter (Value a) String instance Pretty (Value a) where     pprint' _ ValStar       = char '*'     pprint' _ ValColon      = char ':'@@ -967,20 +977,34 @@       | v >= Fortran90 = "operator" <+> parens (text op)       -- TODO better error message is needed. Operator is too vague.       | otherwise = tooOld v "Operator" Fortran90-    pprint' v (ValComplex e1 e2) = parens $ commaSep [pprint' v e1, pprint' v e2]+    pprint' v (ValComplex c) = pprint' v c     pprint' _ (ValString str) = quotes $ text str-    pprint' v (ValLogical b kp) = text litStr <> kpPretty v kp+    pprint' v (ValLogical b mkp) = text litStr <> pprint' v mkp       where litStr = if b then ".true." else ".false."-    pprint' v (ValInteger i kp) = text i <> kpPretty v kp-    pprint' v (ValReal r kp) = text (prettyHsRealLit r) <> kpPretty v kp+    pprint' v (ValInteger i mkp) = text i <> pprint' v mkp+    pprint' v (ValReal rl mkp) = text (prettyHsRealLit rl) <> pprint' v mkp     pprint' _ (ValBoz b) = text $ prettyBoz b-    pprint' _ valLit = text . getFirstParameter $ valLit --- | Helper for pretty printing an optional kind parameter 'Expression'.-kpPretty :: FortranVersion -> Maybe (Expression a) -> Doc-kpPretty v = \case-  Nothing -> empty-  Just kp -> text "_" <> pprint' v kp+    pprint' _ (ValHollerith s) = text s+    pprint' _ (ValVariable  s) = text s+    pprint' _ (ValIntrinsic s) = text s+    pprint' _ (ValType      s) = text s++instance Pretty (ComplexLit a) where+    pprint' v c = parens $ commaSep [realPart, imagPart]+      where realPart = pprint' v (complexLitRealPart c)+            imagPart = pprint' v (complexLitImagPart c)++instance Pretty (KindParam a) where+    pprint' _ kp = text "_" <> text kp'+      where kp' = case kp of KindParamInt _ _ i -> i+                             KindParamVar _ _ v -> v++instance Pretty (ComplexPart a) where+    pprint' v = \case+      ComplexPartReal   _ _ rl mkp -> pprint' v (ValReal    rl mkp)+      ComplexPartInt    _ _ i  mkp -> pprint' v (ValInteger i  mkp)+      ComplexPartNamed  _ _ var    -> text var  instance IndentablePretty (StructureItem a) where   pprint v (StructFields a s spec mAttrs decls) _ = pprint' v (StDeclaration a s spec mAttrs decls)

@@ -96,8 +96,7 @@       let newContents  = RI.applyReplacements contents repls       withTempDirectory (takeDirectory filePath) ('.' : takeFileName filePath) $ \tmpDir ->         let tmpFile = tmpDir </> "tmp.f"-         in do putStrLn tmpFile-               BC.writeFile tmpFile newContents+         in do BC.writeFile tmpFile newContents                renameFile tmpFile filePath  -- | Utility function to convert 'SrcSpan' to 'SourceRange'

@@ -24,8 +24,10 @@       | Just (IDType _ (Just CTFunction)) <- idType a       , indiciesRangeFree indicies = StFunction a1 s v (aMap fromIndex indicies) e2     -- nullary statement function-    statement (StExpressionAssign a1 s1 (ExpFunctionCall _ _ v@(ExpValue a s (ValVariable _)) Nothing) e2)-      = StFunction a1 s1 v (AList a s []) e2+    statement st@(StExpressionAssign a1 s1 (ExpFunctionCall _ _ v@(ExpValue a s (ValVariable _)) args) e2) =+        case alistList args of+          []  -> StFunction a1 s1 v (AList a s []) e2+          _:_ -> st     statement st                                      = st  disambiguateFunctionCalls :: Data a => Transform a ()@@ -34,16 +36,16 @@     trans = transformBi :: Data a => TransFunc Expression ProgramFile a     expression (ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies)       | Just (IDType _ (Just CTFunction)) <- idType a-      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies)       | Just (IDType _ (Just CTExternal)) <- idType a-      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies)       | Just (IDType _ (Just CTVariable)) <- idType a-      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies)       | Nothing <- idType a-      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies)     expression (ExpSubscript a1 s v@(ExpValue a _ (ValIntrinsic _)) indicies)       | Just (IDType _ (Just CTIntrinsic)) <- idType a-      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies)+      , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies)     expression e                                      = e  -- BEGIN: TODO STRICTLY TO BE REMOVED LATER TODO

@@ -210,10 +210,10 @@ applyGroupingToSubblocks f b   | BlStatement{} <- b =       error "Individual statements do not have subblocks. Must not occur."-  | BlIf a s l mn conds blocks         el <- b =-    BlIf a s l mn conds (map f blocks) el-  | BlCase a s l mn scrutinee conds blocks         el <- b =-    BlCase a s l mn scrutinee conds (map f blocks) el+  | BlIf a s l mn clauses elseBlock el <- b =+    BlIf a s l mn (fmap (\(cond, block) -> (cond, f block)) clauses) (fmap f elseBlock) el+  | BlCase a s l mn scrutinee clauses caseDefault el <- b =+    BlCase a s l mn scrutinee (map (\(range, block) -> (range, f block)) clauses) (fmap f caseDefault) el   | BlDo a s l n tl doSpec blocks     el <- b =     BlDo a s l n tl doSpec (f blocks) el   | BlDoWhile a s l n tl doSpec blocks     el <- b =

@@ -1,3 +1,18 @@+{-|+A convenience class for retrieving the first field of any constructor in a+datatype.++The primary usage for this class is generic derivation:++    data D a = D a () String deriving Generic+    instance FirstParameter (D a) a++Note that _the deriver does not check you are requesting a valid/safe instance._+Invalid instances propagate the error to runtime. Fixing this requires a lot+more type-level work. (The generic-lens library has a general solution, but it's+slow and memory-consuming.)+-}+ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FunctionalDependencies #-}

@@ -7,6 +7,7 @@ import Text.PrettyPrint import Data.Binary import Control.DeepSeq+import Data.List.NonEmpty ( NonEmpty(..) )  import Language.Fortran.Util.SecondParameter @@ -17,7 +18,7 @@   { posAbsoluteOffset   :: Int   , posColumn           :: Int   , posLine             :: Int-  , filePath            :: String+  , posFilePath         :: String   , posPragmaOffset     :: Maybe (Int, String)  -- ^ line-offset and filename as given by a pragma.   } deriving (Eq, Ord, Data, Typeable, Generic) @@ -32,7 +33,7 @@   { posAbsoluteOffset = 0   , posColumn = 1   , posLine = 1-  , filePath = ""+  , posFilePath = ""   , posPragmaOffset = Nothing   } @@ -42,14 +43,17 @@ -- | (line, column) number taking into account any specified line pragmas. apparentLineCol :: Position -> (Int, Int) apparentLineCol (Position _ c l _ (Just (o, _))) = (l + o, c)-apparentLineCol (Position _ c l _ _)             = (l, c)+apparentLineCol (Position _ c l _ Nothing)       = (l, c)  -- | Path of file taking into account any specified line pragmas. apparentFilePath :: Position -> String apparentFilePath p | Just (_, f) <- posPragmaOffset p = f-                   | otherwise                        = filePath p+                   | otherwise                        = posFilePath p -data SrcSpan = SrcSpan Position Position deriving (Eq, Ord, Typeable, Data, Generic)+data SrcSpan = SrcSpan+  { ssFrom :: Position+  , ssTo   :: Position+  } deriving (Eq, Ord, Typeable, Data, Generic)  instance Binary SrcSpan instance NFData SrcSpan@@ -75,9 +79,9 @@ initSrcSpan :: SrcSpan initSrcSpan = SrcSpan initPosition initPosition -instance Spanned SrcSpan where-  getSpan s = s-  setSpan _ _ = undefined+-- | Return the empty span at a given position (span between itself).+emptySpan :: Position -> SrcSpan+emptySpan pos = SrcSpan pos pos  class Spanned a where   getSpan :: a -> SrcSpan@@ -89,6 +93,10 @@   default setSpan :: (SecondParameter a SrcSpan) => SrcSpan -> a -> a   setSpan = setSecondParameter +instance Spanned SrcSpan where+  getSpan = id+  setSpan = const+ class (Spanned a, Spanned b) => SpannedPair a b where   getTransSpan :: a -> b -> SrcSpan @@ -99,6 +107,11 @@   getSpan [x]   = getSpan x   getSpan (x:xs) = getTransSpan x (last xs)   setSpan _ _ = error "Cannot set span to an array"++instance (Spanned a) => Spanned (NonEmpty a) where+  getSpan (x :| [])     = getSpan x+  getSpan (x :| (y:ys)) = getTransSpan x (last (y:ys))+  setSpan _ _ = error "Cannot set span to a non-empty list"  instance (Spanned a, Spanned b) => Spanned (a, Maybe b) where   getSpan (x, Just y) = getTransSpan x y

@@ -1,3 +1,18 @@+{-|+A convenience class for retrieving the first field of any constructor in a+datatype.++The primary usage for this class is generic derivation:++    data D a = D a () String deriving Generic+    instance SecondParameter (D a) ()++Note that _the deriver does not check you are requesting a valid/safe instance._+Invalid instances propagate the error to runtime. Fixing this requires a lot+more type-level work. (The generic-lens library has a general solution, but it's+slow and memory-consuming.)+-}+ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FunctionalDependencies #-}

@@ -0,0 +1,1 @@+      integer a

@@ -1,20 +0,0 @@-{-# LANGUAGE TypeApplications #-}--module Language.Fortran.AST.BozSpec where--import Test.Hspec--import Language.Fortran.AST.Boz-import Numeric.Natural ( Natural )--spec :: Spec-spec = do-  describe "BOZ literal constants" $ do-    it "parses a prefix and suffix BOZ constant identically" $ do-      parseBoz "z'123abc'" `shouldBe` parseBoz "'123abc'z"--    it "parses nonstandard X as Z (hex)" $ do-      parseBoz "x'09af'" `shouldBe` parseBoz "z'09af'"--    it "resolves a BOZ as a natural" $ do-      bozAsNatural @Natural (parseBoz "x'FF'") `shouldBe` 255

@@ -0,0 +1,48 @@+{-# LANGUAGE TypeApplications #-}++module Language.Fortran.AST.Literal.BozSpec where++import Test.Hspec++import Language.Fortran.AST.Literal.Boz+import Numeric.Natural ( Natural )+import Data.Int ( Int8, Int16, Int32 )++spec :: Spec+spec = do+  describe "BOZ literal constants" $ do+    it "parses single and double quotes identically" $ do+      parseBoz "o'017'" `shouldBe` parseBoz "o\"017\""++    it "parses postfix BOZ constant as explicitly nonconforming" $ do+      parseBoz "'010'b" `shouldBe` Boz BozPrefixB "010" Nonconforming++    it "parses a prefix and postfix BOZ constant identically (ignoring conformance flags)" $ do+      parseBoz "z'123abc'" `shouldBe` parseBoz "'123abc'z"++    it "parses nonstandard X as Z (hex)" $ do+      parseBoz "x'09af'" `shouldBe` parseBoz "z'09af'"++    it "resolves a BOZ as a natural" $ do+      bozAsNatural @Natural (parseBoz "x'00'") `shouldBe` 0+      bozAsNatural @Natural (parseBoz "x'7F'") `shouldBe` 127+      bozAsNatural @Natural (parseBoz "x'80'") `shouldBe` 128+      bozAsNatural @Natural (parseBoz "x'FF'") `shouldBe` 255++    it "resolves a BOZ as a two's complement integer (INT(1))" $ do+      bozAsTwosComp @Int8  (parseBoz "x'00'") `shouldBe` 0+      bozAsTwosComp @Int8  (parseBoz "x'7F'") `shouldBe` 127+      bozAsTwosComp @Int8  (parseBoz "x'80'") `shouldBe` (-128)+      bozAsTwosComp @Int8  (parseBoz "x'FF'") `shouldBe` (-1)++    it "resolves a BOZ as a two's complement integer (INT(2))" $ do+      bozAsTwosComp @Int16 (parseBoz "x'00'")   `shouldBe` 0+      bozAsTwosComp @Int16 (parseBoz "x'7F'")   `shouldBe` 127+      bozAsTwosComp @Int16 (parseBoz "x'80'")   `shouldBe` 128+      bozAsTwosComp @Int16 (parseBoz "x'FF'")   `shouldBe` 255+      bozAsTwosComp @Int16 (parseBoz "x'7FFF'") `shouldBe` 32767+      bozAsTwosComp @Int16 (parseBoz "x'8000'") `shouldBe` (-32768)+      bozAsTwosComp @Int16 (parseBoz "x'FFFF'") `shouldBe` (-1)++    it "resolves a BOZ as a two's complement integer (INT(4))" $ do+      bozAsTwosComp @Int32 (parseBoz "x'FFFFFFFF'") `shouldBe` (-1)

@@ -0,0 +1,29 @@+module Language.Fortran.AST.Literal.RealSpec where++import Prelude hiding ( exp )++import Test.Hspec++import Language.Fortran.AST.Literal.Real++spec :: Spec+spec = do+  describe "Fortran real literals" $ do+    it "parses & normalizes various well-formed valid real literals" $ do+      prl "1.0"    `shouldBe` rl "1.0" expDef+      prl "1.0e0"  `shouldBe` rl "1.0" expDef+      prl "10e-1"  `shouldBe` rl "10.0" (exp e "-1")+      prl "-1.e-1" `shouldBe` rl "-1.0" (exp e "-1")+      prl "+1.e+1" `shouldBe` rl "1.0" (exp e "1")+      prl "1.e1"   `shouldBe` rl "1.0" (exp e "1")+      prl ".1"     `shouldBe` rl "0.1" expDef+      prl "1.0d0"  `shouldBe` rl "1.0" (exp d "0")+      prl "1.0q0"  `shouldBe` rl "1.0" (exp q "0")+    where+      prl = parseRealLit+      rl = RealLit+      exp = Exponent+      expDef = Exponent ExpLetterE "0"+      e = ExpLetterE+      d = ExpLetterD+      q = ExpLetterQ

@@ -1,29 +0,0 @@-module Language.Fortran.AST.RealLitSpec where--import           Prelude hiding ( exp )--import           Test.Hspec--import           Language.Fortran.AST.RealLit--spec :: Spec-spec = do-  describe "Fortran real literals" $ do-    it "parses & normalizes various well-formed valid real literals" $ do-      prl "1.0"    `shouldBe` rl "1.0" expDef-      prl "1.0e0"  `shouldBe` rl "1.0" expDef-      prl "10e-1"  `shouldBe` rl "10.0" (exp e "-1")-      prl "-1.e-1" `shouldBe` rl "-1.0" (exp e "-1")-      prl "+1.e+1" `shouldBe` rl "1.0" (exp e "1")-      prl "1.e1"   `shouldBe` rl "1.0" (exp e "1")-      prl ".1"     `shouldBe` rl "0.1" expDef-      prl "1.0d0"  `shouldBe` rl "1.0" (exp d "0")-      prl "1.0q0"  `shouldBe` rl "1.0" (exp q "0")-    where-      prl = parseRealLit-      rl = RealLit-      exp = Exponent-      expDef = Exponent ExpLetterE "0"-      e = ExpLetterE-      d = ExpLetterD-      q = ExpLetterQ

@@ -207,7 +207,7 @@   , BlStatement () u Nothing (StExpressionAssign () u       (ExpValue () u (ValVariable "r"))       (ExpFunctionCall () u (ExpValue () u (ValVariable "f1"))-                            (Just $ AList () u [ Argument () u Nothing $ aintGen 1 ]))) ]+                            (AList () u [ Argument () u Nothing $ aintGen 1 ]))) ] ex4pu2 :: ProgramUnit () ex4pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing @@ -235,7 +235,19 @@ ex6pu2bs :: [a] ex6pu2bs = [] ex6pu2pu1 :: ProgramUnit ()-ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "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 (ArgExpr $ varGen "x")]))) ] (Just [ex5pu2pu1])+ex6pu2pu1 =+    PUFunction () u+        (Just $ TypeSpec () u TypeInteger Nothing)+        emptyPrefixSuffix+        "f1"+        (Just $ AList () u [ varGen "x"])+        Nothing+        [ BlStatement () u Nothing+            (StExpressionAssign () u (varGen "f1")+                (ExpFunctionCall () u (ExpValue () u (ValVariable "f1"))+                (AList () u [Argument () u Nothing (ArgExpr $ varGen "x")])+        )) ]+        (Just [ex5pu2pu1])  --parseF90 :: [String] -> ProgramFile A0 --parseF90 = resetSrcSpan . fortran90Parser . unlines

@@ -121,12 +121,12 @@        describe "CALL" $ do         it "parses 'CALL me" $ do-          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) Nothing+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) (aEmpty () u)           sParser "      CALL me" `shouldBe'` expectedSt          it "parses 'CALL me(baby)" $ do           let args = AList () u [ Argument () u Nothing $ ArgExpr $ varGen "baby" ]-          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) $ Just args+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) args           sParser "      CALL me(baby)" `shouldBe'` expectedSt        it "parses 'stop'" $ do

@@ -22,31 +22,35 @@                           "      include 'foo.f'",                           "      end"                          ]-        inc = "./test-data/f77-include"         name = "bar"-        pf = ProgramFile mi77' [pu]         puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")         st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")         expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")--        -- the expansion returns the span in the included file-        -- it should return the span at the inclusion-        foo = inc </> "foo.f"-        st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)-        declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)-        typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)-        blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)-        varGen' str =  ExpValue () blockSpan $ ValVariable str+        pf inc = ProgramFile mi77' [pu]+         where+          -- the expansion returns the span in the included file+          -- it should return the span at the inclusion+          foo = inc </> "foo.f"+          st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)+          declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)+          typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)+          blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)+          varGen' str =  ExpValue () blockSpan $ ValVariable str -        pu = PUMain () puSpan (Just name) blocks Nothing-        blocks = [bl1]-        decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing-        typeSpec = TypeSpec () typeSpan TypeInteger Nothing-        st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])-        bl1 = BlStatement () st1Span Nothing st1-        st1 = StInclude () st1Span ex (Just [bl2])-        ex = ExpValue () expSpan (ValString "foo.f")-        bl2 = BlStatement () declSpan Nothing st2+          pu = PUMain () puSpan (Just name) blocks Nothing+          blocks = [bl1]+          decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing+          typeSpec = TypeSpec () typeSpan TypeInteger Nothing+          st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])+          bl1 = BlStatement () st1Span Nothing st1+          st1 = StInclude () st1Span ex (Just [bl2])+          ex = ExpValue () expSpan (ValString "foo.f")+          bl2 = BlStatement () declSpan Nothing st2     it "includes some files and expands them" $ do+      let inc = "." </> "test-data" </> "f77-include"       pfParsed <- iParser [inc] source-      pfParsed `shouldBe` pf+      pfParsed `shouldBe` pf inc+    it "includes without a newline behave the same" $ do +      let inc = "." </> "test-data" </> "f77-include" </> "no-newline"+      pfParsed <- iParser [inc] source+      pfParsed `shouldBe` pf inc

@@ -11,6 +11,7 @@ import qualified Language.Fortran.Parser.Fixed.Lexer     as Fixed  import Prelude hiding ( exp )+import Data.List ( intercalate ) import qualified Data.ByteString.Char8 as B  parseWith :: FortranVersion -> Parse Fixed.AlexInput Fixed.Token a -> String -> a@@ -155,10 +156,14 @@         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 impEls1 = [ ImpElement () u 'a' Nothing+                      , ImpElement () u 'b' Nothing+                      , ImpElement () u 'c' Nothing ]+            impEls2 = [ ImpElement () u 'a' (Just 'z')+                      , ImpElement () u 'l' Nothing ]             sel = Selector () u (Just (intGen 30)) Nothing-            imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just sel)) $ AList () u impEls-            imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"]+            imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just sel)) $ AList () u impEls1+            imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u impEls2             st = StImplicit () u $ Just $ AList () u [imp1, imp2]         sParser "      implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st @@ -213,24 +218,29 @@       let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]           printStmt  = StPrint () u (ExpValue () u ValStar) printArgs           printBlock = BlStatement () u Nothing printStmt+          inner      = [printBlock]+       it "unlabelled" $ do-        let bl = BlIf () u Nothing Nothing [ Just valTrue, Nothing ] [[printBlock], [printBlock]]  Nothing-            src = unlines [ "      if (.true.) then ! comment if"-                          , "        print *, 'foo'"-                          , "      else ! comment else"-                          , "        print *, 'foo'"-                          , "       endif ! comment end"-                          ]+        let bl = BlIf () u Nothing Nothing ((valTrue, inner) :| []) (Just inner) Nothing+            src = intercalate "\n"+              [ "      if (.true.) then ! comment if"+              , "        print *, 'foo'"+              , "      else ! comment else"+              , "        print *, 'foo'"+              , "       endif ! comment end"+              ]         bParser src `shouldBe'` bl+       it "labelled" $ do         let label = Just . intGen-            bl = BlIf () u (label 10)  Nothing [Just valTrue, Nothing] [[printBlock], [printBlock]] (label 30)-            src = unlines [ "10    if (.true.) then ! comment if"-                          , "        print *, 'foo'"-                          , "20    else ! comment else"-                          , "        print *, 'foo'"-                          , "30     endif ! comment end"-                          ]+            bl = BlIf () u (label 10)  Nothing ((valTrue, inner) :| []) (Just inner) (label 30)+            src = intercalate "\n"+              [ "10    if (.true.) then ! comment if"+              , "        print *, 'foo'"+              , "20    else ! comment else"+              , "        print *, 'foo'"+              , "30     endif ! comment end"+              ]         bParser src `shouldBe'` bl      describe "Legacy Extensions" $ do@@ -308,7 +318,7 @@       it "parse special intrinsics to arguments" $ do         let blStmt stmt = BlStatement () u Nothing stmt             ext = blStmt $ StExternal () u $ AList () u [varGen "bar"]-            arg = Just . AList () u . pure . Argument () u Nothing . ArgExpr+            arg = AList () u . pure . Argument () u Nothing . ArgExpr             valBar = ExpFunctionCall () u (ExpValue () u (ValIntrinsic "%val"))                      $ arg $ varGen "baz"             call = blStmt $ StCall () u (varGen "bar") $ arg valBar

@@ -7,7 +7,7 @@ import Language.Fortran.Parser.Fixed.Lexer import Language.Fortran.Parser import Language.Fortran.Parser.Monad ( ParseState, getAlex, evalParse )-import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Boz import Language.Fortran.Version  import Data.List (isPrefixOf)

@@ -8,22 +8,22 @@  module Language.Fortran.Parser.Free.Common ( specFreeCommon ) where -import           TestUtil-import           Test.Hspec+import TestUtil+import Test.Hspec -import           Language.Fortran.AST-import           Language.Fortran.AST.RealLit+import Language.Fortran.AST+import Language.Fortran.AST.Literal.Real -specFreeCommon :: (String -> Statement A0) -> (String -> Expression A0) -> Spec-specFreeCommon sParser eParser =-  describe "Common Fortran 90+ tests" $ do+specFreeCommon :: (String -> Block A0) -> (String -> Statement A0) -> (String -> Expression A0) -> Spec+specFreeCommon bParser sParser eParser =+  describe "Common Fortran 90+ (free form) tests" $ do     describe "Literals" $ do       describe "Logical" $ do         it "parses logical literal without kind parameter" $ do           eParser ".true." `shouldBe'` valTrue          it "parses logical literal with kind parameter" $ do-          let kp = ExpValue () u (ValVariable "kind")+          let kp = KindParamVar () u "kind"           eParser ".false._kind" `shouldBe'` valFalse' kp          it "parses mixed-case logical literal" $ do@@ -35,11 +35,50 @@         let realLitExp r mkp = ExpValue () u (ValReal (parseRealLit r) mkp)         it "parses various REAL literals" $ do           eParser "1."      `shouldBe'` realLitExp "1."    Nothing-          eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (intGen 8))+          eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (KindParamInt () u "8"))          it "parses \"negative\" real literal (unary op)" $ do-          eParser "-1.0d-1_k8" `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just (varGen "k8")))+          let lit = "-1.0d-1_k8"+              kp  = KindParamVar () u "k8"+           in eParser lit `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just kp)) +      describe "Kind parameters" $ do+        it "parses var kind parameter with underscore" $ do+          let lit = "123_a_1"+              kp  = KindParamVar () u "a_1"+           in eParser lit `shouldBe'` ExpValue () u (ValInteger "123" (Just kp))++        it "fails to parse invalid kind parameter with underscore after numeric" $ do+          {- TODO can't test here because we push parse errors into runtime ones+          let lit = "123_4_8"+           in eParser lit `shouldBe'` undefined -- should error "last parsed was the 2nd underscore"+          -}+          pending++      -- Check various real/int literal forms and some kind parameters.+      describe "Complex" $ do+        let kp = Just . KindParamInt () u+        it "parses a complex literal via positive reals" $ do+          let cr = ComplexPartReal () u (parseRealLit "1.0E0") (kp "8")+              ci = ComplexPartReal () u (parseRealLit "0.2E1") Nothing+          eParser "(1.0E0_8, 0.2E1)" `shouldBe'` complexGen cr ci+        it "parses a complex literal via positive mixed lits" $ do+          let cr = ComplexPartInt  () u "1"                  Nothing+              ci = ComplexPartReal () u (parseRealLit "2D0") Nothing+          eParser "(1, 2D0)" `shouldBe'` complexGen cr ci+        it "parses a complex literal via negative ints" $ do+          let cr = ComplexPartInt  () u "-1" Nothing+              ci = ComplexPartInt  () u "-2" Nothing+          eParser "(-1, -2)" `shouldBe'` complexGen cr ci+        it "parses a complex literal via mixed sign mixed lits with kind parameters" $ do+          let cr = ComplexPartReal () u (parseRealLit "-1.2") (kp "8")+              ci = ComplexPartInt  () u "0"                    Nothing+          eParser "(-1.2_8, 0)" `shouldBe'` complexGen cr ci+        it "parses a complex literal via named constants" $ do+          let cr = ComplexPartNamed () u "a"+              ci = ComplexPartNamed () u "b_something"+          eParser "(a, b_something)" `shouldBe'` complexGen cr ci+     describe "Statement" $ do       describe "Declaration" $ do         it "parses scalar declaration with nonstandard kind param (non-CHAR)" $ do@@ -73,15 +112,116 @@       describe "Function call" $ do         it "parses a simple function call" $ do           let stStr    = "call double(i, i)"-              expected = StCall () u (varGen "double") (Just args)+              expected = StCall () u (varGen "double") args               args     = AList () u [arg, arg]               arg      = Argument () u Nothing (ArgExpr (varGen "i"))           sParser stStr `shouldBe'` expected          it "parses a parenthesized variable as a special indirect/copied variable reference" $ do           let stStr    = "call double((i), i)"-              expected = StCall () u (varGen "double") (Just args)+              expected = StCall () u (varGen "double") args               args     = AList () u [ genArg (ArgExprVar () u "i")                                     , genArg (ArgExpr (varGen "i")) ]               genArg   = Argument () u Nothing           sParser stStr `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+              impEls = [ ImpElement () u 'k' Nothing ]+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]+              st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit character (k)" `shouldBe'` st++        it "parses implicit with range" $ do+          let typeSpec = TypeSpec () u TypeLogical Nothing+              impEls = [ ImpElement () u 'x' (Just 'z') ]+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]+              st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit logical (x-z)" `shouldBe'` st++        it "parses implicit statement" $ do+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing+              typeSpec2 = TypeSpec () u TypeInteger Nothing+              impEls1 = [ ImpElement () u 's' Nothing, ImpElement () u 'a' Nothing ]+              impEls2 = [ ImpElement () u 'x' (Just 'z') ]+              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)+                         , ImpList () u typeSpec2 (fromList () impEls2) ]+              st = StImplicit () u (Just $ fromList () impLists)+          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st++    describe "Block" $ do+      describe "Case" $ do+        let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]+            printStmt = StPrint () u (ExpValue () u ValStar) . printArgs+            ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2+            ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing++        it "unlabelled case block (with inline comments to be stripped)" $ do+          let printBlock = BlStatement () u Nothing . printStmt+              clauses = [(ind2, [printBlock "foo"]), (ind3Plus, [printBlock "bar"])]+              caseDef = Just [printBlock "baz"]+          let src = unlines [ "select case (x) ! comment select"+                            , "! full line before first case (unrepresentable)"+                            , "case (2) ! comment case 1"+                            , "print *, 'foo'"+                            , "case (3:) ! comment case 2"+                            , "print *, 'bar'"+                            , "case default ! comment case 3"+                            , "print *, 'baz'"+                            , "end select ! comment end"+                            ]+              block = BlCase () u Nothing Nothing (varGen "x") clauses caseDef Nothing+          bParser src `shouldBe'` block++        it "labelled case block (with inline comments to be stripped" $ do+          let printBlock label = BlStatement () u (Just $ intGen label) . printStmt+              clauses = [(ind2, [printBlock 30 "foo"]), (ind3Plus, [printBlock 50 "bar"])]+              caseDef = Just [printBlock 70 "baz"]+          let src = unlines [ "10 mylabel: select case (x) ! comment select"+                            , "20 case (2) ! comment case 1"+                            , "30 print *, 'foo'"+                            , "40 case (3:) ! comment case 2"+                            , "50 print *, 'bar'"+                            , "60 case default ! comment case 3"+                            , "70 print *, 'baz'"+                            , "80 end select mylabel ! comment end"+                            ]+              block = BlCase () u+                             (Just $ intGen 10) (Just "mylabel") (varGen "x")+                             clauses caseDef+                             (Just $ intGen 80)+          bParser src `shouldBe'` block++      describe "If" $ do+        let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])+            inner   = [BlStatement () u Nothing stPrint]+        it "parser if block" $+          let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]+              ifBlock = BlIf () u Nothing Nothing ((valFalse, inner) :| []) Nothing Nothing+          in  bParser ifBlockSrc `shouldBe'` ifBlock++        it "parses named if block" $ do+          let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]+              ifBlock = BlIf () u Nothing (Just "mylabel") ((valTrue, inner) :| []) Nothing Nothing+          bParser ifBlockSrc `shouldBe'` ifBlock++        it "parses if-else block with inline comments (stripped)" $+          let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]+              ifBlock = BlIf () u Nothing Nothing ((valFalse, inner) :| []) (Just inner) Nothing+          in  bParser ifBlockSrc `shouldBe'` ifBlock++        it "parses logical if statement" $ do+          let assignment = StExpressionAssign () u (varGen "a") (varGen "b")+              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

@@ -57,26 +57,26 @@         sParser "use :: mod, sprod => prod, a => b" `shouldBe'` st        it "parses procedure (interface-name, attribute, proc-decl)" $ do-        let call = ExpFunctionCall () u (varGen "c") Nothing+        let call = ExpFunctionCall () u (varGen "c") (aEmpty () u)             st = StProcedure () u (Just (ProcInterfaceName () u (varGen "a")))-                                  (Just (AttrSave () u))+                                  (Just (AList () u [AttrSave () u]))                                   (AList () u [ProcDecl () u (varGen "b") (Just call)])         sParser "PROCEDURE(a), SAVE :: b => c()" `shouldBe'` st        it "parses procedure (class-star, bind-name, proc-decls)" $ do-        let call = ExpFunctionCall () u (varGen "c") Nothing+        let call = ExpFunctionCall () u (varGen "c") (aEmpty () u)             clas = TypeSpec () u ClassStar Nothing             st = StProcedure () u (Just (ProcInterfaceType () u clas))-                                  (Just (AttrSuffix () u (SfxBind () u (Just (ExpValue () u (ValString "e"))))))+                                  (Just (AList () u [AttrSuffix () u (SfxBind () u (Just (ExpValue () u (ValString "e"))))]))                                   (AList () u [ProcDecl () u (varGen "b") (Just call)                                               ,ProcDecl () u (varGen "d") (Just call)])         sParser "PROCEDURE(CLASS(*)), BIND(C, NAME=\"e\") :: b => c(), d => c()" `shouldBe'` st        it "parses procedure (class-custom, bind, proc-decls)" $ do-        let call = ExpFunctionCall () u (varGen "c") Nothing+        let call = ExpFunctionCall () u (varGen "c") (aEmpty () u)             clas = TypeSpec () u (ClassCustom "e") Nothing             st = StProcedure () u (Just (ProcInterfaceType () u clas))-                                  (Just (AttrSuffix () u (SfxBind () u Nothing)))+                                  (Just (AList () u [AttrSuffix () u (SfxBind () u Nothing)]))                                   (AList () u [ProcDecl () u (varGen "b") (Just call)                                               ,ProcDecl () u (varGen "d") (Just call)])         sParser "PROCEDURE(CLASS(e)), BIND(C) :: b => c(), d => c()" `shouldBe'` st@@ -173,4 +173,4 @@             expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)         bParser text `shouldBe'` expected -    specFreeCommon sParser eParser+    specFreeCommon bParser sParser eParser

@@ -7,6 +7,7 @@ import Language.Fortran.Parser.Free.Common  import Language.Fortran.AST+import Language.Fortran.AST.Literal.Real ( parseRealLit ) import Language.Fortran.Version import Language.Fortran.Parser import Language.Fortran.Parser.Monad ( Parse )@@ -135,13 +136,6 @@         in fParser fStr `shouldBe'` expected      describe "Expression" $ do-      it "parses logical literal without kind parameter" $ do-        eParser ".true." `shouldBe'` valTrue--      it "parses logical literal with kind parameter" $ do-        let kp = ExpValue () u (ValVariable "kind")-        eParser ".false._kind" `shouldBe'` valFalse' kp-       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@@ -217,7 +211,8 @@        it "parses declaration with initialisation" $         let typeSpec = TypeSpec () u TypeComplex Nothing-            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))+            init' = complexGen (ComplexPartInt () u "24" Nothing)+                               (ComplexPartReal () u (parseRealLit "42.0") Nothing)             declarators = AList () u               [ declVariable () u (varGen "x") Nothing (Just init') ]             expected = StDeclaration () u typeSpec Nothing declarators@@ -277,35 +272,6 @@             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-              impEls = [ ImpCharacter () u "k" ]-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]-              st = StImplicit () u (Just $ fromList () impLists)-          sParser "implicit character (k)" `shouldBe'` st--        it "parses implicit with range" $ do-          let typeSpec = TypeSpec () u TypeLogical Nothing-              impEls = [ ImpRange () u "x" "z" ]-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]-              st = StImplicit () u (Just $ fromList () impLists)-          sParser "implicit logical (x-z)" `shouldBe'` st--        it "parses implicit statement" $ do-          let typeSpec1 = TypeSpec () u TypeCharacter Nothing-              typeSpec2 = TypeSpec () u TypeInteger Nothing-              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]-              impEls2 = [ ImpRange () u "x" "z" ]-              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)-                         , ImpList () u typeSpec2 (fromList () impEls2) ]-              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" ]@@ -432,72 +398,6 @@           it "parses endwhere statement" $             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing -    describe "If" $ do-      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])-      it "parser if block" $-        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]-        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing--      it "parses named if block" $ do-        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing-        bParser ifBlockSrc `shouldBe'` ifBlock--      it "parses if-else block with inline comments (stripped)" $-        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]-        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing--      it "parses logical if statement" $ do-        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")-            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-      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]-          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs-          printBlock = BlStatement () u Nothing . printStmt-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing-          conds = [Just ind2, Just ind3Plus, Nothing]-      it "unlabelled case block (with inline comments to be stripped)" $ do-        let src = unlines [ "select case (x) ! comment select"-                          , "! full line before first case (unrepresentable)"-                          , "case (2) ! comment case 1"-                          , "print *, 'foo'"-                          , "case (3:) ! comment case 2"-                          , "print *, 'bar'"-                          , "case default ! comment case 3"-                          , "print *, 'baz'"-                          , "end select ! comment end"-                          ]-            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]-            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing-        bParser src `shouldBe'` block-      it "labelled case block (with inline comments to be stripped" $ do-        let src = unlines [ "10 mylabel: select case (x) ! comment select"-                          , "20 case (2) ! comment case 1"-                          , "30 print *, 'foo'"-                          , "40 case (3:) ! comment case 2"-                          , "50 print *, 'bar'"-                          , "60 case default ! comment case 3"-                          , "70 print *, 'baz'"-                          , "80 end select mylabel ! comment end"-                          ]-            blocks = (fmap . fmap)-                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)-                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]-            block = BlCase () u-                           (Just $ intGen 10) (Just "mylabel") (varGen "x")-                           conds blocks-                           (Just $ intGen 80)-        bParser src `shouldBe'` block-     describe "Do" $ do       it "parses do statement with label" $ do         let assign = StExpressionAssign () u (varGen "i") (intGen 0)@@ -583,4 +483,4 @@           st = StUse () u (varGen "stats_lib") Nothing Exclusive (Just onlys)       sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st -    specFreeCommon sParser eParser+    specFreeCommon bParser sParser eParser

@@ -7,6 +7,7 @@ import Language.Fortran.Parser.Free.Common  import Language.Fortran.AST+import Language.Fortran.AST.Literal.Real ( parseRealLit ) import Language.Fortran.Version import Language.Fortran.Parser import Language.Fortran.Parser.Monad ( Parse )@@ -152,13 +153,6 @@         fParser fStr `shouldBe'` expected      describe "Expression" $ do-      it "parses logical literal without kind parameter" $ do-        eParser ".true." `shouldBe'` valTrue--      it "parses logical literal with kind parameter" $ do-        let kp = ExpValue () u (ValVariable "kind")-        eParser ".false._kind" `shouldBe'` valFalse' kp-       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@@ -240,7 +234,8 @@        it "parses declaration with initialisation" $ do         let typeSpec = TypeSpec () u TypeComplex Nothing-            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))+            init' = complexGen (ComplexPartInt () u "24" Nothing)+                               (ComplexPartReal () u (parseRealLit "42.0") Nothing)             declarators = AList () u               [ declVariable () u (varGen "x") Nothing (Just init') ]             expected = StDeclaration () u typeSpec Nothing declarators@@ -303,17 +298,17 @@         sParser "parameter (x = 10, y = 20)" `shouldBe'` expected        describe "FORALL blocks" $ do-        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)-            tripletSpecList = [("i", intGen 1, varGen "n", stride)]+        let stride          = ExpBinary () u NE (varGen "i") (intGen 2)+            tripletSpecList = ForallHeaderPart () u "i" (intGen 1) (varGen "n") (Just stride)          it "parses basic FORALL blocks" $ do           let stStr = "FORALL (I=1:N, I /= 2)"-              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)+              expected = StForall () u Nothing (ForallHeader () u [tripletSpecList] Nothing)           sParser stStr `shouldBe'` expected        describe "FORALL statements" $ do-        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)-            tripletSpecList = [("i", intGen 1, varGen "n", stride)]+        let stride          = ExpBinary () u NE (varGen "i") (intGen 2)+            tripletSpecList = ForallHeaderPart () u "i" (intGen 1) (varGen "n") (Just stride)         --let varI = IxSingle () u Nothing (varGen "i")         --let expSub1 = ExpSubscript () u (varGen "a") (AList () u [varI, varI])         --let expSub2 = ExpSubscript () u (varGen "x") (AList () u [varI])@@ -321,7 +316,7 @@          it "parses basic FORALL statements" $ do           let stStr = "FORALL (I=1:N, I /= 2)" -- A(I,I) = X(I)"-              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)-- eAssign+              expected = StForall () u Nothing (ForallHeader () u [tripletSpecList] Nothing) -- eAssign           sParser stStr `shouldBe'` expected        describe "ENDFORALL statements" $ do@@ -335,35 +330,6 @@               expected = StEndForall () u $ Just "a"           sParser stStr `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-              impEls = [ ImpCharacter () u "k" ]-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]-              st = StImplicit () u (Just $ fromList () impLists)-          sParser "implicit character (k)" `shouldBe'` st--        it "parses implicit with range" $ do-          let typeSpec = TypeSpec () u TypeLogical Nothing-              impEls = [ ImpRange () u "x" "z" ]-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]-              st = StImplicit () u (Just $ fromList () impLists)-          sParser "implicit logical (x-z)" `shouldBe'` st--        it "parses implicit statement" $ do-          let typeSpec1 = TypeSpec () u TypeCharacter Nothing-              typeSpec2 = TypeSpec () u TypeInteger Nothing-              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]-              impEls2 = [ ImpRange () u "x" "z" ]-              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)-                         , ImpList () u typeSpec2 (fromList () impEls2) ]-              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" ]@@ -487,72 +453,6 @@           it "parses endwhere statement" $             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing -    describe "If" $ do-      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])-      it "parser if block" $-        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]-        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing--      it "parses named if block" $ do-        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing-        bParser ifBlockSrc `shouldBe'` ifBlock--      it "parses if-else block with inline comments (stripped)" $-        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]-        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing--      it "parses logical if statement" $ do-        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")-            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-      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]-          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs-          printBlock = BlStatement () u Nothing . printStmt-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing-          conds = [Just ind2, Just ind3Plus, Nothing]-      it "unlabelled case block (with inline comments to be stripped)" $ do-        let src = unlines [ "select case (x) ! comment select"-                          , "! full line before first case (unrepresentable)"-                          , "case (2) ! comment case 1"-                          , "print *, 'foo'"-                          , "case (3:) ! comment case 2"-                          , "print *, 'bar'"-                          , "case default ! comment case 3"-                          , "print *, 'baz'"-                          , "end select ! comment end"-                          ]-            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]-            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing-        bParser src `shouldBe'` block-      it "labelled case block (with inline comments to be stripped" $ do-        let src = unlines [ "10 mylabel: select case (x) ! comment select"-                          , "20 case (2) ! comment case 1"-                          , "30 print *, 'foo'"-                          , "40 case (3:) ! comment case 2"-                          , "50 print *, 'bar'"-                          , "60 case default ! comment case 3"-                          , "70 print *, 'baz'"-                          , "80 end select mylabel ! comment end"-                          ]-            blocks = (fmap . fmap)-                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)-                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]-            block = BlCase () u-                           (Just $ intGen 10) (Just "mylabel") (varGen "x")-                           conds blocks-                           (Just $ intGen 80)-        bParser src `shouldBe'` block-     describe "Do" $ do       it "parses do statement with label" $ do         let assign = StExpressionAssign () u (varGen "i") (intGen 0)@@ -652,4 +552,4 @@           st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)       sParser "integer, volatile :: a, b" `shouldBe'` st -    specFreeCommon sParser eParser+    specFreeCommon bParser sParser eParser

@@ -6,7 +6,7 @@ import Language.Fortran.Parser.Free.Lexer ( Token(..), lexer' ) import Language.Fortran.Parser ( collectTokens ) import Language.Fortran.Parser ( initParseStateFree )-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real import Language.Fortran.Version import Language.Fortran.Util.Position (SrcSpan) 

@@ -10,7 +10,7 @@ import Data.Maybe (catMaybes)  import Language.Fortran.AST as LFA-import Language.Fortran.AST.Boz+import Language.Fortran.AST.Literal.Boz import Language.Fortran.Version import Language.Fortran.PrettyPrint @@ -70,9 +70,9 @@     describe "Implicit list" $       it "prints mixed implicit lists" $ do         let typ = TypeSpec () u TypeInteger Nothing-        let impEls = [ ImpCharacter () u "x"-                     , ImpRange () u "a" "z"-                     , ImpCharacter () u "o" ]+        let impEls = [ ImpElement () u 'x' Nothing+                     , ImpElement () u 'a' (Just 'z')+                     , ImpElement () u 'o' Nothing ]         let impList = ImpList () u typ (AList () u impEls)         pprint Fortran90 impList Nothing `shouldBe` "integer (x, a-z, o)" @@ -104,14 +104,23 @@         pprint Fortran77 lit Nothing `shouldBe` ".true."        it "prints logical literal with kind parameter (>=F90)" $ do-        let lit    = ValLogical False (Just kpExpr)-            kpExpr = intGen 8+        let lit = ValLogical False (Just kp)+            kp  = KindParamInt () u "8"         pprint Fortran90 lit Nothing `shouldBe` ".false._8"        it "prints BOZ constant with prefix" $ do-        let lit = ValBoz $ Boz BozPrefixZ "123abc"+        let lit = ValBoz $ Boz (BozPrefixZ Conforming) "123abc" Conforming         pprint Fortran90 lit Nothing `shouldBe` "z'123abc'" +      -- Note that we can't test printing nonconforming BOZs, because the+      -- 'Boz.prettyBoz' that gets used in the 'Pretty' instance refuses to+      -- pretty print nonconforming syntax.+      {-+      it "prints BOZ constant with nonconforming postfix" $ do+        let lit = ValBoz $ Boz (BozPrefixZ Nonconforming) "123abc" Nonconforming+        pprint Fortran90 lit Nothing `shouldBe` "'123abc'x"+      -}+     describe "Statement" $ do       describe "Declaration" $ do         it "prints 90 style with attributes" $ do@@ -367,18 +376,19 @@        describe "If" $ do         it "prints vanilla structured if" $ do-          let bl = BlIf () u Nothing Nothing [ Just valTrue ] [ body ] Nothing-          let expect = unlines [ "if (.true.) then"+          let bl = BlIf () u Nothing Nothing clauses Nothing Nothing+              clauses = (valTrue, body) :| []+              expect = unlines [ "if (.true.) then"                                , "print *, i"                                , "i = (i - 1)"                                , "end if" ]           pprint Fortran90 bl Nothing `shouldBe` text expect          it "prints multiple condition named structured if" $ do-          let conds = [ Just valTrue, Just valFalse, Just valTrue, Nothing ]-          let bodies = replicate 4 body-          let bl = BlIf () u Nothing (Just "mistral") conds bodies Nothing-          let expect = unlines [ "mistral: if (.true.) then"+          let clauses = (valTrue, body) :| [ (valFalse, body), (valTrue, body) ]+              elseBlock = Just body+              bl = BlIf () u Nothing (Just "mistral") clauses elseBlock Nothing+              expect = unlines [ "mistral: if (.true.) then"                                , "  print *, i"                                , "  i = (i - 1)"                                , "else if (.false.) then"@@ -394,35 +404,14 @@           pprint Fortran90 bl (Just 0) `shouldBe` text expect        describe "Case" $-        it "prints complicated structured if" $ do-          let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing-          let cases = [ Just (AList () u [range])-                      , Just (AList () u [ IxSingle () u Nothing (intGen 7) ])-                      , Nothing ]-          let bodies = replicate 3 body-          let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42))-          let expect = unlines [ "select case (x)"-                               , "  case (2:4)"-                               , "    print *, i"-                               , "    i = (i - 1)"-                               , "  case (7)"-                               , "    print *, i"-                               , "    i = (i - 1)"-                               , "  case default"-                               , "    print *, i"-                               , "    i = (i - 1)"-                               , "42 end select" ]-          pprint Fortran90 bl (Just 0) `shouldBe` text expect--      describe "Case" $         it "prints multi-case select case construct" $ do           let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing-          let cases = [ Just (AList () u [range])-                      , Just (AList () u [ IxSingle () u Nothing (intGen 7) ])-                      , Nothing ]-          let bodies = replicate 3 body-          let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42))-          let expect = unlines [ "select case (x)"+              clauses = [ ( AList () u [range] , body )+                        , ( AList () u [ IxSingle () u Nothing (intGen 7) ] , body )+                        ]+              caseDef = Just body+              bl = BlCase () u Nothing Nothing (varGen "x") clauses caseDef (Just (intGen 42))+              expect = unlines [ "select case (x)"                                , "  case (2:4)"                                , "    print *, i"                                , "    i = (i - 1)"

@@ -80,7 +80,7 @@   , BlStatement () u Nothing (StExpressionAssign () u       (ExpSubscript () u (varGen "d") (AList () u [ IxSingle () u Nothing $ varGen "x" ])) (intGen 1))   , BlStatement () u Nothing (StExpressionAssign () u-      (ExpFunctionCall () u (varGen "e") Nothing) (intGen 1)) ]+      (ExpFunctionCall () u (varGen "e") (aEmpty () u)) (intGen 1)) ]  expectedEx1 :: ProgramFile () expectedEx1 = ProgramFile mi77 [ expectedEx1pu1 ]@@ -155,7 +155,7 @@           (intGen 1)           (ExpFunctionCall () u             (ExpValue () u $ ValVariable "f")-            (Just $ AList () u [ Argument () u Nothing (aintGen 1) ])))) ]+            (AList () u [ Argument () u Nothing (aintGen 1) ])))) ]   ex3 :: ProgramFile ()@@ -191,9 +191,9 @@   , BlStatement () u Nothing       (StExpressionAssign () u (varGen "i")         (ExpFunctionCall () u (ExpValue () u $ ValIntrinsic "abs")-          (Just $ AList () u [ Argument () u Nothing+          (AList () u [ Argument () u Nothing             (ArgExpr $ ExpFunctionCall () u (ExpValue () u $ ValVariable "f")-                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ])) ]))) ]+                                  (AList () u [ Argument () u Nothing (aintGen 1) ])) ]))) ]   {-@@ -228,7 +228,7 @@   , BlStatement () u Nothing       (StExpressionAssign () u (varGen "a")        (ExpFunctionCall () u (ExpValue () u $ ValVariable "f")-                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]+                                  (AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]  {- - program Main@@ -260,7 +260,7 @@   , BlStatement () u Nothing       (StExpressionAssign () u (varGen "a")        (ExpFunctionCall () u (ExpValue () u $ ValVariable "f")-                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]+                                  (AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]  {- - program Main

@@ -61,8 +61,8 @@  exampleComment :: Block () exampleComment = BlComment () u $ Comment "comment"-exampleHeader :: ForallHeader a-exampleHeader = ForallHeader [] Nothing+exampleHeader :: ForallHeader ()+exampleHeader = ForallHeader () u [] Nothing exampleForall :: Maybe String -> Maybe String -> ProgramFile () exampleForall name nameEnd = buildExampleProgram "forall"   [ BlStatement () u Nothing $ StForall () u name exampleHeader@@ -208,7 +208,7 @@   , "      end" ] ifInnerBlockSpan :: (String -> Block A0) -> SimpleSpan ifInnerBlockSpan p =-  let BlIf _ _ _ _ _ bs _ = p ifInnerBlockSpanRaw-  in  simplifySpan $ getSpan bs+  let BlIf _ _ _ _ clauses elseBlock _ = p ifInnerBlockSpanRaw+  in  simplifySpan $ getSpan (fmap snd clauses, elseBlock) expectedIfInnerBlockSpan :: SimpleSpan expectedIfInnerBlockSpan = (3, 1, 5, 35)

@@ -5,7 +5,8 @@ import Data.Generics.Uniplate.Data  import Language.Fortran.AST-import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Complex import Language.Fortran.Version import Language.Fortran.Util.Position @@ -31,7 +32,7 @@ valTrue  = ExpValue () u $ ValLogical True  Nothing valFalse = ExpValue () u $ ValLogical False Nothing -valTrue', valFalse' :: Expression () -> Expression ()+valTrue', valFalse' :: KindParam () -> Expression () valTrue'  kp = ExpValue () u $ ValLogical True  (Just kp) valFalse' kp = ExpValue () u $ ValLogical False (Just kp) @@ -52,6 +53,9 @@  realGen :: (Fractional a, Show a) => a -> Expression () realGen i = ExpValue () u $ ValReal (parseRealLit (show i)) Nothing++complexGen :: ComplexPart () -> ComplexPart () -> Expression ()+complexGen cr ci = ExpValue () u $ ValComplex $ ComplexLit () u cr ci  strGen :: String -> Expression () strGen str = ExpValue () u $ ValString str