diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -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 @@ 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 diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs --- a/src/Language/Fortran/AST.hs +++ b/src/Language/Fortran/AST.hs @@ -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) diff --git a/src/Language/Fortran/AST/AList.hs b/src/Language/Fortran/AST/AList.hs --- a/src/Language/Fortran/AST/AList.hs +++ b/src/Language/Fortran/AST/AList.hs @@ -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) + +-} diff --git a/src/Language/Fortran/AST/Annotated.hs b/src/Language/Fortran/AST/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Annotated.hs @@ -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 diff --git a/src/Language/Fortran/AST/Boz.hs b/src/Language/Fortran/AST/Boz.hs deleted file mode 100644 --- a/src/Language/Fortran/AST/Boz.hs +++ /dev/null @@ -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" diff --git a/src/Language/Fortran/AST/Common.hs b/src/Language/Fortran/AST/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Common.hs @@ -0,0 +1,3 @@ +module Language.Fortran.AST.Common where + +type Name = String diff --git a/src/Language/Fortran/AST/Literal.hs b/src/Language/Fortran/AST/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Literal.hs @@ -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) diff --git a/src/Language/Fortran/AST/Literal/Boz.hs b/src/Language/Fortran/AST/Literal/Boz.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Literal/Boz.hs @@ -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 diff --git a/src/Language/Fortran/AST/Literal/Complex.hs b/src/Language/Fortran/AST/Literal/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Literal/Complex.hs @@ -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) diff --git a/src/Language/Fortran/AST/Literal/Real.hs b/src/Language/Fortran/AST/Literal/Real.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Literal/Real.hs @@ -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] diff --git a/src/Language/Fortran/AST/RealLit.hs b/src/Language/Fortran/AST/RealLit.hs deleted file mode 100644 --- a/src/Language/Fortran/AST/RealLit.hs +++ /dev/null @@ -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] diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs --- a/src/Language/Fortran/Analysis.hs +++ b/src/Language/Fortran/Analysis.hs @@ -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. diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs --- a/src/Language/Fortran/Analysis/BBlocks.hs +++ b/src/Language/Fortran/Analysis/BBlocks.hs @@ -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" _ -> "" -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 = "" diff --git a/src/Language/Fortran/Analysis/DataFlow.hs b/src/Language/Fortran/Analysis/DataFlow.hs --- a/src/Language/Fortran/Analysis/DataFlow.hs +++ b/src/Language/Fortran/Analysis/DataFlow.hs @@ -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 diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs --- a/src/Language/Fortran/Analysis/SemanticTypes.hs +++ b/src/Language/Fortran/Analysis/SemanticTypes.hs @@ -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. -- diff --git a/src/Language/Fortran/Analysis/Types.hs b/src/Language/Fortran/Analysis/Types.hs --- a/src/Language/Fortran/Analysis/Types.hs +++ b/src/Language/Fortran/Analysis/Types.hs @@ -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 diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs --- a/src/Language/Fortran/Parser.hs +++ b/src/Language/Fortran/Parser.hs @@ -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 diff --git a/src/Language/Fortran/Parser/Fixed/Fortran66.y b/src/Language/Fortran/Parser/Fixed/Fortran66.y --- a/src/Language/Fortran/Parser/Fixed/Fortran66.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran66.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Fixed/Fortran77.y b/src/Language/Fortran/Parser/Fixed/Fortran77.y --- a/src/Language/Fortran/Parser/Fixed/Fortran77.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran77.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Fixed/Lexer.x b/src/Language/Fortran/Parser/Fixed/Lexer.x --- a/src/Language/Fortran/Parser/Fixed/Lexer.x +++ b/src/Language/Fortran/Parser/Fixed/Lexer.x @@ -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 diff --git a/src/Language/Fortran/Parser/Fixed/Utils.hs b/src/Language/Fortran/Parser/Fixed/Utils.hs --- a/src/Language/Fortran/Parser/Fixed/Utils.hs +++ b/src/Language/Fortran/Parser/Fixed/Utils.hs @@ -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 diff --git a/src/Language/Fortran/Parser/Free/Fortran2003.y b/src/Language/Fortran/Parser/Free/Fortran2003.y --- a/src/Language/Fortran/Parser/Free/Fortran2003.y +++ b/src/Language/Fortran/Parser/Free/Fortran2003.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Free/Fortran95.y b/src/Language/Fortran/Parser/Free/Fortran95.y --- a/src/Language/Fortran/Parser/Free/Fortran95.y +++ b/src/Language/Fortran/Parser/Free/Fortran95.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Free/Lexer.x b/src/Language/Fortran/Parser/Free/Lexer.x --- a/src/Language/Fortran/Parser/Free/Lexer.x +++ b/src/Language/Fortran/Parser/Free/Lexer.x @@ -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 diff --git a/src/Language/Fortran/Parser/LexerUtils.hs b/src/Language/Fortran/Parser/LexerUtils.hs --- a/src/Language/Fortran/Parser/LexerUtils.hs +++ b/src/Language/Fortran/Parser/LexerUtils.hs @@ -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). diff --git a/src/Language/Fortran/Parser/ParserUtils.hs b/src/Language/Fortran/Parser/ParserUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Parser/ParserUtils.hs @@ -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 diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -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) diff --git a/src/Language/Fortran/Rewriter.hs b/src/Language/Fortran/Rewriter.hs --- a/src/Language/Fortran/Rewriter.hs +++ b/src/Language/Fortran/Rewriter.hs @@ -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' diff --git a/src/Language/Fortran/Transformation/Disambiguation/Function.hs b/src/Language/Fortran/Transformation/Disambiguation/Function.hs --- a/src/Language/Fortran/Transformation/Disambiguation/Function.hs +++ b/src/Language/Fortran/Transformation/Disambiguation/Function.hs @@ -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 diff --git a/src/Language/Fortran/Transformation/Grouping.hs b/src/Language/Fortran/Transformation/Grouping.hs --- a/src/Language/Fortran/Transformation/Grouping.hs +++ b/src/Language/Fortran/Transformation/Grouping.hs @@ -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 = diff --git a/src/Language/Fortran/Util/FirstParameter.hs b/src/Language/Fortran/Util/FirstParameter.hs --- a/src/Language/Fortran/Util/FirstParameter.hs +++ b/src/Language/Fortran/Util/FirstParameter.hs @@ -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 #-} diff --git a/src/Language/Fortran/Util/Position.hs b/src/Language/Fortran/Util/Position.hs --- a/src/Language/Fortran/Util/Position.hs +++ b/src/Language/Fortran/Util/Position.hs @@ -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 diff --git a/src/Language/Fortran/Util/SecondParameter.hs b/src/Language/Fortran/Util/SecondParameter.hs --- a/src/Language/Fortran/Util/SecondParameter.hs +++ b/src/Language/Fortran/Util/SecondParameter.hs @@ -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 #-} diff --git a/test-data/f77-include/no-newline/foo.f b/test-data/f77-include/no-newline/foo.f new file mode 100644 --- /dev/null +++ b/test-data/f77-include/no-newline/foo.f @@ -0,0 +1,1 @@ + integer a diff --git a/test/Language/Fortran/AST/BozSpec.hs b/test/Language/Fortran/AST/BozSpec.hs deleted file mode 100644 --- a/test/Language/Fortran/AST/BozSpec.hs +++ /dev/null @@ -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 diff --git a/test/Language/Fortran/AST/Literal/BozSpec.hs b/test/Language/Fortran/AST/Literal/BozSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/AST/Literal/BozSpec.hs @@ -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) diff --git a/test/Language/Fortran/AST/Literal/RealSpec.hs b/test/Language/Fortran/AST/Literal/RealSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/AST/Literal/RealSpec.hs @@ -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 diff --git a/test/Language/Fortran/AST/RealLitSpec.hs b/test/Language/Fortran/AST/RealLitSpec.hs deleted file mode 100644 --- a/test/Language/Fortran/AST/RealLitSpec.hs +++ /dev/null @@ -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 diff --git a/test/Language/Fortran/Analysis/RenamingSpec.hs b/test/Language/Fortran/Analysis/RenamingSpec.hs --- a/test/Language/Fortran/Analysis/RenamingSpec.hs +++ b/test/Language/Fortran/Analysis/RenamingSpec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs --- a/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs --- a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs @@ -22,31 +22,35 @@ " include 'foo.f'", " end" ] - inc = "./test-data/f77-include" name = "bar" - pf = ProgramFile mi77' [pu] puSpan = makeSrcR (6,7,1,"") (48,9,3,"") st1Span = makeSrcR (24,7,2,"") (38,21,2,"") expSpan = makeSrcR (32,15,2,"") (38,21,2,"") - - -- 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 diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs --- a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fixed/LexerSpec.hs b/test/Language/Fortran/Parser/Fixed/LexerSpec.hs --- a/test/Language/Fortran/Parser/Fixed/LexerSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/LexerSpec.hs @@ -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) diff --git a/test/Language/Fortran/Parser/Free/Common.hs b/test/Language/Fortran/Parser/Free/Common.hs --- a/test/Language/Fortran/Parser/Free/Common.hs +++ b/test/Language/Fortran/Parser/Free/Common.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Free/LexerSpec.hs b/test/Language/Fortran/Parser/Free/LexerSpec.hs --- a/test/Language/Fortran/Parser/Free/LexerSpec.hs +++ b/test/Language/Fortran/Parser/Free/LexerSpec.hs @@ -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) diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs --- a/test/Language/Fortran/PrettyPrintSpec.hs +++ b/test/Language/Fortran/PrettyPrintSpec.hs @@ -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)" diff --git a/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs --- a/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +++ b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs @@ -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 diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs --- a/test/Language/Fortran/Transformation/GroupingSpec.hs +++ b/test/Language/Fortran/Transformation/GroupingSpec.hs @@ -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) diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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