diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,32 @@ +### 0.3.0 (June 13, 2019) + +* Add partial Fortran2003 support. +* Introduce datatype for BBGr instead of prior type alias for Gr. + * Now split into three fields: bbgrGr, bbgrEntries and bbgrExits + * May require refactoring of code to use bbgrGr field where a Gr was expected before. +* Introduce pragmaOffset field for Position, allowing pragmas to specify an apparent file and line-number. + * May require refactoring of code that uses the Position constructor. + * Fifth field is Maybe (Int, String), containing a line-offset and a target filename when present. + * It's designed such that most Position-based transformations are not affected by the pragmaOffset. + * They may need to preserve the field, though, as it passes through functions. + * Default value is 'Nothing'. +* Add --show-flows-to/--show-flows-from features + * Visualise the dataflow use/def chains using GraphViz. +* Add --show-block-numbers feature. + * Allows user to get AST-block numbers easily in order to use them with the above visualisation features. +* Fix several bugs with dataflow analysis that had accumulated. +* Eliminate StContinue and StEnddo are eliminated during GroupLabeledDo transformations. + * To be consistent with unlabeled Do. +* Parse and discard C-comments as a convenience feature for when fortran-src must interact with the output of C preprocessors that insert spurious comments. +* Add type propagation into type analysis, annotating every expression with a type. + * Additional interface: analyseTypesWithEnv to access a list of type errors found. +* Add dimensional information to CTArray and length/kind to TypeCharacter. +* Stricter checking of the grouping transform - if any statements that should be grouped are not grouped, raise an error. +* Support pragmas that alter the current 'filename and position' tracker, often used by preprocessors to help pinpoint original code locations. + * Uses a relative offset field called 'posPragmaOffset' so that relative measures continue to function correctly. +* Add constant propagation / parameter variable analysis. +* Add -c feature to compile 'fsmod files' with renaming and type info. + ### 0.2.1.1 (May 18, 2018) * Extend Fortran 95 support diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,10 +1,12 @@ -Copyright (c) 2015, Mistral Contrastin +Copyright (c) 2015-2019: Mistral Contrastin, Matthew Danish, Dominic Orchard and Andrew Rice +Additional thanks for contributions from: Anthony Burzillo, Azeem Bande-Ali, Ben Moon, Bradley Hardy, Eric Seidel, Harry Clarke, Jason Xu, Lukasz Kolodziejczyk, TravelTissues and Vaibhav Yenamandra + Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at - http://www.apache.org/licenses/LICENSE-2.0 + http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -1,135 +1,148 @@ --- Initial Language.Fortran.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ +cabal-version: 1.12 -name: fortran-src -version: 0.2.1.1 -synopsis: Parser and anlyses for Fortran standards 66, 77, 90 and 95. -description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. -bug-reports: https://github.com/camfort/fortran-src/issues -license: Apache-2.0 -license-file: LICENSE -author: Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice -maintainer: me@madgen.net --- copyright: -category: Language -build-type: Simple -extra-source-files: CHANGELOG.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f33857aa248d66c7f4c20fdc906e32ee466aeca57820d7fd2c0874092659737a + +name: fortran-src +version: 0.3.0 +synopsis: Parser and anlyses for Fortran standards 66, 77, 90 and 95. +description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. +category: Language +homepage: https://github.com/camfort/fortran-src#readme +bug-reports: https://github.com/camfort/fortran-src/issues +author: Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice +maintainer: me@madgen.net +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + source-repository head - type: git + type: git location: https://github.com/camfort/fortran-src -executable fortran-src - main-is: src/Main.hs - build-depends: - base >= 4.6 && < 5, - mtl >= 2.2 && < 3, - array >= 0.5 && < 0.6, - uniplate >= 1.6 && < 2, - GenericPretty >= 1.2.2 && < 2, - pretty >= 1.1 && < 2, - containers >= 0.5 && < 0.6, - text >= 1.2 && < 2, - bytestring >= 0.10 && < 0.11, - binary >= 0.8.3.0 && < 0.9, - filepath >= 1.4 && < 2, - directory >= 1.2 && < 2, - fgl >= 5 && < 6, - fortran-src - ghc-options: -fno-warn-tabs - default-language: Haskell2010 - library exposed-modules: - Language.Fortran.Analysis - Language.Fortran.Analysis.Renaming - Language.Fortran.Analysis.Types - Language.Fortran.Analysis.BBlocks - Language.Fortran.Analysis.DataFlow - Language.Fortran.AST - Language.Fortran.LValue - Language.Fortran.Intrinsics - Language.Fortran.Lexer.FixedForm - Language.Fortran.Lexer.FreeForm - Language.Fortran.ParserMonad - Language.Fortran.Parser.Any - Language.Fortran.Parser.Fortran66 - Language.Fortran.Parser.Fortran77 - Language.Fortran.Parser.Fortran90 - Language.Fortran.Parser.Fortran95 - Language.Fortran.Parser.Utils - Language.Fortran.PrettyPrint - Language.Fortran.Transformation.Disambiguation.Function - Language.Fortran.Transformation.Disambiguation.Intrinsic - Language.Fortran.Transformation.Grouping - Language.Fortran.Transformation.TransformMonad - Language.Fortran.Transformer - Language.Fortran.Util.Position - Language.Fortran.Util.FirstParameter - Language.Fortran.Util.SecondParameter - Language.Fortran.Util.ModFile - build-tools: - alex >= 3.1, - happy >= 1.19 + Language.Fortran.Analysis + Language.Fortran.Analysis.Renaming + Language.Fortran.Analysis.Types + Language.Fortran.Analysis.BBlocks + Language.Fortran.Analysis.DataFlow + Language.Fortran.AST + Language.Fortran.LValue + Language.Fortran.Intrinsics + Language.Fortran.Lexer.FixedForm + Language.Fortran.Lexer.FreeForm + Language.Fortran.ParserMonad + Language.Fortran.Parser.Any + Language.Fortran.Parser.Fortran66 + Language.Fortran.Parser.Fortran77 + Language.Fortran.Parser.Fortran90 + Language.Fortran.Parser.Fortran95 + Language.Fortran.Parser.Fortran2003 + Language.Fortran.Parser.Utils + Language.Fortran.PrettyPrint + Language.Fortran.Transformation.Disambiguation.Function + Language.Fortran.Transformation.Disambiguation.Intrinsic + Language.Fortran.Transformation.Grouping + Language.Fortran.Transformation.TransformMonad + Language.Fortran.Transformer + Language.Fortran.Util.Position + Language.Fortran.Util.FirstParameter + Language.Fortran.Util.SecondParameter + Language.Fortran.Util.ModFile + hs-source-dirs: + src + ghc-options: -fno-warn-tabs build-depends: - base >= 4.6 && < 5, - mtl >= 2.2 && < 3, - array >= 0.5 && < 0.6, - uniplate >= 1.6 && < 2, - GenericPretty >= 1.2.2 && < 2, - pretty >= 1.1 && < 2, - containers >= 0.5 && < 0.6, - text >= 1.2 && < 2, - bytestring >= 0.10 && < 0.11, - binary >= 0.8.3.0 && < 0.9, - filepath >= 1.4 && < 2, - directory >= 1.2 && < 2, - fgl >= 5 && < 6 - hs-source-dirs: src + GenericPretty >=1.2.2 && <2 + , array >=0.5 && <0.6 + , base >=4.6 && <5 + , binary >=0.8.3.0 && <0.9 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.7 + , directory >=1.2 && <2 + , fgl >=5 && <6 + , filepath >=1.4 && <2 + , mtl >=2.2 && <3 + , pretty >=1.1 && <2 + , text >=1.2 && <2 + , uniplate >=1.6 && <2 + build-tools: + alex >=3.1 + , happy >=1.19 + default-language: Haskell2010 + +executable fortran-src + main-is: src/Main.hs + other-modules: + Paths_fortran_src ghc-options: -fno-warn-tabs - default-language: Haskell2010 + build-depends: + GenericPretty >=1.2.2 && <2 + , array >=0.5 && <0.6 + , base >=4.6 && <5 + , binary >=0.8.3.0 && <0.9 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.7 + , directory >=1.2 && <2 + , fgl >=5 && <6 + , filepath >=1.4 && <2 + , fortran-src + , mtl >=2.2 && <3 + , pretty >=1.1 && <2 + , text >=1.2 && <2 + , uniplate >=1.6 && <2 + default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 - build-depends: - deepseq, - base >= 4.6 && < 5, - hspec >= 2.2 && < 3, - mtl >= 2.2 && < 3, - array >= 0.5 && < 0.6, - uniplate >= 1.6 && < 2, - directory >= 1.2 && < 2, - filepath >= 1.4 && < 2, - GenericPretty >= 1.2.2 && < 2, - pretty >= 1.1 && < 2, - containers >= 0.5 && < 0.6, - text >= 1.2 && < 2, - bytestring >= 0.10 && < 0.11, - binary >= 0.8.3.0 && < 0.9, - fgl >= 5 && < 6, - fortran-src - hs-source-dirs: test main-is: Spec.hs other-modules: - Language.Fortran.Analysis.BBlocksSpec - Language.Fortran.Analysis.DataFlowSpec - Language.Fortran.Analysis.RenamingSpec - Language.Fortran.Analysis.TypesSpec - Language.Fortran.AnalysisSpec - Language.Fortran.Lexer.FixedFormSpec - Language.Fortran.Lexer.FreeFormSpec - Language.Fortran.Parser.Fortran2003Spec - Language.Fortran.Parser.Fortran2008Spec - Language.Fortran.Parser.Fortran66Spec - Language.Fortran.Parser.Fortran77Spec - Language.Fortran.Parser.Fortran90Spec - Language.Fortran.Parser.Fortran95Spec - Language.Fortran.Parser.UtilsSpec - Language.Fortran.ParserMonadSpec - Language.Fortran.PrettyPrintSpec - Language.Fortran.Transformation.Disambiguation.FunctionSpec - Language.Fortran.Transformation.GroupingSpec - Language.Fortran.Util.FirstParameterSpec - Language.Fortran.Util.SecondParameterSpec - TestUtil - default-language: Haskell2010 + Language.Fortran.Analysis.BBlocksSpec + Language.Fortran.Analysis.DataFlowSpec + Language.Fortran.Analysis.RenamingSpec + Language.Fortran.Analysis.TypesSpec + Language.Fortran.AnalysisSpec + Language.Fortran.Lexer.FixedFormSpec + Language.Fortran.Lexer.FreeFormSpec + Language.Fortran.Parser.Fortran2003Spec + Language.Fortran.Parser.Fortran2008Spec + Language.Fortran.Parser.Fortran66Spec + Language.Fortran.Parser.Fortran77.IncludeSpec + Language.Fortran.Parser.Fortran77.ParserSpec + Language.Fortran.Parser.Fortran90Spec + Language.Fortran.Parser.Fortran95Spec + Language.Fortran.Parser.UtilsSpec + Language.Fortran.ParserMonadSpec + Language.Fortran.PrettyPrintSpec + Language.Fortran.Transformation.Disambiguation.FunctionSpec + Language.Fortran.Transformation.GroupingSpec + Language.Fortran.Util.FirstParameterSpec + Language.Fortran.Util.SecondParameterSpec + TestUtil + Paths_fortran_src + hs-source-dirs: + test + build-depends: + GenericPretty >=1.2.2 && <2 + , array >=0.5 && <0.6 + , base >=4.6 && <5 + , binary >=0.8.3.0 && <0.9 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.7 + , deepseq + , directory >=1.2 && <2 + , fgl >=5 && <6 + , filepath >=1.4 && <2 + , fortran-src + , hspec >=2.2 && <3 + , mtl >=2.2 && <3 + , pretty >=1.1 && <2 + , text >=1.2 && <2 + , uniplate >=1.6 && <2 + default-language: Haskell2010 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 @@ -5,9 +5,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +-- orphans are instances of package-natives +{-# OPTIONS_GHC -Wno-orphans #-} module Language.Fortran.AST where +import Prelude hiding (init) import Data.Data import Data.Generics.Uniplate.Data () import Data.Typeable () @@ -34,12 +37,22 @@ instance Functor t => Functor (AList t) where fmap f (AList a s xs) = AList (f a) s (map (fmap f) xs) + +-- Convert non-empty list to AList. fromList :: Spanned (t a) => a -> [ t a ] -> AList t a fromList a xs = AList a (getSpan xs) xs +-- Nothing iff list is empty +fromList' :: Spanned (t a) => a -> [ t a ] -> Maybe (AList t a) +fromList' _ [] = Nothing +fromList' a xs = Just $ fromList a xs + fromReverseList :: Spanned (t ()) => [ t () ] -> AList t () fromReverseList = fromList () . reverse +fromReverseList' :: Spanned (t ()) => [ t () ] -> Maybe (AList t ()) +fromReverseList' = fromList' () . reverse + aCons :: t a -> AList t a -> AList t a aCons x (AList a s xs) = AList a s $ x:xs @@ -51,6 +64,10 @@ aStrip :: AList t a -> [t a] aStrip (AList _ _ l) = l +aStrip' :: Maybe (AList t a) -> [t a] +aStrip' Nothing = [] +aStrip' (Just a) = aStrip a + aMap :: (t a -> r a) -> AList t a -> AList r a aMap f (AList a s xs) = AList a s (map f xs) @@ -62,13 +79,38 @@ | TypeComplex | TypeDoubleComplex | TypeLogical - | TypeCharacter + | TypeCharacter (Maybe CharacterLen) (Maybe String) -- ^ len and kind, if specified | TypeCustom String + | ClassStar + | ClassCustom String | TypeByte deriving (Ord, Eq, Show, Data, Typeable, Generic) instance Binary BaseType +data CharacterLen = CharLenStar -- ^ specified with a * + | CharLenColon -- ^ specified with a : (Fortran2003) + -- FIXME, possibly, with a more robust const-exp: + | CharLenExp -- ^ specified with a non-trivial expression + | CharLenInt Int -- ^ specified with a constant integer + deriving (Ord, Eq, Show, Data, Typeable, Generic) + +instance Binary CharacterLen + +charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String) +charLenSelector Nothing = (Nothing, Nothing) +charLenSelector (Just (Selector _ _ mlen mkind)) = (l, k) + where + l | Just (ExpValue _ _ ValStar) <- mlen = Just CharLenStar + | Just (ExpValue _ _ ValColon) <- mlen = Just CharLenColon + | Just (ExpValue _ _ (ValInteger i)) <- mlen = Just $ CharLenInt (read i) + | Nothing <- mlen = Nothing + | otherwise = Just CharLenExp + k | Just (ExpValue _ _ (ValInteger i)) <- mkind = Just i + | Just (ExpValue _ _ (ValVariable s)) <- mkind = Just s + -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it + | otherwise = Nothing + data TypeSpec a = TypeSpec a SrcSpan BaseType (Maybe (Selector a)) deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -84,7 +126,9 @@ data ProgramFile a = ProgramFile MetaInfo [ ProgramUnit a ] deriving (Eq, Show, Data, Typeable, 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 data ProgramUnit a = @@ -100,7 +144,7 @@ (Maybe [ProgramUnit a]) -- Subprograms | PUSubroutine a SrcSpan - (PUFunctionOpt a) -- Subroutine options + (PrefixSuffix a) -- Subroutine options Name (Maybe (AList Expression a)) -- Arguments [Block a] -- Body @@ -108,7 +152,7 @@ | PUFunction a SrcSpan (Maybe (TypeSpec a)) -- Return type - (PUFunctionOpt a) -- Function Options + (PrefixSuffix a) -- Function Options Name (Maybe (AList Expression a)) -- Arguments (Maybe (Expression a)) -- Result @@ -121,65 +165,66 @@ | PUComment a SrcSpan (Comment a) deriving (Eq, Show, Data, Typeable, Generic, Functor) -type IsRecursive = Bool -data PUFunctionOpt a = - None a SrcSpan IsRecursive - | Pure a SrcSpan IsRecursive - | Elemental a SrcSpan - deriving (Eq, Show, Data, Typeable, Generic, Functor) +type Prefixes a = Maybe (AList Prefix a) +type Suffixes a = Maybe (AList Suffix a) +type PrefixSuffix a = (Prefixes a, Suffixes a) -buildPUFunctionOpt :: (PUFunctionOpt ()) -> (PUFunctionOpt ()) -> Either String (PUFunctionOpt ()) -buildPUFunctionOpt a b = - case (a, b) of - ((None () _ False ), _) -> Right $ setSpan (getTransSpan a b) b - (_, (None () _ False)) -> Right $ setSpan (getTransSpan a b) a - ((Elemental () _), _) -> if functionIsRecursive b - then Left "Function cannot be both elemental and recursive. " - else Right . Elemental () $ getTransSpan a b - (_, (Elemental () _)) -> buildPUFunctionOpt b a - ((Pure () _ r), b) -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive b) - (a, (Pure () _ r)) -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive a) - ((None () _ r), (None () _ r')) -> Right $ None () (getTransSpan a b) (r || r') --- Should parse: "elemental pure recursive function f()\nend": Right (Elemental ()) FAILED [4] +emptyPrefixes :: Prefixes a +emptyPrefixes = Nothing -buildPUFunctionOpts :: [PUFunctionOpt ()] -> Either String (PUFunctionOpt()) -buildPUFunctionOpts = - foldr merge . Right $ None () initSrcSpan False - where merge a = either Left $ buildPUFunctionOpt a +emptySuffixes :: Suffixes a +emptySuffixes = Nothing -functionIsRecursive :: (PUFunctionOpt a) -> Bool -functionIsRecursive (Elemental _ _) = False -functionIsRecursive (Pure _ _ r) = r -functionIsRecursive (None _ _ r) = r +emptyPrefixSuffix :: PrefixSuffix a +emptyPrefixSuffix = (emptyPrefixes, emptySuffixes) +data Prefix a = PfxRecursive a SrcSpan + | PfxElemental a SrcSpan + | PfxPure a SrcSpan + deriving (Eq, Show, Data, Typeable, Generic, Functor) + +-- see C1241 & C1242 (Fortran2003) +validPrefixSuffix :: PrefixSuffix a -> Bool +validPrefixSuffix (mpfxs, msfxs) = + not (any isElem pfxs) || (not (any isRec pfxs) && not (any isBind sfxs)) + where + isElem (PfxElemental {}) = True; isElem _ = False + isRec (PfxRecursive {}) = True; isRec _ = False + isBind (SfxBind {}) = True + pfxs = aStrip' mpfxs + sfxs = aStrip' msfxs + +data Suffix a = SfxBind a SrcSpan (Maybe (Expression a)) + deriving (Eq, Show, Data, Typeable, Generic, Functor) + programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _) = bs programUnitBody (PUModule _ _ _ bs _) = bs programUnitBody (PUSubroutine _ _ _ _ _ bs _) = bs programUnitBody (PUFunction _ _ _ _ _ _ _ bs _) = bs programUnitBody (PUBlockData _ _ _ bs) = bs -programUnitBody (PUComment {}) = [] +programUnitBody PUComment{} = [] updateProgramUnitBody :: ProgramUnit a -> [Block a] -> ProgramUnit a -updateProgramUnitBody (PUMain a s n bs pu) bs' = +updateProgramUnitBody (PUMain a s n _ pu) bs' = PUMain a s n bs' pu -updateProgramUnitBody (PUModule a s n bs pu) bs' = +updateProgramUnitBody (PUModule a s n _ pu) bs' = PUModule a s n bs' pu -updateProgramUnitBody (PUSubroutine a s f n args bs pu) bs' = +updateProgramUnitBody (PUSubroutine a s f n args _ pu) bs' = PUSubroutine a s f n args bs' pu -updateProgramUnitBody (PUFunction a s t f n args res bs pu) bs' = +updateProgramUnitBody (PUFunction a s t f n args res _ pu) bs' = PUFunction a s t f n args res bs' pu -updateProgramUnitBody (PUBlockData a s n bs) bs' = +updateProgramUnitBody (PUBlockData a s n _) bs' = PUBlockData a s n bs' -updateProgramUnitBody p@(PUComment {}) _ = p +updateProgramUnitBody p@PUComment{} _ = p programUnitSubprograms :: ProgramUnit a -> Maybe [ProgramUnit a] programUnitSubprograms (PUMain _ _ _ _ s) = s programUnitSubprograms (PUModule _ _ _ _ s) = s programUnitSubprograms (PUSubroutine _ _ _ _ _ _ s) = s programUnitSubprograms (PUFunction _ _ _ _ _ _ _ _ s) = s -programUnitSubprograms (PUBlockData {}) = Nothing -programUnitSubprograms (PUComment {}) = Nothing +programUnitSubprograms PUBlockData{} = Nothing +programUnitSubprograms PUComment{} = Nothing newtype Comment a = Comment String deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -229,6 +274,7 @@ | BlInterface a SrcSpan (Maybe (Expression a)) -- label + Bool -- abstract? [ ProgramUnit a ] -- Routine decls. in the interface [ Block a ] -- Module procedures @@ -242,11 +288,15 @@ | 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)) | StDimension a SrcSpan (AList Declarator a) | StAllocatable a SrcSpan (AList Declarator a) + | StAsynchronous a SrcSpan (AList Declarator a) | StPointer a SrcSpan (AList Declarator a) | StTarget a SrcSpan (AList Declarator a) + | StValue a SrcSpan (AList Declarator a) + | StVolatile a SrcSpan (AList Declarator a) | StData a SrcSpan (AList DataGroup a) | StAutomatic a SrcSpan (AList Declarator a) | StNamelist a SrcSpan (AList Namelist a) @@ -292,6 +342,7 @@ | StTypePrint a SrcSpan (Expression a) (Maybe (AList Expression a)) | StOpen a SrcSpan (AList ControlPair a) | StClose a SrcSpan (AList ControlPair a) + | StFlush a SrcSpan (AList FlushSpec a) | StInquire a SrcSpan (AList ControlPair a) | StRewind a SrcSpan (AList ControlPair a) | StRewind2 a SrcSpan (Expression a) @@ -299,26 +350,40 @@ | StBackspace2 a SrcSpan (Expression a) | StEndfile a SrcSpan (AList ControlPair a) | StEndfile2 a SrcSpan (Expression a) - | StAllocate a SrcSpan (AList Expression a) (Maybe (ControlPair 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 (ControlPair a)) + | StDeallocate a SrcSpan (AList Expression a) (Maybe (AList AllocOpt a)) | StWhere a SrcSpan (Expression a) (Statement a) - | StWhereConstruct a SrcSpan (Expression a) - | StElsewhere a SrcSpan - | StEndWhere a SrcSpan - | StUse a SrcSpan (Expression a) Only (Maybe (AList Use 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) | 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) + | 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) +-- 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) + +-- 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) + data ForallHeader a = ForallHeader -- List of tuples: index-name, start subscript, end subscript, optional stride [(Name, Expression a, Expression a, Maybe (Expression a))] @@ -329,6 +394,9 @@ data Only = Exclusive | Permissive deriving (Eq, Show, Data, Typeable, Generic) +data ModuleNature = ModIntrinsic | ModNonIntrinsic + deriving (Eq, Show, Data, Typeable, Generic) + data Use a = UseRename a SrcSpan (Expression a) (Expression a) | UseID a SrcSpan (Expression a) @@ -338,18 +406,23 @@ deriving (Eq, Show, Data, Typeable, Generic, Functor) data Attribute a = - AttrParameter a SrcSpan - | AttrPublic a SrcSpan - | AttrPrivate a SrcSpan - | AttrAllocatable a SrcSpan + AttrAllocatable a SrcSpan + | AttrAsynchronous a SrcSpan | AttrDimension a SrcSpan (AList DimensionDeclarator a) | AttrExternal a SrcSpan | AttrIntent a SrcSpan Intent | AttrIntrinsic a SrcSpan | AttrOptional a SrcSpan + | AttrParameter a SrcSpan | AttrPointer a SrcSpan + | AttrPrivate a SrcSpan + | AttrProtected a SrcSpan + | AttrPublic a SrcSpan | AttrSave a SrcSpan + | AttrSuffix a SrcSpan (Suffix a) -- for language-binding-spec | AttrTarget a SrcSpan + | AttrValue a SrcSpan + | AttrVolatile a SrcSpan deriving (Eq, Show, Data, Typeable, Generic, Functor) data Intent = In | Out | InOut @@ -358,6 +431,12 @@ data ControlPair a = ControlPair a SrcSpan (Maybe String) (Expression a) deriving (Eq, Show, Data, Typeable, Generic, Functor) +data AllocOpt a = + AOStat a SrcSpan (Expression a) + | AOErrMsg a SrcSpan (Expression a) + | AOSource a SrcSpan (Expression a) + deriving (Eq, Show, Data, Typeable, Generic, Functor) + data ImpList a = ImpList a SrcSpan (TypeSpec a) (AList ImpElement a) deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -399,6 +478,13 @@ | FIScaleFactor a SrcSpan Integer deriving (Eq, Show, Data, Typeable, 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) + data DoSpecification a = DoSpecification a SrcSpan (Statement a) (Expression a) (Maybe (Expression a)) deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -456,6 +542,7 @@ -- ^ Overloaded assignment in interfaces | ValType String | ValStar + | ValColon -- see R402 / C403 in Fortran2003 spec. deriving (Eq, Show, Data, Typeable, Generic, Functor) data Declarator a = @@ -475,6 +562,8 @@ DeclVariable a (getTransSpan s init) v l (Just init) setInitialisation (DeclArray a s v ds l Nothing) init = DeclArray a (getTransSpan s init) v ds l (Just init) +-- do nothing when there is already a value +setInitialisation d _ = d data DimensionDeclarator a = DimensionDeclarator a SrcSpan (Maybe (Expression a)) (Maybe (Expression a)) @@ -485,8 +574,10 @@ | Minus | Not | UnCustom String - deriving (Eq, Show, Data, Typeable, Generic) + deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Binary UnaryOp + data BinaryOp = Addition | Subtraction @@ -506,8 +597,10 @@ | Equivalent | NotEquivalent | BinCustom String - deriving (Eq, Show, Data, Typeable, Generic) + deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Binary BinaryOp + -- Retrieving SrcSpan and Annotation from nodes class Annotated f where getAnnotation :: f a -> a @@ -523,12 +616,15 @@ instance FirstParameter (AList t a) a instance FirstParameter (ProgramUnit a) a -instance FirstParameter (PUFunctionOpt a) a +instance FirstParameter (Prefix a) a +instance FirstParameter (Suffix a) a instance FirstParameter (Block a) a instance FirstParameter (Statement a) a instance FirstParameter (Argument a) a instance FirstParameter (Use a) a instance FirstParameter (TypeSpec a) a +instance FirstParameter (ProcDecl a) a +instance FirstParameter (ProcInterface a) a instance FirstParameter (Selector a) a instance FirstParameter (Attribute a) a instance FirstParameter (ImpList a) a @@ -542,18 +638,23 @@ instance FirstParameter (Expression a) a instance FirstParameter (Index a) a instance FirstParameter (DoSpecification a) a +instance FirstParameter (FlushSpec a) a instance FirstParameter (Declarator a) a instance FirstParameter (DimensionDeclarator a) a instance FirstParameter (ControlPair a) a +instance FirstParameter (AllocOpt a) a instance SecondParameter (AList t a) SrcSpan instance SecondParameter (ProgramUnit a) SrcSpan -instance SecondParameter (PUFunctionOpt a) SrcSpan +instance SecondParameter (Prefix a) SrcSpan +instance SecondParameter (Suffix a) SrcSpan instance SecondParameter (Block a) SrcSpan instance SecondParameter (Statement a) SrcSpan instance SecondParameter (Argument a) SrcSpan instance SecondParameter (Use a) SrcSpan instance SecondParameter (TypeSpec a) SrcSpan +instance SecondParameter (ProcDecl a) SrcSpan +instance SecondParameter (ProcInterface a) SrcSpan instance SecondParameter (Selector a) SrcSpan instance SecondParameter (Attribute a) SrcSpan instance SecondParameter (ImpList a) SrcSpan @@ -567,9 +668,11 @@ instance SecondParameter (Expression a) SrcSpan instance SecondParameter (Index a) SrcSpan instance SecondParameter (DoSpecification a) SrcSpan +instance SecondParameter (FlushSpec a) SrcSpan instance SecondParameter (Declarator a) SrcSpan instance SecondParameter (DimensionDeclarator a) SrcSpan instance SecondParameter (ControlPair a) SrcSpan +instance SecondParameter (AllocOpt a) SrcSpan instance Annotated (AList t) instance Annotated ProgramUnit @@ -578,6 +681,8 @@ instance Annotated Argument instance Annotated Use instance Annotated TypeSpec +instance Annotated ProcDecl +instance Annotated ProcInterface instance Annotated Selector instance Annotated Attribute instance Annotated ImpList @@ -591,18 +696,23 @@ instance Annotated Expression instance Annotated Index instance Annotated DoSpecification +instance Annotated FlushSpec instance Annotated Declarator instance Annotated DimensionDeclarator instance Annotated ControlPair +instance Annotated AllocOpt instance Spanned (AList t a) instance Spanned (ProgramUnit a) -instance Spanned (PUFunctionOpt a) +instance Spanned (Prefix a) +instance Spanned (Suffix a) instance Spanned (Statement a) instance Spanned (Argument a) instance Spanned (Use a) instance Spanned (Attribute a) instance Spanned (TypeSpec a) +instance Spanned (ProcDecl a) +instance Spanned (ProcInterface a) instance Spanned (Selector a) instance Spanned (ImpList a) instance Spanned (ImpElement a) @@ -616,15 +726,17 @@ instance Spanned (Expression a) instance Spanned (Index a) instance Spanned (DoSpecification a) +instance Spanned (FlushSpec a) instance Spanned (Declarator a) instance Spanned (DimensionDeclarator a) instance Spanned (ControlPair a) +instance Spanned (AllocOpt a) instance Spanned (ProgramFile a) where getSpan (ProgramFile _ pus) = case pus of [] -> SrcSpan initPosition initPosition - pus -> getSpan pus + pus' -> getSpan pus' setSpan _ _ = error "Cannot set span to a program unit" @@ -644,6 +756,11 @@ getSpan (_,y) = getSpan y setSpan _ = undefined +instance (Spanned a, Spanned b) => Spanned (Either a b) where + getSpan (Left x) = getSpan x + getSpan (Right x) = getSpan x + setSpan _ = undefined + instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => Spanned (a, b) where getSpan (x,y) = getTransSpan x y setSpan _ = undefined @@ -670,7 +787,7 @@ setSpan _ = undefined instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b, Spanned c) => Spanned (a, b, c) where - getSpan (x,y,z) = getTransSpan x z + getSpan (x,_,z) = getTransSpan x z setSpan _ = undefined class (Spanned a, Spanned b) => SpannedPair a b where @@ -719,7 +836,7 @@ setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el - setLabel b l = b + setLabel b _ = b class Conditioned f where getCondition :: f a -> Maybe (Expression a) @@ -754,7 +871,7 @@ getName (PUFunction _ _ _ _ n _ _ _ _) = Named n getName (PUBlockData _ _ Nothing _) = NamelessBlockData getName (PUBlockData _ _ (Just n) _) = Named n - getName (PUComment {}) = NamelessComment + getName PUComment{} = NamelessComment setName (Named n) (PUMain a s _ b pus) = PUMain a s (Just n) b pus setName _ (PUMain a s _ b pus) = PUMain a s Nothing b pus setName (Named n) (PUModule a s _ b pus) = PUModule a s n b pus @@ -764,15 +881,21 @@ PUFunction a s r rec n p res b subs setName (Named n) (PUBlockData a s _ b) = PUBlockData a s (Just n) b setName _ (PUBlockData a s _ b) = PUBlockData a s Nothing b + -- Identity function if first arg is nameless or second arg is comment. + setName _ a = a instance Out FortranVersion instance Out MetaInfo instance Out a => Out (ProgramFile a) instance Out a => Out (ProgramUnit a) -instance Out a => Out (PUFunctionOpt a) +instance Out a => Out (Prefix a) +instance Out a => Out (Suffix a) instance (Out a, Out (t a)) => Out (AList t a) instance Out a => Out (Statement a) +instance Out a => Out (ProcDecl a) +instance Out a => Out (ProcInterface a) instance Out Only +instance Out ModuleNature instance Out a => Out (Argument a) instance Out a => Out (Use a) instance Out a => Out (Attribute a) @@ -790,13 +913,16 @@ instance Out a => Out (Expression a) 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 CharacterLen instance Out BaseType instance Out a => Out (Declarator a) instance Out a => Out (DimensionDeclarator a) instance Out a => Out (ControlPair a) +instance Out a => Out (AllocOpt a) instance Out UnaryOp instance Out BinaryOp instance Out a => Out (ForallHeader a) @@ -804,35 +930,39 @@ -- Classifiers on statement and blocks ASTs nonExecutableStatement :: FortranVersion -> Statement a -> Bool -nonExecutableStatement v s = case s of - StIntent {} -> True - StOptional {} -> True - StPublic {} -> True - StPrivate {} -> True - StSave {} -> True - StDimension {} -> True - StAllocatable {} -> True - StPointer {} -> True - StTarget {} -> True - StData {} -> True - StParameter {} -> True - StImplicit {} -> True - StNamelist {} -> True - StEquivalence {} -> True - StCommon {} -> True - StExternal {} -> True - StIntrinsic {} -> True - StUse {} -> True - StEntry {} -> True - StSequence {} -> True - StType {} -> True - StEndType {} -> True - StFormat {} -> True - StFormatBogus {} -> True - StInclude {} -> True - StDeclaration {} -> True - StStructure {} -> True - _ -> False +nonExecutableStatement _ s = case s of + StIntent {} -> True + StOptional {} -> True + StPublic {} -> True + StPrivate {} -> True + StProtected {} -> True + StSave {} -> True + StDimension {} -> True + StAllocatable {} -> True + StAsynchronous {} -> True + StPointer {} -> True + StTarget {} -> True + StValue {} -> True + StVolatile {} -> True + StData {} -> True + StParameter {} -> True + StImplicit {} -> True + StNamelist {} -> True + StEquivalence {} -> True + StCommon {} -> True + StExternal {} -> True + StIntrinsic {} -> True + StUse {} -> True + StEntry {} -> True + StSequence {} -> True + StType {} -> True + StEndType {} -> True + StFormat {} -> True + StFormatBogus {} -> True + StInclude {} -> True + StDeclaration {} -> True + StStructure {} -> True + _ -> False executableStatement :: FortranVersion -> Statement a -> Bool -- Some statements are both executable and non-executable in Fortran 90 upwards @@ -843,9 +973,9 @@ executableStatementBlock :: FortranVersion -> Block a -> Bool executableStatementBlock v (BlStatement _ _ _ s) = executableStatement v s -executableStatementBlock v _ = False +executableStatementBlock _ _ = False nonExecutableStatementBlock :: FortranVersion -> Block a -> Bool nonExecutableStatementBlock v (BlStatement _ _ _ s) = nonExecutableStatement v s -nonExecutableStatementBlock v BlInterface{} = True -nonExecutableStatementBlock v _ = False +nonExecutableStatementBlock _ BlInterface{} = True +nonExecutableStatementBlock _ _ = False 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 @@ -1,27 +1,31 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TupleSections #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis - ( initAnalysis, stripAnalysis, Analysis(..) + ( initAnalysis, stripAnalysis, Analysis(..), Constant(..) , varName, srcName, lvVarName, lvSrcName, isNamedExpression , genVar, puName, puSrcName, blockRhsExprs, rhsExprs , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..) , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars , blockVarUses, blockVarDefs - , BB, BBGr + , BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty , TransFunc, TransFuncM ) where +import Prelude hiding (exp) +import Control.Monad (void) import Language.Fortran.Util.Position (SrcSpan) import Data.Generics.Uniplate.Data import Data.Data import Language.Fortran.AST import Language.Fortran.LValue +import Data.Graph.Inductive (Node, empty) import Data.Graph.Inductive.PatriciaTree (Gr) import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint +import Text.PrettyPrint hiding (empty, isEmpty) import qualified Data.Map.Strict as M import Data.Maybe import Data.Binary @@ -34,12 +38,32 @@ type BB a = [Block a] -- | Basic block graph. -type BBGr a = Gr (BB a) () +data BBGr a = BBGr { bbgrGr :: Gr (BB a) () -- ^ the underlying graph + , bbgrEntries :: [Node] -- ^ the entry node(s) + , bbgrExits :: [Node] -- ^ the exit node(s) + } + deriving (Data, Show, Eq, Generic) +type BBNode = Int + +-- | Empty basic block graph +bbgrEmpty :: BBGr a +bbgrEmpty = BBGr empty [] [] + +-- | Call function on the underlying graph +bbgrMap :: (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b +bbgrMap f bb = bb { bbgrGr = f (bbgrGr bb) } + +-- | Monadically call function on the underlying graph +bbgrMapM :: Monad m => (Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2) +bbgrMapM f bb = do + x <- f (bbgrGr bb) + return $ bb { bbgrGr = x } + -- Allow graphs to reside inside of annotations deriving instance (Typeable a, Typeable b) => Typeable (Gr a b) instance (Typeable a, Typeable b) => Data (Gr a b) where - gfoldl _k z v = z v -- make graphs opaque to Uniplate + gfoldl _k z = z -- make graphs opaque to Uniplate toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Gr" @@ -66,7 +90,7 @@ | CTSubroutine | CTExternal | CTVariable - | CTArray + | CTArray [(Maybe Int, Maybe Int)] | CTParameter | CTIntrinsic deriving (Ord, Eq, Show, Data, Typeable, Generic) @@ -82,6 +106,18 @@ instance Out IDType instance Binary IDType +-- | Information about potential / actual constant expressions. +data Constant + = ConstInt Integer -- ^ interpreted integer + | ConstUninterpInt String -- ^ uninterpreted integer + | ConstUninterpReal String -- ^ uninterpreted real + | ConstBinary BinaryOp Constant Constant -- ^ binary operation on potential constants + | ConstUnary UnaryOp Constant -- ^ unary operation on potential constants + deriving (Show, Ord, Eq, Typeable, Generic, Data) + +instance Out Constant +instance Binary Constant + data Analysis a = Analysis { prevAnnotation :: a -- ^ original annotation , uniqueName :: Maybe String -- ^ unique name for function/variable, after variable renaming phase @@ -91,6 +127,7 @@ , moduleEnv :: Maybe ModEnv , idType :: Maybe IDType , allLhsVarsAnn :: [Name] + , constExp :: Maybe Constant } deriving (Data, Show, Eq, Generic) @@ -100,11 +137,12 @@ { prevAnnotation = f (prevAnnotation analysis) , uniqueName = uniqueName analysis , sourceName = sourceName analysis - , bBlocks = fmap (first . fmap . fmap . fmap $ f) . bBlocks $ analysis + , bBlocks = fmap (bbgrMap (first . fmap . fmap . fmap $ f)) . bBlocks $ analysis , insLabel = insLabel analysis , moduleEnv = moduleEnv analysis , idType = idType analysis , allLhsVarsAnn = allLhsVarsAnn analysis + , constExp = constExp analysis } instance Out (Analysis a) where @@ -115,6 +153,7 @@ , ("idType: ", fmap show (idType a)) ] docPrec _ = doc +analysis0 :: a -> Analysis a analysis0 a = Analysis { prevAnnotation = a , uniqueName = Nothing , sourceName = Nothing @@ -122,7 +161,8 @@ , insLabel = Nothing , moduleEnv = Nothing , idType = Nothing - , allLhsVarsAnn = [] } + , allLhsVarsAnn = [] + , constExp = Nothing } -- | True iff the expression can be used with varName or srcName isNamedExpression :: Expression a -> Bool @@ -132,32 +172,32 @@ -- | Obtain either uniqueName or source name from an ExpValue variable. varName :: Expression (Analysis a) -> String -varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValVariable {})) = n -varName (ExpValue (Analysis { sourceName = Just n }) _ (ValVariable {})) = n -varName (ExpValue _ _ (ValVariable n)) = n -varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValIntrinsic {})) = n -varName (ExpValue (Analysis { sourceName = Just n }) _ (ValIntrinsic {})) = n -varName (ExpValue _ _ (ValIntrinsic n)) = n -varName _ = error "Use of varName on non-variable." +varName (ExpValue Analysis { uniqueName = Just n } _ ValVariable{}) = n +varName (ExpValue Analysis { sourceName = Just n } _ ValVariable{}) = n +varName (ExpValue _ _ (ValVariable n)) = n +varName (ExpValue Analysis { uniqueName = Just n } _ ValIntrinsic{}) = n +varName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n +varName (ExpValue _ _ (ValIntrinsic n)) = n +varName _ = error "Use of varName on non-variable." -- | Obtain the source name from an ExpValue variable. srcName :: Expression (Analysis a) -> String -srcName (ExpValue (Analysis { sourceName = Just n }) _ (ValVariable {})) = n -srcName (ExpValue _ _ (ValVariable n)) = n -srcName (ExpValue (Analysis { sourceName = Just n }) _ (ValIntrinsic {})) = n -srcName (ExpValue _ _ (ValIntrinsic n)) = n -srcName _ = error "Use of srcName on non-variable." +srcName (ExpValue Analysis { sourceName = Just n } _ ValVariable{}) = n +srcName (ExpValue _ _ (ValVariable n)) = n +srcName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n +srcName (ExpValue _ _ (ValIntrinsic n)) = n +srcName _ = error "Use of srcName on non-variable." -- | Obtain either uniqueName or source name from an LvSimpleVar variable. lvVarName :: LValue (Analysis a) -> String -lvVarName (LvSimpleVar (Analysis { uniqueName = Just n }) _ _) = n -lvVarName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n -lvVarName (LvSimpleVar _ _ n) = n -lvVarName _ = error "Use of lvVarName on non-variable." +lvVarName (LvSimpleVar Analysis { uniqueName = Just n } _ _) = n +lvVarName (LvSimpleVar Analysis { sourceName = Just n } _ _) = n +lvVarName (LvSimpleVar _ _ n) = n +lvVarName _ = error "Use of lvVarName on non-variable." -- | Obtain the source name from an LvSimpleVar variable. lvSrcName :: LValue (Analysis a) -> String -lvSrcName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n +lvSrcName (LvSimpleVar Analysis { sourceName = Just n } _ _) = n lvSrcName (LvSimpleVar _ _ n) = n lvSrcName _ = error "Use of lvSrcName on a non-variable" @@ -219,9 +259,9 @@ -- | Is this an expression capable of assignment? isLExpr :: Expression a -> Bool -isLExpr (ExpValue _ _ (ValVariable {})) = True -isLExpr (ExpSubscript _ _ _ _) = True -isLExpr _ = False +isLExpr (ExpValue _ _ ValVariable {}) = True +isLExpr ExpSubscript{} = True +isLExpr _ = False -- | Set of names found in an AST node. allVars :: forall a b. (Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name] @@ -243,10 +283,10 @@ -- an assignment statement. -- allLhsVars :: (Annotated b, Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name] allLhsVars :: Data a => Block (Analysis a) -> [Name] -allLhsVars x = allLhsVarsAnn . getAnnotation $ x +allLhsVars = allLhsVarsAnn . getAnnotation allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name] -allLhsVarsDoSpec x = computeAllLhsVars x +allLhsVarsDoSpec = computeAllLhsVars -- | Set of names found in the parts of an AST that are the target of -- an assignment statement. @@ -255,11 +295,16 @@ where lhsOfStmt :: Statement (Analysis a) -> [Name] lhsOfStmt (StExpressionAssign _ _ e e') = match' e : onExprs e' + 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'' . extractExp) (aStrip aexps) lhsOfStmt s = onExprs s + lhsOfDecls (DeclVariable _ _ e _ (Just e')) = match' e : onExprs e' + lhsOfDecls (DeclArray _ _ e _ _ (Just e')) = match' e : onExprs e' + lhsOfDecls _ = [] + onExprs :: (Data (c (Analysis a))) => c (Analysis a) -> [Name] onExprs = concatMap lhsOfExp . universeBi @@ -270,22 +315,22 @@ extractExp (Argument _ _ _ exp) = exp -- Match and give the varname for LHS of statement - match' v@(ExpValue _ _ (ValVariable {})) = varName v - match' (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = varName v + match' v@(ExpValue _ _ ValVariable{}) = varName v + match' (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = varName v match' (ExpDataRef _ _ v _) = match' v - match' e = error $ "An unexpected LHS to an expression assign: " ++ show (fmap (const ()) e) + match' e = error $ "An unexpected LHS to an expression assign: " ++ show (void (const ()) e) -- Match and give the varname of LHSes which occur in subroutine calls - match'' v@(ExpValue _ _ (ValVariable {})) = [varName v] - match'' (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = [varName v] - match'' (ExpDataRef _ _ v _) = match'' v - match'' e = onExprs e + match'' v@(ExpValue _ _ ValVariable{}) = [varName v] + match'' (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = [varName v] + match'' (ExpDataRef _ _ v _) = match'' v + match'' e = onExprs e -- Match and give the varname of LHSes which occur in function calls - match v@(ExpValue _ _ (ValVariable {})) = [varName v] - match (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = [varName v] - match (ExpDataRef _ _ e _) = match e - match e = [] + match v@(ExpValue _ _ ValVariable{}) = [varName v] + match (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = [varName v] + match (ExpDataRef _ _ e _) = match e + match _ = [] -- | Set of expressions used -- not defined -- by an AST-block. blockRhsExprs :: Data a => Block a -> [Expression a] @@ -302,23 +347,28 @@ statementRhsExprs (StExpressionAssign _ _ lhs rhs) | ExpSubscript _ _ _ subs <- lhs = universeBi rhs ++ universeBi subs | otherwise = universeBi rhs -statementRhsExprs (StDeclaration {}) = [] +statementRhsExprs StDeclaration{} = [] statementRhsExprs (StIfLogical _ _ _ s) = statementRhsExprs s -statementRhsExprs (StDo _ _ _ l s) = (universeBi l) ++ doSpecRhsExprs s +statementRhsExprs (StDo _ _ _ l s') = universeBi l ++ doSpecRhsExprs s' where doSpecRhsExprs (Just (DoSpecification _ _ s e1 e2)) = - (e1 : (universeBi e2)) ++ statementRhsExprs s + (e1 : universeBi e2) ++ statementRhsExprs s doSpecRhsExprs Nothing = [] statementRhsExprs s = universeBi s -- | Set of names used -- not defined -- by an AST-block. -blockVarUses :: Data a => Block (Analysis a) -> [Name] +blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name] blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs)) | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs) | otherwise = allVars rhs blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _) | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs) | otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 -blockVarUses (BlStatement _ _ _ (StDeclaration {})) = [] +blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ] + where + rhsOfDecls :: Data a => Declarator (Analysis a) -> [Name] + rhsOfDecls (DeclVariable _ _ _ _ (Just e)) = allVars e + rhsOfDecls (DeclArray _ _ _ _ _ (Just e)) = allVars e + rhsOfDecls _ = [] blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)) | Just uses <- intrinsicUses f = uses blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps @@ -328,7 +378,7 @@ -- | Set of names defined by an AST-block. blockVarDefs :: Data a => Block (Analysis a) -> [Name] -blockVarDefs b@(BlStatement _ _ _ st) = allLhsVars b +blockVarDefs b@BlStatement{} = allLhsVars b blockVarDefs (BlDo _ _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec blockVarDefs _ = [] @@ -347,7 +397,7 @@ -- return dummy arg names (defined, used) by intrinsic intrinsicDefsUses :: Expression (Analysis a) -> Maybe ([Name], [Name]) intrinsicDefsUses f = both (map (dummyArg (varName f))) <$> getIntrinsicDefsUses (srcName f) allIntrinsics - where both f (x, y) = (f x, f y) + where both f' (x, y) = (f' x, f' y) -- Local variables: -- mode: haskell 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 @@ -1,20 +1,22 @@ -- | Analyse a program file and create basic blocks. -{-# LANGUAGE FlexibleContexts, PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections, FlexibleContexts, PatternGuards, ScopedTypeVariables #-} module Language.Fortran.Analysis.BBlocks - ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap - , genSuperBBGr, SuperBBGr, showSuperBBGr, superBBGrToDOT, superBBGrGraph, superBBGrClusters, superBBGrEntries - , findLabeledBBlock ) + ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode + , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock ) where -import Data.Generics.Uniplate.Data +import Prelude hiding (exp) +import Data.Generics.Uniplate.Data hiding (transform) +import Data.Char (toLower) import Data.Data +import Data.List (unfoldr, foldl') import Control.Monad -import Control.Monad.State.Lazy -import Control.Monad.Writer +import Control.Monad.State.Lazy hiding (fix) +import Control.Monad.Writer hiding (fix) import Text.PrettyPrint.GenericPretty (pretty, Out) import Language.Fortran.Analysis -import Language.Fortran.AST +import Language.Fortran.AST hiding (setName) import Language.Fortran.Util.Position import qualified Data.Map as M import qualified Data.IntMap as IM @@ -22,6 +24,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr) import Data.List (intercalate) import Data.Maybe +import Data.Functor.Identity -------------------------------------------------- @@ -48,16 +51,18 @@ -------------------------------------------------- +type ASTBlockNode = Int + -- Insert unique labels on each AST-block for easier look-up later. -labelBlocks :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a)) -labelBlocks gr = transform eachBlock gr +labelBlocks :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a)) +labelBlocks = transform eachBlock where - eachBlock :: Data a => Block (Analysis a) -> State Int (Block (Analysis a)) + eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a)) eachBlock b = do n <- get - put $ (n + 1) + put (n + 1) return . labelWithinBlocks $ setAnnotation ((getAnnotation b) { insLabel = Just n }) b - transform :: Data a => TransFuncM (State Int) Block ProgramFile a + transform :: Data a => TransFuncM (State ASTBlockNode) Block ProgramFile a transform = transformBiM -- A version of labelBlocks that works on all AST-blocks inside of a @@ -65,27 +70,27 @@ -- numbers. The reason that this function must exist is because -- additional AST-blocks are generated within the process of creating -- basic-block graphs, and must also be labelled. -labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a)) -labelBlocksInBBGr pf = transform (nmapM' (mapM eachBlock)) pf +labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a)) +labelBlocksInBBGr = transform (bbgrMapM (nmapM' (mapM eachBlock))) where - eachBlock :: Data a => Block (Analysis a) -> State Int (Block (Analysis a)) + eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a)) eachBlock b | a@Analysis { insLabel = Nothing } <- getAnnotation b = do n <- get put $ n + 1 return . analyseAllLhsVars1 . labelWithinBlocks $ setAnnotation (a { insLabel = Just n }) b | otherwise = return . analyseAllLhsVars1 $ b - transform :: Data a => (BBGr a -> State Int (BBGr a)) -> - ProgramFile a -> State Int (ProgramFile a) + transform :: Data a => (BBGr a -> State ASTBlockNode (BBGr a)) -> + ProgramFile a -> State ASTBlockNode (ProgramFile a) transform = transformBiM -- Sets the label on each Index within a Block to match the Block, for -- later look-up. labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a) -labelWithinBlocks = perBlock +labelWithinBlocks = perBlock' where - perBlock :: Block (Analysis a) -> Block (Analysis a) - perBlock b = + perBlock' :: Block (Analysis a) -> Block (Analysis a) + 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 @@ -98,7 +103,7 @@ mfill i = fmap (fill i) mmfill i = fmap (fmap (fill i)) - fill :: forall f. (Data (f (Analysis a))) => Maybe Int -> f (Analysis a) -> f (Analysis a) + fill :: forall f. (Data (f (Analysis a))) => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a) fill Nothing = id fill (Just i) = transform perIndex where @@ -110,16 +115,18 @@ -------------------------------------------------- +type ASTExprNode = Int + -- Insert unique labels on each expression for easier look-up later. -labelExprs :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a)) -labelExprs gr = transform eachExpr gr +labelExprs :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a)) +labelExprs = transform eachExpr where - eachExpr :: Data a => Expression (Analysis a) -> State Int (Expression (Analysis a)) + eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a)) eachExpr e = do n <- get - put $ (n + 1) + put (n + 1) return $ setAnnotation ((getAnnotation e) { insLabel = Just n }) e - transform :: Data a => TransFuncM (State Int) Expression ProgramFile a + transform :: Data a => TransFuncM (State ASTExprNode) Expression ProgramFile a transform = transformBiM -- A version of labelExprs that works on all expressions inside of a @@ -127,21 +134,21 @@ -- numbers. The reason that this function must exist is because -- additional expressions are generated within the process of creating -- basic-block graphs, and must also be labelled. -labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a)) -labelExprsInBBGr pf = transformBB (nmapM' (transformExpr eachExpr)) pf +labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a)) +labelExprsInBBGr = transformBB (bbgrMapM (nmapM' (transformExpr eachExpr))) where - eachExpr :: Data a => Expression (Analysis a) -> State Int (Expression (Analysis a)) + eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a)) eachExpr e | a@Analysis { insLabel = Nothing } <- getAnnotation e = do n <- get put $ n + 1 return $ setAnnotation (a { insLabel = Just n }) e | otherwise = return e - transformBB :: Data a => (BBGr a -> State Int (BBGr a)) -> - ProgramFile a -> State Int (ProgramFile a) + transformBB :: Data a => (BBGr a -> State ASTExprNode (BBGr a)) -> + ProgramFile a -> State ASTExprNode (ProgramFile a) transformBB = transformBiM - transformExpr :: Data a => (Expression (Analysis a) -> State Int (Expression (Analysis a))) -> - [Block (Analysis a)] -> State Int [Block (Analysis a)] + transformExpr :: Data a => (Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))) -> + [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)] transformExpr = transformBiM -------------------------------------------------- @@ -154,45 +161,49 @@ where bs = case pu of - PUMain _ _ _ bs _ -> bs; - PUSubroutine _ _ _ _ _ bs _ -> bs; - PUFunction _ _ _ _ _ _ _ bs _ -> bs + PUMain _ _ _ bs' _ -> bs'; + PUSubroutine _ _ _ _ _ bs' _ -> bs'; + PUFunction _ _ _ _ _ _ _ bs' _ -> bs' _ -> [] bbs = execBBlocker (processBlocks bs) fix = delEmptyBBlocks . delUnreachable . insExitEdges pu lm . delInvalidExits . insEntryEdges pu - gr = fix (insEdges (newEdges bbs) (bbGraph bbs)) - pu' = setAnnotation ((getAnnotation pu) { bBlocks = Just gr }) pu + gr = bbgrMap (fix . insEdges (newEdges bbs)) $ bbGraph bbs + gr' = gr { bbgrEntries = [0], bbgrExits = [-1] } -- conventional entry/exit blocks + pu' = setAnnotation ((getAnnotation pu) { bBlocks = Just gr' }) pu lm = labelMap bbs -- Create node 0 "the start node" and link it -- for now assume only one entry +insEntryEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] () insEntryEdges pu = insEdge (0, 1, ()) . insNode (0, bs) where bs = genInOutAssignments pu False -- create assignments of the form "x = f[1]" or "f[1] = x" at the -- entry/exit bblocks. +genInOutAssignments :: Data a => ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)] genInOutAssignments pu exit - | exit, PUFunction _ _ _ _ _ _ _ _ _ <- pu = zipWith genAssign (genVar a0 noSrcSpan fn:vs) [0..] - | otherwise = zipWith genAssign vs [1..] + | exit, PUFunction{} <- pu = zipWith genAssign (genVar a0 noSrcSpan fn:vs) [(0::Integer)..] + | otherwise = zipWith genAssign vs [(1::Integer)..] where Named fn = puName pu name i = fn ++ "[" ++ show i ++ "]" a0 = head $ initAnalysis [prevAnnotation a] (a, s, vs) = case pu of - PUFunction _ _ _ _ _ (Just (AList a s vs)) _ _ _ -> (a, s, vs) - PUSubroutine _ _ _ _ (Just (AList a s vs)) _ _ -> (a, s, vs) - PUFunction a s _ _ _ Nothing _ _ _ -> (a, s, []) - PUSubroutine a s _ _ Nothing _ _ -> (a, s, []) + PUFunction _ _ _ _ _ (Just (AList a' s' vs')) _ _ _ -> (a', s', vs') + PUSubroutine _ _ _ _ (Just (AList a' s' vs')) _ _ -> (a', s', vs') + PUFunction a' s' _ _ _ Nothing _ _ _ -> (a', s', []) + PUSubroutine a' s' _ _ Nothing _ _ -> (a', s', []) _ -> (error "genInOutAssignments", error "genInOutAssignments", []) genAssign v i = analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a0 s vl vr) where (vl, vr) = if exit then (v', v) else (v, v') v' = case v of - ExpValue a' s (ValVariable _) -> genVar a0 s (name i) - _ -> error $ "unhandled genAssign case: " ++ show (fmap (const ()) v) + ExpValue _ s' (ValVariable _) -> genVar a0 s' (name i) + _ -> error $ "unhandled genAssign case: " ++ show (void (const ()) v) -- Remove exit edges for bblocks where standard construction doesn't apply. +delInvalidExits :: DynGraph gr => gr [Block a] b -> gr [Block a] b delInvalidExits gr = flip delEdges gr $ do n <- nodes gr bs <- maybeToList $ lab gr n @@ -201,40 +212,81 @@ return $ toEdge le -- Insert exit edges for bblocks with special handling. +insExitEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> M.Map String Node -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] () insExitEdges pu lm gr = flip insEdges (insNode (-1, bs) gr) $ do n <- nodes gr - guard $ null (out gr n) - bs <- maybeToList $ lab gr n - n' <- examineFinalBlock lm bs + bs' <- maybeToList $ lab gr n + guard $ null (out gr n) || isFinalBlockExceptionalCtrlXfer bs' + n' <- examineFinalBlock lm bs' return (n, n', ()) where bs = genInOutAssignments pu True +-- Given a list of ControlPairs for a StRead, return (if any exists) +-- the expression accompanying an END or ERR, respectively +getReadCtrlXfers :: [ControlPair a] -> (Maybe (Expression a), Maybe (Expression a)) +getReadCtrlXfers = foldl' handler (Nothing, Nothing) + where + handler r@(r1, r2) (ControlPair _ _ ms e) = case ms of + Nothing -> r + Just s -> + case map toLower s of + "end" -> (Just e, r2) + "err" -> (r1, Just e) + _ -> r + -- Find target of Goto statements (Return statements default target to -1). +examineFinalBlock :: Num a1 => M.Map String a1 -> [Block a2] -> [a1] examineFinalBlock lm bs@(_:_) | BlStatement _ _ _ (StGotoUnconditional _ _ k) <- last bs = [lookupBBlock lm k] | BlStatement _ _ _ (StGotoAssigned _ _ _ ks) <- last bs = map (lookupBBlock lm) (maybe [] aStrip ks) | BlStatement _ _ _ (StGotoComputed _ _ ks _) <- last bs = map (lookupBBlock lm) (aStrip ks) - | BlStatement _ _ _ (StReturn _ _ _) <- last bs = [-1] + | BlStatement _ _ _ StReturn{} <- last bs = [-1] | BlStatement _ _ _ (StIfArithmetic _ _ _ k1 k2 k3) <- last bs = [lookupBBlock lm k1, lookupBBlock lm k2, lookupBBlock lm k3] + | BlStatement _ _ _ (StRead _ _ cs _) <- last bs = + let (me, mr) = getReadCtrlXfers $ aStrip cs + f = maybe [] $ \v -> [lookupBBlock lm v] + in f me ++ f mr examineFinalBlock _ _ = [-1] -- True iff the final block in the list is an explicit control transfer. +isFinalBlockCtrlXfer :: [Block a] -> Bool isFinalBlockCtrlXfer bs@(_:_) - | BlStatement _ _ _ (StGotoUnconditional {}) <- last bs = True - | BlStatement _ _ _ (StGotoAssigned {}) <- last bs = True - | BlStatement _ _ _ (StGotoComputed {}) <- last bs = True - | BlStatement _ _ _ (StReturn {}) <- last bs = True - | BlStatement _ _ _ (StIfArithmetic {}) <- last bs = True -isFinalBlockCtrlXfer _ = False + | BlStatement _ _ _ StGotoUnconditional{} <- last bs = True + | BlStatement _ _ _ StGotoAssigned{} <- last bs = True + | BlStatement _ _ _ StReturn{} <- last bs = True + | BlStatement _ _ _ StIfArithmetic{} <- last bs = True + -- Note that StGotoComputed is not handled here since it + -- is not an explicit control transfer if the expression + -- does not index into one of the labels, in which case + -- it acts as a StContinue +isFinalBlockCtrlXfer _ = False -lookupBBlock lm (ExpValue _ _ (ValInteger l)) = (-1) `fromMaybe` M.lookup l lm +-- True iff the final block in the list has an control transfer +-- with exceptional circumstances, like a StGotoComputed or a StRead +isFinalBlockExceptionalCtrlXfer :: [Block a] -> Bool +isFinalBlockExceptionalCtrlXfer bs@(_:_) + | BlStatement _ _ _ StGotoComputed{} <- last bs = True + | BlStatement _ _ _ StRead{} <- last bs = True +isFinalBlockExceptionalCtrlXfer _ = False + +-- Drop any '0' that appear at the beginning of a label since +-- labels like "40" and "040" are considered equivalent. +dropLeadingZeroes :: String -> String +dropLeadingZeroes = dropWhile (== '0') + +lookupBBlock :: Num a1 => M.Map String a1 -> Expression a2 -> a1 +lookupBBlock lm a = + case a of + ExpValue _ _ (ValInteger l) -> (-1) `fromMaybe` M.lookup (dropLeadingZeroes l) lm -- This occurs if a variable is being used for a label, e.g., from a Fortran 77 ASSIGN statement -lookupBBlock lm (ExpValue _ _ (ValVariable l)) = (-1) `fromMaybe` M.lookup l lm + ExpValue _ _ (ValVariable l) -> (-1) `fromMaybe` M.lookup l lm + _ -> error "unhandled lookupBBlock" -- Seek out empty bblocks with a single entrance and a single exit -- edge, and remove them, re-establishing the edges without them. +delEmptyBBlocks :: (Foldable t, DynGraph gr) => gr (t a) b -> gr (t a) b delEmptyBBlocks gr | (n, s, t, l):_ <- candidates = delEmptyBBlocks . insEdge (s, t, l) . delNode n $ gr | otherwise = gr @@ -247,6 +299,7 @@ return (n, s, t, l) -- Delete unreachable nodes. +delUnreachable :: DynGraph gr => gr a b -> gr a b delUnreachable gr = subgraph (reachable 0 gr) gr -------------------------------------------------- @@ -261,7 +314,8 @@ , newEdges :: [LEdge ()] } -- Initial state -bbs0 = BBS { bbGraph = empty, curBB = [], curNode = 1 +bbs0 :: BBState a +bbs0 = BBS { bbGraph = bbgrEmpty, curBB = [], curNode = 1 , labelMap = M.empty, nums = [2..], tempNums = [0..] , newEdges = [] } @@ -283,7 +337,7 @@ startN <- gets curNode mapM_ perBlock bs endN <- gets curNode - modify $ \ st -> st { bbGraph = insNode (endN, reverse (curBB st)) (bbGraph st) + modify $ \ st -> st { bbGraph = bbgrMap (insNode (endN, reverse (curBB st))) (bbGraph st) , curBB = [] } return (startN, endN) @@ -295,14 +349,14 @@ -- invariant: curBB is in reverse order perBlock b@(BlIf _ _ _ _ exps bss _) = do processLabel b - exps' <- forM (map fromJust . filter isJust $ exps) processFunctionCalls + _ <- forM (catMaybes . filter isJust $ exps) processFunctionCalls addToBBlock $ stripNestedBlocks b (ifN, _) <- closeBBlock -- go through nested AST-blocks startEnds <- forM bss $ \ bs -> do (thenN, endN) <- processBlocks bs - genBBlock + _ <- genBBlock return (thenN, endN) -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN @@ -319,7 +373,7 @@ -- go through nested AST-blocks startEnds <- forM bss $ \ bs -> do (caseN, endN) <- processBlocks bs - genBBlock + _ <- genBBlock return (caseN, endN) -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN @@ -328,77 +382,102 @@ -- 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 +perBlock b@(BlStatement _ _ _ (StGotoComputed _ _ _ exp)) = do + processLabel b + _ <- processFunctionCalls exp + addToBBlock b + (gotoN, nxtN) <- closeBBlock + createEdges [(gotoN, nxtN, ())] + perBlock b@(BlStatement a ss _ (StIfLogical _ _ exp stm)) = do processLabel b - exp' <- processFunctionCalls exp + _ <- processFunctionCalls exp addToBBlock $ stripNestedBlocks b -- start a bblock for the nested statement inside the If (ifN, thenN) <- closeBBlock -- build pseudo-AST-block to contain nested statement - processBlocks [BlStatement a ss Nothing stm] - endN <- gets curNode + _ <- processBlocks [BlStatement a{ insLabel = Nothing } ss Nothing stm] + _ <- gets curNode -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN nxtN <- genBBlock createEdges [(ifN, thenN, ()), (ifN, nxtN, ()), (thenN, nxtN, ())] -perBlock b@(BlStatement _ _ _ (StIfArithmetic {})) = +perBlock b@(BlStatement _ _ _ StIfArithmetic{}) = -- Treat an arithmetic if similarly to a goto processLabel b >> addToBBlock b >> closeBBlock_ -perBlock b@(BlDo _ _ mlab _ _ (Just spec) bs _) = do +perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec - e1' <- processFunctionCalls e1 - e2' <- processFunctionCalls e2 - me3' <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing + _ <- processFunctionCalls e1 + _ <- processFunctionCalls e2 + _ <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing perDoBlock Nothing b bs perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs -perBlock b@(BlStatement _ _ _ (StReturn {})) = +perBlock b@(BlStatement _ _ _ StReturn{}) = processLabel b >> addToBBlock b >> closeBBlock_ -perBlock b@(BlStatement _ _ _ (StGotoUnconditional {})) = +perBlock b@(BlStatement _ _ _ StGotoUnconditional{}) = processLabel b >> addToBBlock b >> closeBBlock_ -perBlock b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ _) Nothing)) = do +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 b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ _) (Just aargs))) = do +perBlock (BlStatement a s l (StCall a' s' cn@ExpValue{} (Just aargs))) = do + let a0 = head . initAnalysis $ [prevAnnotation a] let exps = map extractExp . 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 () + 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 = ExpValue a s (ValVariable (name i)) - formal e i = ExpValue a s (ValVariable (name i)) - where a = getAnnotation e; s = getSpan e - forM_ (zip exps [1..]) $ \ (e, i) -> do - e' <- processFunctionCalls e - addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StExpressionAssign a' s' (formal e' i) e') - (_, dummyCallN) <- closeBBlock + 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 "dummy call" bblock with no parameters in the StCall AST-node. - addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' cn Nothing) + (formalN', dummyCallN) <- closeBBlock + -- formalN' may differ from formalN when additional bblocks were + -- generated by processFunctionCalls. + + let dummyArgs = map (Argument a0 s' Nothing) (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 -- re-assign the variables using the values of the formal parameters, if possible -- (because call-by-reference) - forM_ (zip exps [1..]) $ \ (e, i) -> + forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> -- this is only possible for l-expressions - if isLExpr e then - addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StExpressionAssign a' s' e (formal e i)) - else return () + (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, ()) + createEdges [ (prevN, formalN, ()), (formalN', dummyCallN, ()) , (dummyCallN, returnedN, ()), (returnedN, nextN, ()) ] +perBlock b@(BlStatement _ _ _ (StRead _ _ cs _)) = do + let (end, err) = getReadCtrlXfers $ aStrip cs + + processLabel b + b' <- descendBiM processFunctionCalls b + addToBBlock b' + + when (isJust end || isJust err) $ do + (readN, nxtN) <- closeBBlock + createEdges [(readN, nxtN, ())] + perBlock b = do processLabel b b' <- descendBiM processFunctionCalls b @@ -414,9 +493,9 @@ case getLabel b of Just (ExpValue _ _ (ValInteger l)) -> insertLabel l doN _ -> return () - case repeatExpr of Just e -> processFunctionCalls e >> return (); Nothing -> return () + case repeatExpr of Just e -> void (processFunctionCalls e); Nothing -> return () addToBBlock $ stripNestedBlocks b - closeBBlock + _ <- closeBBlock -- process nested bblocks inside of do-statement (startN, endN) <- processBlocks bs n' <- genBBlock @@ -433,7 +512,8 @@ processLabel _ = return () -- Inserts into labelMap -insertLabel l n = modify $ \ st -> st { labelMap = M.insert l n (labelMap st) } +insertLabel :: MonadState (BBState a) m => String -> Node -> m () +insertLabel l n = modify $ \ st -> st { labelMap = M.insert (dropLeadingZeroes l) n (labelMap st) } -- Puts an AST block into the current bblock. addToBBlock :: Block a -> BBlocker a () @@ -443,10 +523,11 @@ closeBBlock :: BBlocker a (Node, Node) closeBBlock = do n <- gets curNode - modify $ \ st -> st { bbGraph = insNode (n, reverse (curBB st)) (bbGraph st), curBB = [] } + modify $ \ st -> st { bbGraph = bbgrMap (insNode (n, reverse (curBB st))) (bbGraph st), curBB = [] } n' <- genBBlock return (n, n') -closeBBlock_ = closeBBlock >> return () +closeBBlock_ :: StateT (BBState a) Identity () +closeBBlock_ = void closeBBlock -- Starts up a new bblock. genBBlock :: BBlocker a Int @@ -456,23 +537,25 @@ return n' -- Adds labeled-edge mappings. +createEdges :: MonadState (BBState a) m => [LEdge ()] -> m () createEdges es = modify $ \ st -> st { newEdges = es ++ newEdges st } -- Generates a new node number. gen :: BBlocker a Int gen = do - n:ns <- gets nums + ~(n:ns) <- gets nums modify $ \ s -> s { nums = ns } return n genTemp :: String -> BBlocker a String genTemp str = do - n:ns <- gets tempNums + ~(n:ns) <- gets tempNums modify $ \ s -> s { tempNums = ns } return $ "_" ++ str ++ "_t#" ++ show n -- Strip nested code not necessary since it is duplicated in another -- basic block. +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 @@ -498,17 +581,15 @@ -- create bblock that assigns formal parameters (fn[1], fn[2], ...) let name i = varName fn ++ "[" ++ show i ++ "]" - let setName n e = setAnnotation ((getAnnotation e) { uniqueName = Just n, sourceName = Just n }) e - let formal (ExpValue a s (ValVariable _)) i = setName n $ ExpValue a0 s (ValVariable n) - where n = name i - formal e i = setName n $ ExpValue a0 s (ValVariable n) - where a = getAnnotation e; s = getSpan e; n = name i - forM_ (zip exps [1..]) $ \ (e, i) -> do + let formal (ExpValue _ s'' (ValVariable _)) i = genVar a0 s'' $ name i + formal e i = genVar a0 (getSpan e) $ name i + + forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' (formal e i) e) (_, dummyCallN) <- closeBBlock - let retV = setName (name 0) $ ExpValue a0 s (ValVariable (name 0)) - let dummyArgs = map (Argument a0 s' Nothing) (retV:map (uncurry formal) (zip exps [1..])) + let retV = genVar a0 s $ name (0::Integer) + let dummyArgs = map (Argument a0 s' Nothing) (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)) @@ -516,13 +597,12 @@ -- re-assign the variables using the values of the formal parameters, if possible -- (because call-by-reference) - forM_ (zip exps [1..]) $ \ (e, i) -> + forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> -- this is only possible for l-expressions - if isLExpr e then - addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' e (formal e i)) - else return () + (when (isLExpr e) $ + addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' e (formal e i))) tempName <- genTemp (varName fn) - let temp = setName tempName $ ExpValue a0 s (ValVariable tempName) + let temp = genVar a0 s tempName addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a0 s' temp retV) (_, nextN) <- closeBBlock @@ -533,26 +613,15 @@ return temp processFunctionCall e = return e +extractExp :: Argument a -> Expression a extractExp (Argument _ _ _ exp) = exp -------------------------------------------------- -- Supergraph: all program units in one basic-block graph -data SuperBBGr a = SuperBBGr { graph :: BBGr a - , clusters :: IM.IntMap ProgramUnitName - , entries :: M.Map PUName SuperNode } - --- | Extract graph from SuperBBGr -superBBGrGraph :: SuperBBGr a -> BBGr a -superBBGrGraph = graph - --- | Extract entry map from SuperBBGr -superBBGrEntries :: SuperBBGr a -> M.Map ProgramUnitName SuperNode -superBBGrEntries = entries - --- | Extract cluster map from SuperBBGr -superBBGrClusters :: SuperBBGr a -> IM.IntMap ProgramUnitName -superBBGrClusters = clusters +data SuperBBGr a = SuperBBGr { superBBGrGraph :: BBGr a + , superBBGrClusters :: IM.IntMap ProgramUnitName + , superBBGrEntries :: M.Map PUName SuperNode } type SuperNode = Node type SuperEdge = (SuperNode, SuperNode, ELabel) @@ -561,12 +630,14 @@ type ELabel = () genSuperBBGr :: forall a. Data a => BBlockMap (Analysis a) -> SuperBBGr (Analysis a) -genSuperBBGr bbm = SuperBBGr { graph = superGraph'', clusters = cmap, entries = entryMap } +genSuperBBGr bbm = SuperBBGr { superBBGrGraph = superGraph'' + , superBBGrClusters = cmap + , superBBGrEntries = entryMap } where namedNodes :: [((PUName, Node), NLabel a)] - namedNodes = [ ((name, n), bs) | (name, gr) <- M.toList bbm, (n, bs) <- labNodes gr ] + namedNodes = [ ((name, n), bs) | (name, gr) <- M.toList bbm, (n, bs) <- labNodes (bbgrGr gr) ] namedEdges :: [((PUName, Node), (PUName, Node), ELabel)] - namedEdges = [ ((name, n), (name, m), l) | (name, gr) <- M.toList bbm, (n, m, l) <- labEdges gr ] + namedEdges = [ ((name, n), (name, m), l) | (name, gr) <- M.toList bbm, (n, m, l) <- labEdges (bbgrGr gr) ] superNodeMap :: M.Map (PUName, Node) SuperNode superNodeMap = M.fromList $ zip (map fst namedNodes) [1..] getSuperNode :: (PUName, Node) -> SuperNode @@ -585,7 +656,7 @@ -- Assumption: all StCalls appear by themselves in a bblock. stCalls :: [(SuperNode, String)] stCalls = [ (getSuperNode n, sub) | (n, [BlStatement _ _ _ (StCall _ _ e _)]) <- namedNodes - , v@(ExpValue _ _ _) <- [e] + , v@ExpValue{} <- [e] , let sub = varName v , Named sub `M.member` entryMap && Named sub `M.member` exitMap ] stCallCtxts :: [([SuperEdge], SuperNode, String, [SuperEdge])] @@ -603,25 +674,28 @@ mainEntry :: SuperNode -- (possibly more than one, arbitrarily take first) mainEntry:_ = [ n | (n, _) <- labNodes superGraph', null (pre superGraph' n) ] -- Rename the main entry point to 0 - superGraph'' :: Gr (NLabel a) ELabel - superGraph'' = delNode mainEntry . - insEdges [ (0, m, l) | (_, m, l) <- out superGraph' mainEntry ] . - insNode (0, []) $ superGraph' + superGraph'' :: BBGr (Analysis a) + superGraph'' = BBGr { bbgrGr = delNode mainEntry . + insEdges [ (0, m, l) | (_, m, l) <- out superGraph' mainEntry ] . + insNode (0, []) $ superGraph' + , bbgrEntries = (0:) . filter (/=mainEntry) . map snd . M.toList $ entryMap + , bbgrExits = (-1:) . map snd . M.toList $ exitMap } +fromJustMsg :: String -> Maybe a -> a fromJustMsg _ (Just x) = x fromJustMsg msg _ = error msg -------------------------------------------------- findLabeledBBlock :: String -> BBGr a -> Maybe Node -findLabeledBBlock lab gr = - listToMaybe [ n | (n, bs) <- labNodes gr, b <- bs - , ExpValue _ _ (ValInteger lab') <- maybeToList (getLabel b) - , lab == lab' ] +findLabeledBBlock llab gr = + listToMaybe [ n | (n, bs) <- labNodes (bbgrGr gr), b <- bs + , ExpValue _ _ (ValInteger llab') <- maybeToList (getLabel b) + , llab == llab' ] -- | Show a basic block graph in a somewhat decent way. showBBGr :: (Out a, Show a) => BBGr a -> String -showBBGr gr = execWriter . forM (labNodes gr) $ \ (n, bs) -> do +showBBGr (BBGr gr _ _) = execWriter . forM (labNodes gr) $ \ (n, bs) -> do let b = "BBLOCK " ++ show n ++ " -> " ++ show (map (\ (_, m, _) -> m) $ out gr n) tell $ "\n\n" ++ b tell $ "\n" ++ replicate (length b) '-' ++ "\n" @@ -629,23 +703,27 @@ -- | Show a basic block graph without the clutter showAnalysedBBGr :: (Out a, Show a) => BBGr (Analysis a) -> String -showAnalysedBBGr = showBBGr . nmap strip +showAnalysedBBGr = showBBGr . bbgrMap (nmap strip) where strip = map (fmap insLabel) -- | Show a basic block supergraph showSuperBBGr :: (Out a, Show a) => SuperBBGr (Analysis a) -> String -showSuperBBGr = showAnalysedBBGr . graph +showSuperBBGr = showAnalysedBBGr . superBBGrGraph -- | Pick out and show the basic block graphs in the program file analysis. showBBlocks :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String showBBlocks pf = perPU =<< getPUs pf where + perPU PUComment{} = "" perPU pu | Analysis { bBlocks = Just gr } <- getAnnotation pu = - dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ showBBGr (nmap strip gr) ++ "\n\n" + dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ showBBGr (bbgrMap (nmap strip) gr) ++ "\n\n" where p = "| Program Unit " ++ show (puName pu) ++ " |" dashes = replicate (length p) '-' - perPU _ = "" + perPU pu = + dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ unlines (map (pretty . fmap insLabel) (programUnitBody pu)) ++ "\n\n" + where p = "| Program Unit " ++ show (puName pu) ++ " |" + dashes = replicate (length p) '-' strip = map (fmap insLabel) getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)] getPUs = universeBi @@ -656,35 +734,38 @@ -- | Output a supergraph in the GraphViz DOT format superBBGrToDOT :: SuperBBGr a -> String -superBBGrToDOT sgr = bbgrToDOT' (clusters sgr) (graph sgr) +superBBGrToDOT sgr = bbgrToDOT' (superBBGrClusters sgr) (superBBGrGraph sgr) -- shared code for DOT output bbgrToDOT' :: IM.IntMap ProgramUnitName -> BBGr a -> String -bbgrToDOT' clusters gr = execWriter $ do +bbgrToDOT' clusters' (BBGr{ bbgrGr = gr }) = execWriter $ do tell "strict digraph {\n" tell "node [shape=box,fontname=\"Courier New\"]\n" - let entryNodes = filter (\ n -> null (pre gr n)) (nodes gr) - let nodes = bfsn entryNodes gr - forM nodes $ \ n -> do + let entryNodes = filter (null . pre gr) (nodes gr) + let nodes' = bfsn entryNodes gr + _ <- forM nodes' $ \ n -> do let Just bs = lab gr n - let mname = IM.lookup n clusters + let mname = IM.lookup n clusters' case mname of Just name -> do tell $ "subgraph \"cluster " ++ showPUName name ++ "\" {\n" tell $ "label=\"" ++ showPUName name ++ "\"\n" - tell $ "fontname=\"Courier New\"\nfontsize=24\n" + tell "fontname=\"Courier New\"\nfontsize=24\n" _ -> return () - tell $ "bb" ++ show n ++ "[label=\"" ++ show n ++ "\\l" ++ (concatMap showBlock bs) ++ "\"]\n" + tell $ "bb" ++ show n ++ "[label=\"" ++ show n ++ "\\l" ++ concatMap showBlock bs ++ "\"]\n" when (null bs) . tell $ "bb" ++ show n ++ "[shape=circle]\n" tell $ "bb" ++ show n ++ " -> {" - forM (suc gr n) $ \ m -> tell (" bb" ++ show m) + _ <- forM (suc gr n) $ \ m -> tell (" bb" ++ show m) tell "}\n" when (isJust mname) $ tell "}\n" tell "}\n" +showPUName :: ProgramUnitName -> String showPUName (Named n) = n -showPUName (NamelessBlockData) = ".blockdata." -showPUName (NamelessMain) = ".main." +showPUName NamelessBlockData = ".blockdata." +showPUName NamelessMain = ".main." +showPUName NamelessComment = ".comment." --- Some helper functions to output some pseudo-code for readability +-- | Some helper functions to output some pseudo-code for readability. +showBlock :: Block a -> String showBlock (BlStatement _ _ mlab st) | null (str :: String) = "" | otherwise = showLab mlab ++ str ++ "\\l" @@ -703,7 +784,8 @@ aIntercalate ", " showAttr aattrs ++ aIntercalate ", " showDecl adecls StDimension _ _ adecls -> "dimension " ++ aIntercalate ", " showDecl adecls - _ -> "" + StExit{} -> "exit" + _ -> "" showBlock (BlIf _ _ mlab _ (Just e1:_) _ _) = showLab mlab ++ "if " ++ showExpr e1 ++ "\\l" showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) = showLab mlab ++ "do " ++ showExpr e1 ++ " <- " ++ @@ -712,12 +794,16 @@ maybe "1" showExpr me4 ++ "\\l" where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do" -showBlock _ = "" +showBlock (BlComment{}) = "" +showBlock b = "" +showAttr :: Attribute a -> String showAttr (AttrParameter _ _) = "parameter" showAttr (AttrPublic _ _) = "public" showAttr (AttrPrivate _ _) = "private" +showAttr (AttrProtected _ _) = "protected" showAttr (AttrAllocatable _ _) = "allocatable" +showAttr (AttrAsynchronous _ _) = "asynchronous" showAttr (AttrDimension _ _ aDimDecs) = "dimension ( " ++ aIntercalate ", " showDim aDimDecs ++ " )" showAttr (AttrExternal _ _) = "external" @@ -729,66 +815,110 @@ showAttr (AttrPointer _ _) = "pointer" showAttr (AttrSave _ _) = "save" showAttr (AttrTarget _ _) = "target" +showAttr (AttrValue _ _) = "value" +showAttr (AttrVolatile _ _) = "volatile" +showAttr (AttrSuffix _ _ (SfxBind _ _ Nothing)) = "bind(c)" +showAttr (AttrSuffix _ _ (SfxBind _ _ (Just e))) = "bind(c,name=" ++ showExpr e ++ ")" -showLab Nothing = replicate 6 ' ' -showLab (Just (ExpValue _ _ (ValInteger l))) = ' ':l ++ replicate (5 - length l) ' ' +showLab :: Maybe (Expression a) -> String +showLab a = + case a of + Nothing -> replicate 6 ' ' + Just (ExpValue _ _ (ValInteger l)) -> ' ':l ++ replicate (5 - length l) ' ' + _ -> error "unhandled showLab" +showValue :: Value a -> Name showValue (ValVariable v) = v showValue (ValIntrinsic v) = v showValue (ValInteger v) = v showValue (ValReal v) = v showValue (ValComplex e1 e2) = "( " ++ showExpr e1 ++ " , " ++ showExpr e2 ++ " )" -showValue _ = "" +showValue (ValString s) = "\\\"" ++ escapeStr s ++ "\\\"" +showValue v = "" +escapeStr :: String -> String +escapeStr = map fst . unfoldr f . map (,False) + where + f [] = Nothing + f ((c,False):cs) + | c `elem` "\"\\" = Just (('\\', False), (c, True):cs) + f ((c,_):cs) = Just ((c, False), cs) + +showExpr :: Expression a -> String showExpr (ExpValue _ _ v) = showValue v showExpr (ExpBinary _ _ op e1 e2) = "(" ++ showExpr e1 ++ showOp op ++ showExpr e2 ++ ")" showExpr (ExpUnary _ _ op e) = "(" ++ showUOp op ++ showExpr e ++ ")" showExpr (ExpSubscript _ _ e1 aexps) = showExpr e1 ++ "[" ++ aIntercalate ", " showIndex aexps ++ "]" -showExpr _ = "" +showExpr e = "" +showIndex :: Index a -> String showIndex (IxSingle _ _ _ i) = showExpr i showIndex (IxRange _ _ l u s) = maybe "" showExpr l ++ -- Lower ':' : maybe "" showExpr u ++ -- Upper - maybe "" (\u -> ':' : showExpr u) s -- Stride + maybe "" (\u' -> ':' : showExpr u') s -- Stride +showUOp :: UnaryOp -> String showUOp Plus = "+" showUOp Minus = "-" showUOp Not = "!" +-- needs a custom instance +showUOp (UnCustom x) = show x +showOp :: BinaryOp -> String showOp Addition = " + " showOp Multiplication = " * " showOp Subtraction = " - " showOp Division = " / " +showOp Concatenation = " // " showOp op = " ." ++ show op ++ ". " -showType (TypeSpec _ _ t (Just s)) = showBaseType t ++ "(selector)" -- ++ show s +showType :: TypeSpec a -> String +showType (TypeSpec _ _ t (Just _)) = showBaseType t ++ "(selector)" -- ++ show s showType (TypeSpec _ _ t Nothing) = showBaseType t +showBaseType :: BaseType -> String showBaseType TypeInteger = "integer" showBaseType TypeReal = "real" showBaseType TypeDoublePrecision = "double" showBaseType TypeComplex = "complex" showBaseType TypeDoubleComplex = "doublecomplex" showBaseType TypeLogical = "logical" -showBaseType TypeCharacter = "character" -showBaseType (TypeCustom s) = s +showBaseType (TypeCharacter l k) = case (l, k) of + (Just cl, Just ki) -> "character(" ++ showCharLen cl ++ "," ++ ki ++ ")" + (Just cl, Nothing) -> "character(" ++ showCharLen cl ++ ")" + (Nothing, Just ki) -> "character(kind=" ++ ki ++ ")" + (Nothing, Nothing) -> "character" +showBaseType (TypeCustom s) = "type(" ++ s ++ ")" +showBaseType TypeByte = "byte" +showBaseType ClassStar = "class(*)" +showBaseType (ClassCustom s) = "class(" ++ s ++ ")" -showDecl (DeclArray _ _ e adims length initial) = +showCharLen :: CharacterLen -> String +showCharLen CharLenStar = "*" +showCharLen CharLenColon = ":" +showCharLen CharLenExp = "*" -- FIXME, possibly, with a more robust const-exp +showCharLen (CharLenInt i) = show i + +showDecl :: Declarator a -> String +showDecl (DeclArray _ _ e adims length' initial) = showExpr e ++ "(" ++ aIntercalate "," showDim adims ++ ")" ++ - maybe "" (\e -> "*" ++ showExpr e) length ++ - maybe "" (\e -> " = " ++ showExpr e) initial -showDecl (DeclVariable _ _ e length initial) = + maybe "" (\e' -> "*" ++ showExpr e') length' ++ + maybe "" (\e' -> " = " ++ showExpr e') initial +showDecl (DeclVariable _ _ e length' initial) = showExpr e ++ - maybe "" (\e -> "*" ++ showExpr e) length ++ - maybe "" (\e -> " = " ++ showExpr e) initial + maybe "" (\e' -> "*" ++ showExpr e') length' ++ + maybe "" (\e' -> " = " ++ showExpr e') initial +showDim :: DimensionDeclarator a -> String showDim (DimensionDeclarator _ _ me1 me2) = maybe "" ((++":") . showExpr) me1 ++ maybe "" showExpr me2 +aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1] aIntercalate sep f = intercalate sep . map f . aStrip +noSrcSpan :: SrcSpan noSrcSpan = SrcSpan initPosition initPosition -------------------------------------------------- @@ -798,7 +928,7 @@ ufoldM' :: (Graph gr, Monad m) => (Context a b -> c -> m c) -> c -> gr a b -> m c ufoldM' f u g | isEmpty g = return u - | otherwise = f c =<< (ufoldM' f u g') + | otherwise = f c =<< ufoldM' f u g' where (c,g') = matchAny g 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 @@ -4,52 +4,66 @@ module Language.Fortran.Analysis.DataFlow ( dominators, iDominators, DomMap, IDomMap , postOrder, revPostOrder, preOrder, revPreOrder, OrderF - , dataFlowSolver, showDataFlow, InOut, InOutMap, InF, OutF + , dataFlowSolver, InOut, InOutMap, InF, OutF , liveVariableAnalysis, reachingDefinitions , genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap , genFlowsToGraph, FlowsGraph , genVarFlowsToMap, VarFlowsMap + , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars , genBlockMap, genDefMap, BlockMap, DefMap , genCallMap, CallMap , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap , genLoopNodeMap, LoopNodeMap , genInductionVarMap, InductionVarMap , genInductionVarMapByASTBlock, InductionVarMapByASTBlock - , noPredNodes, genDerivedInductionMap, DerivedInductionMap, InductionExpr(..) + , genDerivedInductionMap, DerivedInductionMap, InductionExpr(..) + , showDataFlow, showFlowsDOT + , BBNodeMap, BBNodeSet, ASTBlockNodeMap, ASTBlockNodeSet, ASTExprNodeMap, ASTExprNodeSet ) where +import Prelude hiding (init) import Data.Generics.Uniplate.Data import GHC.Generics import Data.Data import Control.Monad.State.Lazy +import Control.Arrow ((&&&)) import Text.PrettyPrint.GenericPretty (Out) import Language.Fortran.Parser.Utils import Language.Fortran.Analysis +import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode) import Language.Fortran.AST import qualified Data.Map as M import qualified Data.IntMap.Lazy as IM import qualified Data.Set as S import qualified Data.IntSet as IS -import Data.Graph.Inductive hiding (trc, dom) +import Data.Graph.Inductive hiding (trc, dom, order, inn, out, rc) import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.Graph.Inductive.Query.BFS (bfen) import Data.Maybe import Data.List (foldl', foldl1', (\\), union, intersect) +import Control.Monad.Writer hiding (fix) -------------------------------------------------- +-- Better names for commonly used types +type BBNodeMap = IM.IntMap +type BBNodeSet = IS.IntSet +type ASTBlockNodeMap = IM.IntMap +type ASTBlockNodeSet = IS.IntSet +type ASTExprNodeMap = IM.IntMap +type ASTExprNodeSet = IS.IntSet -- | DomMap : node -> dominators of node -type DomMap = IM.IntMap IS.IntSet +type DomMap = BBNodeMap BBNodeSet -- | Compute dominators of each bblock in the graph. Node A dominates -- node B when all paths from the start node of that program unit must -- pass through node A in order to reach node B. That will be -- represented as the relation (B, [A, ...]) in the DomMap. dominators :: BBGr a -> DomMap -dominators gr = IM.map snd $ dataFlowSolver gr init revPostOrder inn out +dominators bbgr = IM.map snd $ dataFlowSolver bbgr init revPostOrder inn out where + gr = bbgrGr bbgr nodeSet = IS.fromList $ nodes gr - init n = (nodeSet, nodeSet) + init _ = (nodeSet, nodeSet) inn outF n | preNodes@(_:_) <- pre gr n = foldl1' IS.intersection . map outF $ preNodes @@ -58,7 +72,7 @@ out inF n = IS.insert n $ inF n -- | IDomMap : node -> immediate dominator of node -type IDomMap = IM.IntMap Int +type IDomMap = BBNodeMap BBNode -- | Compute the immediate dominator of each bblock in the graph. The -- immediate dominator is, in a sense, the 'closest' dominator of a @@ -66,14 +80,14 @@ -- dominated by node B if there does not exist any node C such that: -- node A dominates node C and node C dominates node B. iDominators :: BBGr a -> IDomMap -iDominators gr = IM.unions [ IM.fromList . flip iDom n $ gr | n <- noPredNodes gr ] +iDominators gr = IM.unions [ IM.fromList . flip iDom n $ bbgrGr gr | n <- bbgrEntries gr ] -- | An OrderF is a function from graph to a specific ordering of nodes. type OrderF a = BBGr a -> [Node] -- | The postordering of a graph outputs the label after traversal of children. postOrder :: OrderF a -postOrder gr = concatMap postorder . dff (noPredNodes gr) $ gr +postOrder gr = concatMap postorder . dff (bbgrEntries gr) $ bbgrGr gr -- | Reversed postordering. revPostOrder :: OrderF a @@ -81,24 +95,19 @@ -- | The preordering of a graph outputs the label before traversal of children. preOrder :: OrderF a -preOrder gr = concatMap preorder . dff (noPredNodes gr) $ gr +preOrder gr = concatMap preorder . dff (bbgrEntries gr) $ bbgrGr gr -- | Reversed preordering. revPreOrder :: OrderF a revPreOrder = reverse . preOrder --- | Compute the set of nodes with no predecessors. -noPredNodes :: Graph g => g a b -> [Node] --- noPredNodes = flip ufold [] $ \ ctx ns -> if null (pre' ctx) then node' ctx : ns else ns -- doesn't work, though it should -noPredNodes gr = filter (null . pre gr) (nodes gr) - -------------------------------------------------- -- | InOut : (dataflow into the bblock, dataflow out of the bblock) type InOut t = (t, t) -- | InOutMap : node -> (dataflow into node, dataflow out of node) -type InOutMap t = IM.IntMap (InOut t) +type InOutMap t = BBNodeMap (InOut t) -- | InF, a function that returns the in-dataflow for a given node type InF t = Node -> t @@ -117,22 +126,22 @@ where ordNodes = order gr initM = IM.fromList [ (n, initF n) | n <- ordNodes ] - step m = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ] - get m n = fromJustMsg ("dataFlowSolver: get " ++ show (n)) $ IM.lookup n m + step m = IM.fromList [ (n, (inF (snd . get' m) n, outF (fst . get' m) n)) | n <- ordNodes ] + get' m n = fromJustMsg ("dataFlowSolver: get " ++ show n) $ IM.lookup n m --- | Apply the iterative dataflow analysis method. -dataFlowSolver' :: Ord t => BBGr a -- ^ basic block graph - -> (Node -> InOut t) -- ^ initialisation for in and out dataflows - -> OrderF a -- ^ ordering function - -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function - -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function - -> [InOutMap t] -- ^ dataflow steps -dataFlowSolver' gr initF order inF outF = iterate step initM - where - ordNodes = order gr - initM = IM.fromList [ (n, initF n) | n <- ordNodes ] - step m = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ] - get m n = fromJustMsg ("dataFlowSolver': get " ++ show (n)) $ IM.lookup n m +-- Similar to above but return a list of states instead of just the final one. +--dataFlowSolver' :: Ord t => BBGr a -- ^ basic block graph +-- -> (Node -> InOut t) -- ^ initialisation for in and out dataflows +-- -> OrderF a -- ^ ordering function +-- -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function +-- -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function +-- -> [InOutMap t] -- ^ dataflow steps +--dataFlowSolver' gr initF order inF outF = iterate step initM +-- where +-- ordNodes = order gr +-- initM = IM.fromList [ (n, initF n) | n <- ordNodes ] +-- step m = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ] +-- get m n = fromJustMsg ("dataFlowSolver': get " ++ show (n)) $ IM.lookup n m -------------------------------------------------- @@ -140,14 +149,14 @@ -- Each AST-block has been given a unique number label during analysis -- of basic blocks. The purpose of this map is to provide the ability -- to lookup AST-blocks by label. -type BlockMap a = IM.IntMap (Block (Analysis a)) +type BlockMap a = ASTBlockNodeMap (Block (Analysis a)) -- | Build a BlockMap from the AST. This can only be performed after -- analyseBasicBlocks has operated, created basic blocks, and labeled -- all of the AST-blocks with unique numbers. genBlockMap :: Data a => ProgramFile (Analysis a) -> BlockMap a genBlockMap pf = IM.fromList [ (i, b) | gr <- uni pf - , (_, bs) <- labNodes gr + , (_, bs) <- labNodes $ bbgrGr gr , b <- bs , let Just i = insLabel (getAnnotation b) ] where @@ -155,7 +164,7 @@ uni = universeBi -- | DefMap : variable name -> { AST-block label } -type DefMap = M.Map Name IS.IntSet +type DefMap = M.Map Name ASTBlockNodeSet -- | Build a DefMap from the BlockMap. This allows us to quickly look -- up the AST-block labels that wrote into the given variable. @@ -174,9 +183,9 @@ liveVariableAnalysis gr = dataFlowSolver gr (const (S.empty, S.empty)) revPreOrder inn out where inn outF b = (outF b S.\\ kill b) `S.union` gen b - out innF b = S.unions [ innF s | s <- suc gr b ] - kill b = bblockKill (fromJustMsg "liveVariableAnalysis kill" $ lab gr b) - gen b = bblockGen (fromJustMsg "liveVariableAnalysis gen" $ lab gr b) + out innF b = S.unions [ innF s | s <- suc (bbgrGr gr) b ] + kill b = bblockKill (fromJustMsg "liveVariableAnalysis kill" $ lab (bbgrGr gr) b) + gen b = bblockGen (fromJustMsg "liveVariableAnalysis gen" $ lab (bbgrGr gr) b) -- | Iterate "KILL" set through a single basic block. bblockKill :: Data a => [Block (Analysis a)] -> S.Set Name @@ -184,17 +193,10 @@ -- | Iterate "GEN" set through a single basic block. bblockGen :: Data a => [Block (Analysis a)] -> S.Set Name -bblockGen bs = S.fromList . fst . foldl' f ([], []) $ zip (map blockGen bs) (map blockKill bs) +bblockGen bs = S.fromList . fst . foldl' f ([], []) $ map (blockGen &&& blockKill) bs where f (bbgen, bbkill) (gen, kill) = ((gen \\ bbkill) `union` bbgen, kill `union` bbkill) --- | Iterate "GEN" set through a single basic block. --- attempt to make this faster using sets internally (no obvious speedup though) -bblockGenFast :: Data a => [Block (Analysis a)] -> S.Set Name -bblockGenFast bs = fst . foldl' f (S.empty, S.empty) $ zip (map (S.fromList . blockGen) bs) (map (S.fromList . blockKill) bs) - where - f (bbgen, bbkill) (gen, kill) = ((gen S.\\ bbkill) `S.union` bbgen, kill `S.union` bbkill) - -- | "KILL" set for a single AST-block. blockKill :: Data a => Block (Analysis a) -> [Name] blockKill = blockVarDefs @@ -227,41 +229,41 @@ -- named v. Label A may reach another program point labeled P if there -- is at least one program path from label A to label P that does not -- redefine variable v. -reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet +reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet reachingDefinitions dm gr = dataFlowSolver gr (const (IS.empty, IS.empty)) revPostOrder inn out where - inn outF b = IS.unions [ outF s | s <- pre gr b ] + inn outF b = IS.unions [ outF s | s <- pre (bbgrGr gr) b ] out innF b = gen `IS.union` (innF b IS.\\ kill) - where (gen, kill) = rdBblockGenKill dm (fromJustMsg "reachingDefinitions" $ lab gr b) + where (gen, kill) = rdBblockGenKill dm (fromJustMsg "reachingDefinitions" $ lab (bbgrGr gr) b) -- Compute the "GEN" and "KILL" sets for a given basic block. -rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (IS.IntSet, IS.IntSet) -rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ zip (map gen bs) (map kill bs) +rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (ASTBlockNodeSet, ASTBlockNodeSet) +rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ map (gen &&& kill) bs where gen b | null (allLhsVars b) = IS.empty | otherwise = IS.singleton . fromJustMsg "rdBblockGenKill" . insLabel . getAnnotation $ b kill = rdDefs dm - f (bbgen, bbkill) (gen, kill) = - ((bbgen IS.\\ kill) `IS.union` gen, (bbkill IS.\\ gen) `IS.union` kill) + f (bbgen, bbkill) (gen', kill') = + ((bbgen IS.\\ kill') `IS.union` gen', (bbkill IS.\\ gen') `IS.union` kill') -- Set of all AST-block labels that also define variables defined by AST-block b -rdDefs :: Data a => DefMap -> Block (Analysis a) -> IS.IntSet +rdDefs :: Data a => DefMap -> Block (Analysis a) -> ASTBlockNodeSet rdDefs dm b = IS.unions [ IS.empty `fromMaybe` M.lookup y dm | y <- allLhsVars b ] -------------------------------------------------- -- | DUMap : definition -> { use } -type DUMap = IM.IntMap IS.IntSet +type DUMap = ASTBlockNodeMap ASTBlockNodeSet -- | def-use map: map AST-block labels of defining AST-blocks to the -- AST-blocks that may use the definition. -genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet -> DUMap +genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> DUMap genDUMap bm dm gr rdefs = IM.unionsWith IS.union duMaps where -- duMaps for each bblock duMaps = [ fst (foldl' inBBlock (IM.empty, is) bs) | (n, (is, _)) <- IM.toList rdefs, - let Just bs = lab gr n ] + let Just bs = lab (bbgrGr gr) n ] -- internal analysis within bblock; fold over list of AST-blocks inBBlock (duMap, inSet) b = (duMap', inSet') where @@ -272,13 +274,13 @@ where Just b' = IM.lookup i' bm uses = blockVarUses b duMap' = IM.unionWith IS.union duMap bduMap - gen b | null (allLhsVars b) = IS.empty - | otherwise = IS.singleton . fromJustMsg "genDUMap" . insLabel . getAnnotation $ b + gen b' | null (allLhsVars b') = IS.empty + | otherwise = IS.singleton . fromJustMsg "genDUMap" . insLabel . getAnnotation $ b' kill = rdDefs dm - inSet' = (inSet IS.\\ (kill b)) `IS.union` (gen b) + inSet' = (inSet IS.\\ kill b) `IS.union` gen b -- | UDMap : use -> { definition } -type UDMap = IM.IntMap IS.IntSet +type UDMap = ASTBlockNodeMap ASTBlockNodeSet -- | Invert the DUMap into a UDMap duMapToUdMap :: DUMap -> UDMap @@ -288,18 +290,18 @@ -- | use-def map: map AST-block labels of variable-using AST-blocks to -- the AST-blocks that define those variables. -genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet -> UDMap +genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> UDMap genUDMap bm dm gr = duMapToUdMap . genDUMap bm dm gr -------------------------------------------------- -- | Convert a UD or DU Map into a graph. -mapToGraph :: DynGraph gr => BlockMap a -> IM.IntMap IS.IntSet -> gr (Block (Analysis a)) () -mapToGraph bm m = mkGraph nodes edges +mapToGraph :: DynGraph gr => BlockMap a -> ASTBlockNodeMap ASTBlockNodeSet -> gr (Block (Analysis a)) () +mapToGraph bm m = mkGraph nodes' edges' where - nodes = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m) + nodes' = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m) , let iLabel = fromJustMsg "mapToGraph" (IM.lookup i bm) ] - edges = [ (i, j, ()) | (i, js) <- IM.toList m + edges' = [ (i, j, ()) | (i, js) <- IM.toList m , j <- IS.toList js ] -- | FlowsGraph : nodes as AST-block (numbered by label), edges @@ -310,7 +312,7 @@ genFlowsToGraph :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) - -> InOutMap IS.IntSet -- ^ result of reaching definitions + -> InOutMap ASTBlockNodeSet -- ^ result of reaching definitions -> FlowsGraph a genFlowsToGraph bm dm gr = mapToGraph bm . genDUMap bm dm gr @@ -328,22 +330,115 @@ -- planning to make revDM a surjection, after I flatten-out Fortran functions revDM = IM.fromListWith (curry fst) [ (i, v) | (v, is) <- M.toList dm, i <- IS.toList is ] -{-| -Finds the transitive closure of a directed graph. -Given a graph G=(V,E), its transitive closure is the graph: -G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G} --} -tc :: (DynGraph gr) => gr a b -> gr a () -tc g = newEdges `insEdges` insNodes ln empty +-------------------------------------------------- + +-- Integer arithmetic can be compile-time evaluated if we guard +-- against overflow, divide-by-zero. We must interpret the various +-- lexical forms of integers. +-- +-- Floating point arithmetic requires knowing the target machine and +-- being very careful with all the possible effects of IEEE FP. Will +-- leave it alone for now. + +-- conservative assumption: stay within bounds of signed 32-bit integer +minConst :: Integer +minConst = (-2::Integer) ^ (31::Integer) + +maxConst :: Integer +maxConst = (2::Integer) ^ (31::Integer) - (1::Integer) + +inBounds :: Integer -> Bool +inBounds x = minConst <= x && x <= maxConst + +-- | Evaluate possible constant expressions within tree. +constantFolding :: Constant -> Constant +constantFolding c = case c of + ConstBinary binOp a b | ConstInt x <- constantFolding a + , ConstInt y <- constantFolding b -> case binOp of + Addition | inBounds (x + y) -> ConstInt (x + y) + Subtraction | inBounds (x - y) -> ConstInt (x - y) + Multiplication | inBounds (x * y) -> ConstInt (x * y) + Division | y /= 0 -> ConstInt (x `div` y) + _ -> ConstBinary binOp (ConstInt x) (ConstInt y) + ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x) + ConstUnary Plus a -> constantFolding a + _ -> c + +-- | The map of all parameter variables and their corresponding values +type ParameterVarMap = M.Map Name Constant +-- | The map of all expressions and whether they are undecided (not +-- present in map), a constant value (Just Constant), or probably not +-- constant (Nothing). +type ConstExpMap = ASTExprNodeMap (Maybe Constant) + +-- | Generate a constant-expression map with information about the +-- expressions (identified by insLabel numbering) in the ProgramFile +-- pf (must have analysis initiated & basic blocks generated) . +genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap +genConstExpMap pf = ceMap where - ln = labNodes g - newEdges = [ toLEdge (u, v) () | (u, _) <- ln, (_, v) <- bfen (outU g u) g ] - outU gr = map toEdge . out gr + -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily. + pvMap = M.fromList $ + [ (varName v, getE e) + | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)] + , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)] + , (DeclVariable _ _ v _ (Just e)) <- universeBi st ] ++ + [ (varName v, getE e) + | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)] + , (DeclVariable _ _ v _ (Just e)) <- universeBi st ] + getV :: Expression (Analysis a) -> Maybe Constant + getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e) + -- Generate map of information about 'constant expressions'. + ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ] + getE :: Expression (Analysis a) -> Maybe Constant + getE = join . (flip IM.lookup ceMap <=< labelOf) + labelOf = insLabel . getAnnotation + doExpr :: Expression (Analysis a) -> Maybe Constant + doExpr e = case e of + ExpValue _ _ (ValInteger str) + | Just i <- readInteger str -> Just . ConstInt $ fromIntegral i + ExpValue _ _ (ValInteger str) -> Just $ ConstUninterpInt str + ExpValue _ _ (ValReal str) -> Just $ ConstUninterpReal str + ExpValue _ _ (ValVariable _) -> getV e + -- Recursively seek information about sub-expressions, relying on laziness. + ExpBinary _ _ binOp e1 e2 -> constantFolding <$> liftM2 (ConstBinary binOp) (getE e1) (getE e2) + ExpUnary _ _ unOp e' -> constantFolding <$> ConstUnary unOp <$> getE e' + _ -> Nothing + +-- | Get constant-expression information and put it into the AST +-- analysis annotation. Must occur after analyseBBlocks. +analyseConstExps :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) +analyseConstExps pf = pf' + where + ceMap = genConstExpMap pf + -- transform both the AST and the basic block graph + pf' = transformBB (bbgrMap (nmap (transformExpr insertConstExp))) $ transformBi insertConstExp pf + -- insert info about constExp into Expression annotation + insertConstExp :: Expression (Analysis a) -> Expression (Analysis a) + insertConstExp e = flip modifyAnnotation e $ \ a -> + a { constExp = constExp a `mplus` join (flip IM.lookup ceMap =<< insLabel (getAnnotation e)) } + -- utility functions for transforming expressions tucked away inside of the basic block graph + transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a) + transformBB = transformBi + transformExpr :: (Expression (Analysis a) -> Expression (Analysis a)) -> + [Block (Analysis a)] -> [Block (Analysis a)] + transformExpr = transformBi + +-- | Annotate AST with constant-expression information based on given +-- ParameterVarMap. +analyseParameterVars :: forall a. Data a => ParameterVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a) +analyseParameterVars pvm = transformBi expr + where + expr :: Expression (Analysis a) -> Expression (Analysis a) + expr e@(ExpValue _ _ ValVariable{}) + | Just con <- M.lookup (varName e) pvm = flip modifyAnnotation e $ \ a -> a { constExp = Just con } + expr e = e + -------------------------------------------------- --- | BackEdgeMap : node -> node -type BackEdgeMap = IM.IntMap Node +-- | BackEdgeMap : bblock node -> bblock node +type BackEdgeMap = BBNodeMap BBNode -- | Find the edges that 'loop back' in the graph; ones where the -- target node dominates the source node. If the backedges are viewed @@ -351,7 +446,7 @@ genBackEdgeMap :: Graph gr => DomMap -> gr a b -> BackEdgeMap genBackEdgeMap domMap = IM.fromList . filter isBackEdge . edges where - isBackEdge (s, t) = t `IS.member` (fromJustMsg "genBackEdgeMap" $ s `IM.lookup` domMap) + isBackEdge (s, t) = t `IS.member` fromJustMsg "genBackEdgeMap" (s `IM.lookup` domMap) -- | For each loop in the program, find out which bblock nodes are -- part of the loop by looking through the backedges (m, n) where n is @@ -360,13 +455,13 @@ -- of interest. Intersect this with the strongly-connected component -- containing m, in case of 'improper' graphs with weird control -- transfers. -loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [IS.IntSet] +loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [BBNodeSet] loopNodes bedges gr = [ IS.fromList (n:intersect (sccWith n gr) (rdfs [m] (delNode n gr))) | (m, n) <- IM.toList bedges ] --- | LoopNodeMap : node -> { node } -type LoopNodeMap = IM.IntMap IS.IntSet +-- | LoopNodeMap : bblock node -> { bblock node } +type LoopNodeMap = BBNodeMap BBNodeSet -- | Similar to loopNodes except it creates a map from loop-header to -- the set of loop nodes, for each loop-header. @@ -382,7 +477,7 @@ c:_ -> c -- | Map of loop header nodes to the induction variables within that loop. -type InductionVarMap = IM.IntMap (S.Set Name) +type InductionVarMap = BBNodeMap (S.Set Name) -- | Basic induction variables are induction variables that are the -- most easily derived from the syntactic structure of the program: @@ -390,8 +485,8 @@ basicInductionVars :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap basicInductionVars bedges gr = IM.fromListWith S.union [ (n, S.singleton v) | (_, n) <- IM.toList bedges - , let Just bs = lab gr n - , b@(BlDo {}) <- bs + , let Just bs = lab (bbgrGr gr) n + , b@BlDo{} <- bs , v <- blockVarDefs b ] @@ -402,19 +497,19 @@ genInductionVarMap = basicInductionVars -- | InductionVarMapByASTBlock : AST-block label -> { name } -type InductionVarMapByASTBlock = IM.IntMap (S.Set Name) +type InductionVarMapByASTBlock = ASTBlockNodeMap (S.Set Name) -- | Generate an induction variable map that is indexed by the labels -- on AST-blocks within those loops. genInductionVarMapByASTBlock :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMapByASTBlock genInductionVarMapByASTBlock bedges gr = loopsToLabs . genInductionVarMap bedges $ gr where - lnMap = genLoopNodeMap bedges gr - get = fromMaybe (error "missing loop-header node") . flip IM.lookup lnMap - astLabels n = [ i | b <- (universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (lab gr n) + lnMap = genLoopNodeMap bedges $ bbgrGr gr + get' = fromMaybe (error "missing loop-header node") . flip IM.lookup lnMap + astLabels n = [ i | b <- (universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (lab (bbgrGr gr) n) , let Just i = insLabel (getAnnotation b) ] loopsToLabs = IM.fromListWith S.union . concatMap loopToLabs . IM.toList - loopToLabs (n, ivs) = (map (,ivs) . astLabels) =<< IS.toList (get n) + loopToLabs (n, ivs) = (map (,ivs) . astLabels) =<< IS.toList (get' n) -- It's a 'lattice' but will leave it ungeneralised for the moment. data InductionExpr @@ -423,14 +518,21 @@ | IEBottom -- too difficult deriving (Show, Eq, Ord, Typeable, Generic, Data) -type DerivedInductionMap = IM.IntMap InductionExpr +type DerivedInductionMap = ASTExprNodeMap InductionExpr data IEFlow = IEFlow { ieFlowVars :: M.Map Name InductionExpr, ieFlowExprs :: DerivedInductionMap } deriving (Show, Eq, Ord, Typeable, Generic, Data) +ieFlowInsertVar :: Name -> InductionExpr -> IEFlow -> IEFlow ieFlowInsertVar v ie flow = flow { ieFlowVars = M.insert v ie (ieFlowVars flow) } + +ieFlowInsertExpr :: ASTExprNode -> InductionExpr -> IEFlow -> IEFlow ieFlowInsertExpr i ie flow = flow { ieFlowExprs = IM.insert i ie (ieFlowExprs flow) } + +emptyIEFlow :: IEFlow emptyIEFlow = IEFlow M.empty IM.empty + +joinIEFlows :: [IEFlow] -> IEFlow joinIEFlows flows = IEFlow flowV flowE where flowV = M.unionsWith joinInductionExprs (map ieFlowVars flows) @@ -442,13 +544,13 @@ genDerivedInductionMap bedges gr = ieFlowExprs . joinIEFlows . map snd . IM.elems . IM.filterWithKey inLoop $ inOutMaps where bivMap = basicInductionVars bedges gr -- basic indvars indexed by loop header node - loopNodeSet = IS.unions (loopNodes bedges gr) -- set of nodes within a loop + loopNodeSet = IS.unions (loopNodes bedges $ bbgrGr gr) -- set of nodes within a loop inLoop i _ = i `IS.member` loopNodeSet step :: IEFlow -> Block (Analysis a) -> IEFlow step flow b = case b of BlStatement _ _ _ (StExpressionAssign _ _ lv@(ExpValue _ _ (ValVariable _)) rhs) - | rhsLabel <- insLabel (getAnnotation rhs) + | _ <- insLabel (getAnnotation rhs) , flow'' <- ieFlowInsertVar (varName lv) (derivedInductionExpr flow' rhs) flow' -> stepExpr flow'' lv _ -> flow' where @@ -461,12 +563,12 @@ label = fromJustMsg "stepExpr" $ insLabel (getAnnotation e) out :: InF IEFlow -> OutF IEFlow - out inF node = foldl' step flow (fromJustMsg ("analyseDerivedIE out(" ++ show node ++ ")") $ lab gr node) + out inF node = foldl' step flow (fromJustMsg ("analyseDerivedIE out(" ++ show node ++ ")") $ lab (bbgrGr gr) node) where flow = joinIEFlows [fst (initF node), inF node] inn :: OutF IEFlow -> InF IEFlow - inn outF node = joinIEFlows [ outF p | p <- pre gr node ] + inn outF node = joinIEFlows [ outF p | p <- pre (bbgrGr gr) node ] initF :: Node -> InOut IEFlow initF node = case IM.lookup node bivMap of @@ -496,8 +598,8 @@ | lc == 0 = IELinear rn rc (lo + ro) | rc == 0 = IELinear ln lc (lo + ro) | otherwise = IEBottom -- maybe for future... -addInductionExprs ie1 IETop = IETop -addInductionExprs IETop ie2 = IETop +addInductionExprs _ IETop = IETop +addInductionExprs IETop _ = IETop addInductionExprs _ _ = IEBottom -- Negate an induction variable relationship. @@ -508,8 +610,8 @@ -- Combine two induction variable relationships through multiplication. mulInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr -mulInductionExprs (IELinear "" lc lo) (IELinear rn rc ro) = IELinear rn (rc * lo) (ro * lo) -mulInductionExprs (IELinear ln lc lo) (IELinear "" rc ro) = IELinear ln (lc * ro) (lo * ro) +mulInductionExprs (IELinear "" _ lo) (IELinear rn rc ro) = IELinear rn (rc * lo) (ro * lo) +mulInductionExprs (IELinear ln lc lo) (IELinear "" _ ro) = IELinear ln (lc * ro) (lo * ro) mulInductionExprs _ IETop = IETop mulInductionExprs IETop _ = IETop mulInductionExprs _ _ = IEBottom @@ -528,7 +630,7 @@ showDataFlow :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String showDataFlow pf = perPU =<< uni pf where - uni = (universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]) + uni = universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)] perPU pu | Analysis { bBlocks = Just gr } <- getAnnotation pu = dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr gr ++ "\n\n" where p = "| Program Unit " ++ show (puName pu) ++ " |" @@ -544,25 +646,54 @@ , ("lva", show (IM.toList $ lva gr)) , ("rd", show (IM.toList $ rd gr)) , ("backEdges", show bedges) - , ("topsort", show (topsort gr)) - , ("scc ", show (scc gr)) - , ("loopNodes", show (loopNodes bedges gr)) + , ("topsort", show (topsort $ bbgrGr gr)) + , ("scc ", show (scc $ bbgrGr gr)) + , ("loopNodes", show (loopNodes bedges $ bbgrGr gr)) , ("duMap", show (genDUMap bm dm gr (rd gr))) , ("udMap", show (genUDMap bm dm gr (rd gr))) - , ("flowsTo", show (edges $ genFlowsToGraph bm dm gr (rd gr))) + , ("flowsTo", show (edges flTo)) , ("varFlowsTo", show (genVarFlowsToMap dm (genFlowsToGraph bm dm gr (rd gr)))) , ("ivMap", show (genInductionVarMap bedges gr)) , ("ivMapByAST", show (genInductionVarMapByASTBlock bedges gr)) - , ("noPredNodes", show (noPredNodes gr)) + , ("constExpMap", show (genConstExpMap pf)) + , ("entries", show (bbgrEntries gr)) + , ("exits", show (bbgrExits gr)) ] where - bedges = genBackEdgeMap (dominators gr) gr - perPU _ = "" + bedges = genBackEdgeMap (dominators gr) $ bbgrGr gr + flTo = genFlowsToGraph bm dm gr (rd gr) + + perPU pu = dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr ++ "\n\n" + where p = "| Program Unit " ++ show (puName pu) ++ " |" + dashes = replicate (length p) '-' + dfStr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [ + ("constExpMap", show (genConstExpMap pf)) + ] + lva = liveVariableAnalysis bm = genBlockMap pf dm = genDefMap bm rd = reachingDefinitions dm cm = genCallMap pf +-- | Outputs a DOT-formatted graph showing flow-to data starting at +-- the given AST-Block node in the given Basic Block graph. +showFlowsDOT :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> BBGr (Analysis a) -> ASTBlockNode -> Bool -> String +showFlowsDOT pf bbgr astBlockId isFrom = execWriter $ do + let bm = genBlockMap pf + dm = genDefMap bm + flowsTo = genFlowsToGraph bm dm bbgr (reachingDefinitions dm bbgr) + flows | isFrom = grev flowsTo + | otherwise = flowsTo + tell "strict digraph {\n" + forM_ (bfsn [astBlockId] flows) $ \ n -> do + let pseudocode = maybe "" showBlock $ IM.lookup n bm + tell "node [shape=box,fontname=\"Courier New\"]\n" + tell $ "Bl" ++ show n ++ "[label=\"B" ++ show n ++ "\\l" ++ pseudocode ++ "\"]\n" + tell $ "Bl" ++ show n ++ " -> {" + forM_ (suc flows n) $ \ m -> tell (" Bl" ++ show m) + tell "}\n" + tell "}\n" + -------------------------------------------------- -- | CallMap : program unit name -> { name of function or subroutine } @@ -571,7 +702,7 @@ -- | Create a call map showing the structure of the program. genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap genCallMap pf = flip execState M.empty $ do - let uP = (universeBi :: Data a => ProgramFile a -> [ProgramUnit a]) + let uP = universeBi :: Data a => ProgramFile a -> [ProgramUnit a] forM_ (uP pf) $ \ pu -> do let n = puName pu let uS :: Data a => ProgramUnit a -> [Statement a] @@ -579,18 +710,31 @@ let uE :: Data a => ProgramUnit a -> [Expression a] uE = universeBi m <- get - let ns = [ varName v | StCall _ _ v@(ExpValue _ _ _) _ <- uS pu ] ++ - [ varName v | ExpFunctionCall _ _ v@(ExpValue _ _ _) _ <- uE pu ] + let ns = [ varName v | StCall _ _ v@ExpValue{} _ <- uS pu ] ++ + [ varName v | ExpFunctionCall _ _ v@ExpValue{} _ <- uE pu ] put $ M.insert n (S.fromList ns) m -------------------------------------------------- --- helper: iterate until predicate is satisfied. +-- | Finds the transitive closure of a directed graph. +-- Given a graph G=(V,E), its transitive closure is the graph: +-- G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G} +--tc :: (DynGraph gr) => gr a b -> gr a () +--tc g = newEdges `insEdges` insNodes ln empty +-- where +-- ln = labNodes g +-- newEdges = [ toLEdge (u, v) () | (u, _) <- ln, (_, v) <- bfen (outU g u) g ] +-- outU gr = map toEdge . out gr + +-- helper: iterate until predicate is satisfied; expects infinite list. converge :: (a -> a -> Bool) -> [a] -> a converge p (x:ys@(y:_)) | p x y = y | otherwise = converge p ys +converge _ [] = error "converge: empty list" +converge _ [_] = error "converge: finite list" +fromJustMsg :: String -> Maybe a -> a fromJustMsg _ (Just x) = x fromJustMsg msg _ = error msg diff --git a/src/Language/Fortran/Analysis/Renaming.hs b/src/Language/Fortran/Analysis/Renaming.hs --- a/src/Language/Fortran/Analysis/Renaming.hs +++ b/src/Language/Fortran/Analysis/Renaming.hs @@ -11,26 +11,25 @@ ( analyseRenames, analyseRenamesWithModuleMap, rename, unrename, ModuleMap ) where -import Debug.Trace - import Language.Fortran.AST hiding (fromList) import Language.Fortran.Intrinsics import Language.Fortran.Analysis import Language.Fortran.ParserMonad (FortranVersion(..)) import Prelude hiding (lookup) -import Data.Maybe (maybe, fromMaybe) +import Data.Maybe (mapMaybe, maybe, fromMaybe) import qualified Data.List as L -import Data.Map (insert, union, empty, lookup, Map, fromList) +import Data.Map (insert, empty, lookup, Map) import qualified Data.Map.Strict as M +import Control.Monad (void) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data +import Data.Functor.Identity (Identity) -------------------------------------------------- type ModuleMap = Map ProgramUnitName ModEnv -type NameMap = Map String String -- DEPRECATED type Renamer a = State RenameState a -- the monad. data RenameState = RenameState { langVersion :: FortranVersion @@ -47,17 +46,15 @@ -- | Annotate unique names for variable and function declarations and uses. analyseRenames :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) -analyseRenames (ProgramFile mi pus) = ProgramFile mi pus' +analyseRenames (ProgramFile mi pus) = cleanupUseRenames $ ProgramFile mi pus' where - (Just pus', _) = runRenamer (skimProgramUnits pus >> renameSubPUs (Just pus)) - (renameState0 (miVersion mi)) + (Just pus', _) = runRenamer (renameSubPUs (Just pus)) (renameState0 (miVersion mi)) -- | Annotate unique names for variable and function declarations and uses. With external module map. analyseRenamesWithModuleMap :: Data a => ModuleMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a) -analyseRenamesWithModuleMap mmap (ProgramFile mi pus) = ProgramFile mi pus' +analyseRenamesWithModuleMap mmap (ProgramFile mi pus) = cleanupUseRenames $ ProgramFile mi pus' where - (Just pus', _) = runRenamer (skimProgramUnits pus >> renameSubPUs (Just pus)) - (renameState0 (miVersion mi)) { moduleMap = mmap } + (Just pus', _) = runRenamer (renameSubPUs (Just pus)) (renameState0 (miVersion mi)) { moduleMap = mmap } -- | Take the unique name annotations and substitute them into the actual AST. rename :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) @@ -81,7 +78,7 @@ -- | Take a renamed program and undo the renames. unrename :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) -unrename pf = trPU fPU . trE fE $ pf +unrename = trPU fPU . trE fE where trE :: Data a => (Expression (Analysis a) -> Expression (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a) trE = transformBi @@ -93,9 +90,9 @@ trPU :: Data a => (ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a) trPU = transformBi fPU :: Data a => ProgramUnit (Analysis a) -> ProgramUnit (Analysis a) - fPU (PUFunction a s ty r n args res b subs) + fPU (PUFunction a s ty r _ args res b subs) | Just srcN <- sourceName a = PUFunction a s ty r srcN args res b subs - fPU (PUSubroutine a s r n args b subs) + fPU (PUSubroutine a s r _ args b subs) | Just srcN <- sourceName a = PUSubroutine a s r srcN args b subs fPU pu = pu @@ -107,40 +104,42 @@ programUnit (PUModule a s name blocks m_contains) = do env0 <- initialEnv blocks pushScope name env0 - blocks' <- mapM renameDeclDecls blocks -- handle declarations + blocks1 <- mapM renameModDecls blocks -- handle declarations + blocks2 <- mapM renameUseSt blocks1 -- handle use statements m_contains' <- renameSubPUs m_contains -- handle contained program units + blocks3 <- mapM renameBlock blocks2 -- process all uses of functions/subroutine names env <- getEnv addModEnv name env -- save the module environment let a' = a { moduleEnv = Just env } -- also annotate it on the module popScope - return (PUModule a' s name blocks' m_contains') + return (PUModule a' s name blocks3 m_contains') programUnit (PUFunction a s ty rec name args res blocks m_contains) = do - Just name' <- getFromEnv name -- get renamed function name - blocks1 <- mapM renameEntryPointDecl blocks -- rename any entry points - env0 <- initialEnv blocks1 - pushScope name env0 + ~(Just name') <- getFromEnv name -- get renamed function name + (blocks1, _) <- returnBlocksEnv blocks name blocks2 <- mapM renameEntryPointResultDecl blocks1 -- rename the result res' <- mapM renameGenericDecls res -- variable(s) if needed args' <- mapM renameGenericDecls args -- rename arguments blocks3 <- mapM renameDeclDecls blocks2 -- handle declarations m_contains' <- renameSubPUs m_contains -- handle contained program units blocks4 <- mapM renameBlock blocks3 -- process all uses of variables + let env = M.singleton name (name', NTSubprogram) + let a' = a { moduleEnv = Just env } -- also annotate it on the program unit popScope - let pu' = PUFunction a s ty rec name args' res' blocks4 m_contains' + let pu' = PUFunction a' s ty rec name args' res' blocks4 m_contains' return . setSourceName name . setUniqueName name' $ pu' programUnit (PUSubroutine a s rec name args blocks m_contains) = do - Just name' <- getFromEnv name -- get renamed subroutine name - blocks1 <- mapM renameEntryPointDecl blocks -- rename any entry points - env0 <- initialEnv blocks1 - pushScope name env0 + ~(Just name') <- getFromEnv name -- get renamed subroutine name + (blocks1, _) <- returnBlocksEnv blocks name args' <- mapM renameGenericDecls args -- rename arguments blocks2 <- mapM renameDeclDecls blocks1 -- handle declarations m_contains' <- renameSubPUs m_contains -- handle contained program units blocks3 <- mapM renameBlock blocks2 -- process all uses of variables + let env = M.singleton name (name', NTSubprogram) + let a' = a { moduleEnv = Just env } -- also annotate it on the program unit popScope - let pu' = PUSubroutine a s rec name args' blocks3 m_contains' + let pu' = PUSubroutine a' s rec name args' blocks3 m_contains' return . setSourceName name . setUniqueName name' $ pu' programUnit (PUMain a s n blocks m_contains) = do @@ -154,19 +153,26 @@ programUnit pu = return pu +returnBlocksEnv :: Data a => [Block (Analysis a)] + -> String + -> StateT RenameState Identity ([Block (Analysis a)], ModEnv) +returnBlocksEnv bs n = do + bs1 <- mapM renameEntryPointDecl bs + e0 <- initialEnv bs1 + pushScope n e0 + return (bs1, e0) + declarator :: forall a. Data a => RenamerFunc (Declarator (Analysis a)) declarator (DeclVariable a s e1 me2 me3) = do e1' <- renameExpDecl e1 - me2' <- traverse renameExp me2 - me3' <- traverse renameExp me3 + me2' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me2 + me3' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me3 return $ DeclVariable a s e1' me2' me3' declarator (DeclArray a s e1 ddAList me2 me3) = do e1' <- renameExpDecl e1 - let trans :: RenamerFunc (Expression (Analysis a)) -> RenamerFunc (AList DimensionDeclarator (Analysis a)) - trans = transformBiM - ddAList' <- trans renameExp ddAList - me2' <- traverse renameExp me2 - me3' <- traverse renameExp me3 + ddAList' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) ddAList + me2' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me2 + me3' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me3 return $ DeclArray a s e1' ddAList' me2' me3' expression :: Data a => RenamerFunc (Expression (Analysis a)) @@ -177,6 +183,7 @@ -- transformations. -- Initial monad state. +renameState0 :: FortranVersion -> RenameState renameState0 v = RenameState { langVersion = v , intrinsics = getVersionIntrinsics v , scopeStack = [] @@ -185,7 +192,8 @@ , moduleMap = empty } -- Run the monad. -runRenamer m = runState m +runRenamer :: State a b -> a -> (b, a) +runRenamer = runState -- Get a freshly generated number. getUniqNum :: Renamer Int @@ -201,38 +209,56 @@ n <- getUniqNum return $ scope ++ "_" ++ var ++ show n -isModule (PUModule {}) = True; isModule _ = False - -isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _)) _ _)) = True -isUseStatement _ = False +--isModule :: ProgramUnit a -> Bool +--isModule (PUModule {}) = True; isModule _ = False -isUseID (UseID {}) = True; isUseID _ = False +isUseStatement :: Block a -> Bool +isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _)) _ _ _)) = True +isUseStatement _ = False -- Generate an initial environment for a scope based upon any Use -- statements in the blocks. -initialEnv :: Data a => [Block (Analysis a)] -> Renamer ModEnv +initialEnv :: forall a. Data a => [Block (Analysis a)] -> Renamer ModEnv initialEnv blocks = do - -- FIXME: add "use renaming" declarations (requires change in - -- NameMap because it would be possible for the same program object - -- to have two different names used by different parts of the - -- program). let uses = filter isUseStatement blocks - fmap M.unions . forM uses $ \ use -> case use of - (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ Nothing)) -> do - mMap <- gets moduleMap + mMap <- gets moduleMap + modEnv <- fmap M.unions . forM uses $ \ use -> case use of + (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ Nothing)) -> return $ fromMaybe empty (Named m `lookup` mMap) - (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ (Just onlyAList))) - | only <- aStrip onlyAList, all isUseID only -> do - mMap <- gets moduleMap + (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ (Just onlyAList))) + | only <- aStrip onlyAList -> do let env = fromMaybe empty (Named m `lookup` mMap) - let onlyNames = map (\ (UseID _ _ v) -> varName v) only - -- filter for the the mod remappings mentioned in the list, only - return $ M.filterWithKey (\ k _ -> k `elem` onlyNames) env - _ -> trace "WARNING: USE renaming not supported (yet)" $ return empty + -- list of (local name, original name) from USE declaration: + let localNamePairs = flip mapMaybe only $ \ r -> case r of + UseID _ _ v@(ExpValue _ _ ValVariable{}) -> Just (varName v, varName v) + UseRename _ _ u v -> Just (varName u, varName v) + _ -> Nothing + -- create environment based on local name written in ONLY list + -- (if applicable) and variable information found in imported + -- mod env. + let re = M.fromList [ (local, info) | (local, orig) <- localNamePairs + , Just info <- [M.lookup orig env] ] + return re + _ -> return empty + -- Include any global names from program units defined outside of + -- modules as well. + let global = fromMaybe M.empty $ M.lookup NamelessMain mMap + + -- Include any mappings defined by COMMON blocks: use variable + -- source name prefixed by name of COMMON block. + let common = M.fromList [ (v, (v', NTVariable)) + | CommonGroup _ _ me1 alist <- universeBi blocks :: [CommonGroup (Analysis a)] + , let prefix = case me1 of Just e1 -> srcName e1; _ -> "" + , e@(ExpValue _ _ ValVariable{}) <- universeBi (aStrip alist) :: [Expression (Analysis a)] + , let v = srcName e + , let v' = prefix ++ "_" ++ v ++ "_common" ] + + return $ M.unions [modEnv, global, common] + -- Get the current scope name. -getScope :: Renamer String -getScope = gets (head . scopeStack) +--getScope :: Renamer String +--getScope = gets (head . scopeStack) -- Get the concatenated scopes. getScopes :: Renamer String @@ -295,7 +321,7 @@ case mEntry of Just (v', NTSubprogram) -> return $ Just v' Just (_, NTVariable) -> getFromEnv v - _ -> return $ Nothing + _ -> return Nothing -- Add a renaming mapping to the environment. addToEnv :: String -> String -> NameType -> Renamer () @@ -309,7 +335,7 @@ return v' addUnique_ :: String -> NameType -> Renamer () -addUnique_ v nt = addUnique v nt >> return () +addUnique_ v nt = void (addUnique v nt) -- This function will be invoked by occurrences of -- declarations. First, search to see if v is a subprogram name that @@ -324,17 +350,17 @@ -- If uniqueName/sourceName property is not set, then set it. setUniqueName, setSourceName :: (Annotated f, Data a) => String -> f (Analysis a) -> f (Analysis a) setUniqueName un x - | a@(Analysis { uniqueName = Nothing }) <- getAnnotation x = setAnnotation (a { uniqueName = Just un }) x - | otherwise = x + | a@Analysis { uniqueName = Nothing } <- getAnnotation x = setAnnotation (a { uniqueName = Just un }) x + | otherwise = x setSourceName sn x - | a@(Analysis { sourceName = Nothing }) <- getAnnotation x = setAnnotation (a { sourceName = Just sn }) x - | otherwise = x + | a@Analysis { sourceName = Nothing } <- getAnnotation x = setAnnotation (a { sourceName = Just sn }) x + | otherwise = x -- Work recursively into sub-program units. renameSubPUs :: Data a => RenamerFunc (Maybe [ProgramUnit (Analysis a)]) renameSubPUs Nothing = return Nothing -renameSubPUs (Just pus) = skimProgramUnits pus >> Just `fmap` (mapM programUnit pus) +renameSubPUs (Just pus) = skimProgramUnits pus >> Just <$> mapM programUnit pus -- Go through all program units at the same level and add their names -- to the environment. @@ -367,6 +393,24 @@ renameExpDecl e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic renameExpDecl e = return e +renameInterfaces :: (Data a, Data (f (Analysis a))) => RenamerFunc (f (Analysis a)) +renameInterfaces = trans interface + where + trans :: (Data a, Data (f (Analysis a))) => RenamerFunc (Block (Analysis a)) -> RenamerFunc (f (Analysis a)) + trans = transformBiM + +interface :: Data a => RenamerFunc (Block (Analysis a)) +interface (BlInterface a s (Just e@(ExpValue _ _ (ValVariable v))) abst pus bs) = do + e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTSubprogram + pure $ BlInterface a s (Just e') abst pus bs +interface b = pure b + +-- Handle generic-interfaces as if they were subprograms, then handle +-- other declarations, assuming they might possibly need the creation +-- of new unique mappings. +renameModDecls :: (Data a, Data (f (Analysis a))) => RenamerFunc (f (Analysis a)) +renameModDecls = renameDeclDecls <=< renameInterfaces + -- Find all declarators within a value and then dive within those -- declarators to rename any ExpValue variables, assuming they might -- possibly need the creation of new unique mappings. @@ -399,7 +443,7 @@ -- Rename an ExpValue variable, assuming that it is to be treated as a -- reference to a previous declaration, possibly in an outer scope. renameExp :: Data a => RenamerFunc (Expression (Analysis a)) -renameExp e@(ExpValue _ _ (ValVariable v)) = maybe e (flip setUniqueName (setSourceName v e)) `fmap` getFromEnvs v +renameExp e@(ExpValue _ _ (ValVariable v)) = maybe e (`setUniqueName` setSourceName v e) `fmap` getFromEnvs v -- Intrinsics get unique names for each use. renameExp e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic renameExp e = return e @@ -413,7 +457,26 @@ trans :: Data a => RenamerFunc (Expression a) -> RenamerFunc (Block a) trans = transformBiM -- search all expressions, bottom-up +-- Rename the components of a Use statement contained in the block. +renameUseSt :: Data a => RenamerFunc (Block (Analysis a)) +renameUseSt (BlStatement a s l st@StUse{}) = BlStatement a s l <$> trans expression st + where + trans :: Data a => RenamerFunc (Expression a) -> RenamerFunc (Statement a) + trans = transformBiM -- search all expressions, bottom-up +renameUseSt b = return b + -------------------------------------------------- + +-- Ensure second part of UseRename has the right uniqueName & +-- sourceName, since that name does not appear in our mod env, because +-- it has been given a different local name by the programmer. +cleanupUseRenames :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) +cleanupUseRenames = transformBi (\ u -> case u :: Use (Analysis a) of + UseRename a s e1 e2@(ExpValue _ _ (ValVariable v)) -> UseRename a s e1 $ setUniqueName (varName e1) (setSourceName v e2) + _ -> u) + + + -- Local variables: -- mode: haskell 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 @@ -1,17 +1,22 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Language.Fortran.Analysis.Types ( analyseTypes, analyseTypesWithEnv, extractTypeEnv, TypeEnv ) where +module Language.Fortran.Analysis.Types + ( analyseTypes, analyseTypesWithEnv, analyseAndCheckTypesWithEnv, extractTypeEnv, TypeEnv, TypeError ) +where import Language.Fortran.AST -import Prelude hiding (lookup) +import Prelude hiding (lookup, EQ, LT, GT) import Data.Map (insert) import qualified Data.Map as M import Data.Maybe (maybeToList) +import Data.List (find) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data +import Data.Functor.Identity (Identity ()) import Language.Fortran.Analysis import Language.Fortran.Intrinsics +import Language.Fortran.Util.Position import Language.Fortran.ParserMonad (FortranVersion(..)) @@ -20,6 +25,9 @@ -- | Mapping of names to type information. type TypeEnv = M.Map Name IDType +-- | Information about a detected type error. +type TypeError = (String, SrcSpan) + -------------------------------------------------- -- Monad for type inference work @@ -27,7 +35,8 @@ data InferState = InferState { langVersion :: FortranVersion , intrinsics :: IntrinsicsTable , environ :: TypeEnv - , entryPoints :: M.Map Name (Name, Maybe Name) } + , entryPoints :: M.Map Name (Name, Maybe Name) + , typeErrors :: [TypeError] } deriving Show type InferFunc t = t -> Infer () @@ -42,7 +51,24 @@ -- environment mapping names to type information; provided with a -- starting type environment. analyseTypesWithEnv :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv) -analyseTypesWithEnv env pf@(ProgramFile mi _) = fmap environ . runInfer (miVersion mi) env $ do +analyseTypesWithEnv env pf = (pf', tenv) + where + (pf', endState) = analyseTypesWithEnv' env pf + tenv = environ endState + +-- | Annotate AST nodes with type information, return a type +-- environment mapping names to type information and return any type +-- errors found; provided with a starting type environment. +analyseAndCheckTypesWithEnv + :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv, [TypeError]) +analyseAndCheckTypesWithEnv env pf = (pf', tenv, terrs) + where + (pf', endState) = analyseTypesWithEnv' env pf + tenv = environ endState + terrs = typeErrors endState + +analyseTypesWithEnv' :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), InferState) +analyseTypesWithEnv' env pf@(ProgramFile mi _) = runInfer (miVersion mi) env $ do -- Gather information. mapM_ intrinsicsExp (allExpressions pf) mapM_ programUnit (allProgramUnits pf) @@ -51,7 +77,7 @@ -- Gather types for known entry points. eps <- gets (M.toList . entryPoints) - forM eps $ \ (eName, (fName, mRetName)) -> do + _ <- forM eps $ \ (eName, (fName, mRetName)) -> do mFType <- getRecordedType fName case mFType of Just (IDType fVType fCType) -> do @@ -68,7 +94,7 @@ puEnv = M.fromList [ (n, ty) | pu <- universeBi pf :: [ProgramUnit (Analysis a)] , Named n <- [puName pu] , ty <- maybeToList (idType (getAnnotation pu)) ] - expEnv = M.fromList [ (n, ty) | e <- universeBi pf :: [Expression (Analysis a)] + expEnv = M.fromList [ (n, ty) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)] , let n = varName e , ty <- maybeToList (idType (getAnnotation e)) ] @@ -82,10 +108,11 @@ intrinsicsExp (ExpFunctionCall _ _ nexp _) = intrinsicsHelper nexp intrinsicsExp _ = return () +intrinsicsHelper :: Expression (Analysis a) -> StateT InferState Identity () intrinsicsHelper nexp | isNamedExpression nexp = do itab <- gets intrinsics case getIntrinsicReturnType (srcName nexp) itab of - Just itype -> do + Just _ -> do let n = varName nexp recordCType CTIntrinsic n -- recordBaseType _ n -- FIXME: going to skip base types for the moment @@ -103,7 +130,7 @@ _ -> return () -- record entry points for later annotation forM_ blocks $ \ block -> - sequence_ [ recordEntryPoint n (varName v) (fmap varName mRetVar) | (StEntry _ _ v _ mRetVar) <- allStatements block ] + sequence_ [ recordEntryPoint n (varName v) (fmap varName mRetVar') | (StEntry _ _ v _ mRetVar') <- allStatements block ] programUnit pu@(PUSubroutine _ _ _ _ _ blocks _) | Named n <- puName pu = do -- record the fact that this is a subroutine recordCType CTSubroutine n @@ -113,29 +140,42 @@ programUnit _ = return () declarator :: Data a => InferFunc (Declarator (Analysis a)) -declarator (DeclArray _ _ v _ _ _) = recordCType CTArray (varName v) -declarator _ = return () +declarator (DeclArray _ _ v ddAList _ _) = recordCType (CTArray $ dimDeclarator ddAList) (varName v) +declarator _ = return () +dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)] +dimDeclarator ddAList = [ (lb, ub) | DimensionDeclarator _ _ lbExp ubExp <- aStrip ddAList + , let lb = do ExpValue _ _ (ValInteger i) <- lbExp + return $ read i + , let ub = do ExpValue _ _ (ValInteger i) <- ubExp + return $ read i ] + statement :: Data a => InferFunc (Statement (Analysis a)) -- maybe FIXME: should Kind Selectors be part of types? statement (StDeclaration _ _ (TypeSpec _ _ baseType _) mAttrAList declAList) | mAttrs <- maybe [] aStrip mAttrAList - , isArray <- any isAttrDimension mAttrs + , attrDim <- find isAttrDimension mAttrs , isParam <- any isAttrParameter mAttrs , isExtrn <- any isAttrExternal mAttrs , decls <- aStrip declAList = do env <- gets environ - forM_ decls $ \ decl -> case decl of - DeclArray _ _ v _ _ _ -> recordType baseType CTArray (varName v) - DeclVariable _ _ v (Just _) _ -> recordType baseType CTVariable (varName v) - DeclVariable _ _ v Nothing _ -> recordType baseType cType n - where - n = varName v - cType | isExtrn = CTExternal - | isArray = CTArray + let cType n | isExtrn = CTExternal + | Just (AttrDimension _ _ ddAList) <- attrDim = CTArray (dimDeclarator ddAList) | isParam = CTParameter - | Just (IDType _ (Just ct)) <- M.lookup n env = ct + | Just (IDType _ (Just ct)) <- M.lookup n env + , ct /= CTIntrinsic = ct | otherwise = CTVariable + let charLen (ExpValue _ _ (ValInteger i)) = CharLenInt (read i) + charLen (ExpValue _ _ ValStar) = CharLenStar + charLen _ = CharLenExp + let bType (Just e) + | TypeCharacter _ kind <- baseType = TypeCharacter (Just $ charLen e) kind + | otherwise = TypeCharacter (Just $ charLen e) Nothing + bType Nothing = baseType + forM_ decls $ \ decl -> case decl of + DeclArray _ _ v ddAList e _ -> recordType (bType e) (CTArray $ dimDeclarator ddAList) (varName v) + DeclVariable _ _ v e _ -> recordType (bType e) (cType n) n where n = varName v + statement (StExternal _ _ varAList) = do let vars = aStrip varAList mapM_ (recordCType CTExternal . varName) vars @@ -145,45 +185,193 @@ let n = varName v mIDType <- getRecordedType n case mIDType of - Just (IDType mBT (Just CTArray)) -> return () -- do nothing, it's already known to be an array + Just (IDType _ (Just CTArray{})) -> return () -- do nothing, it's already known to be an array _ -> recordCType CTFunction n -- assume it's a function statement -- FIXME: if StFunctions can only be identified after types analysis -- is complete and disambiguation is performed, then how do we get -- 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 (StDimension _ _ declAList) = do let decls = aStrip declAList forM_ decls $ \ decl -> case decl of - DeclArray _ _ v _ _ _ -> recordCType CTArray (varName v) - _ -> return () + DeclArray _ _ v ddAList _ _ -> recordCType (CTArray $ dimDeclarator ddAList) (varName v) + _ -> return () statement _ = return () annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a)) -annotateExpression e@(ExpValue _ _ (ValVariable _)) = maybe e (flip setIDType e) `fmap` getRecordedType (varName e) -annotateExpression e@(ExpValue _ _ (ValIntrinsic _)) = maybe e (flip setIDType e) `fmap` getRecordedType (varName e) -annotateExpression e = return e +annotateExpression e@(ExpValue _ _ (ValVariable _)) = maybe e (`setIDType` e) `fmap` getRecordedType (varName e) +annotateExpression e@(ExpValue _ _ (ValIntrinsic _)) = maybe e (`setIDType` e) `fmap` getRecordedType (varName e) +annotateExpression e@(ExpValue _ _ (ValReal r)) = return $ realLiteralType r `setIDType` e +annotateExpression e@(ExpValue _ _ (ValComplex e1 e2)) = return $ complexLiteralType e1 e2 `setIDType` e +annotateExpression e@(ExpValue _ _ (ValInteger _)) = return $ IDType (Just TypeInteger) Nothing `setIDType` e +annotateExpression e@(ExpValue _ _ (ValLogical _)) = return $ IDType (Just TypeLogical) Nothing `setIDType` e +annotateExpression e@(ExpBinary _ _ op e1 e2) = flip setIDType e `fmap` binaryOpType (getSpan e) op e1 e2 +annotateExpression e@(ExpUnary _ _ op e1) = flip setIDType e `fmap` unaryOpType (getSpan e1) op e1 +annotateExpression e@(ExpSubscript _ _ e1 idxAList) = flip setIDType e `fmap` subscriptType (getSpan e) e1 idxAList +annotateExpression e@(ExpFunctionCall _ _ e1 parAList) = flip setIDType e `fmap` functionCallType (getSpan e) e1 parAList +annotateExpression e = return e annotateProgramUnit :: Data a => ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a)) -annotateProgramUnit pu | Named n <- puName pu = maybe pu (flip setIDType pu) `fmap` getRecordedType n +annotateProgramUnit pu | Named n <- puName pu = maybe pu (`setIDType` pu) `fmap` getRecordedType n annotateProgramUnit pu = return pu +realLiteralType :: String -> IDType +realLiteralType r | 'd' `elem` r = IDType (Just TypeDoublePrecision) Nothing + | otherwise = IDType (Just TypeReal) Nothing + +complexLiteralType :: Expression a -> Expression a -> IDType +complexLiteralType (ExpValue _ _ (ValReal r)) _ + | IDType (Just TypeDoublePrecision) _ <- realLiteralType r = IDType (Just TypeDoubleComplex) Nothing + | otherwise = IDType (Just TypeComplex) Nothing +complexLiteralType _ _ = IDType (Just TypeComplex) Nothing + +binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType +binaryOpType ss op e1 e2 = do + mbt1 <- case getIDType e1 of + Just (IDType (Just bt) _) -> return $ Just bt + _ -> typeError "Unable to obtain type for first operand" (getSpan e1) >> return Nothing + mbt2 <- case getIDType e2 of + Just (IDType (Just bt) _) -> return $ Just bt + _ -> typeError "Unable to obtain type for second operand" (getSpan e2) >> return Nothing + case (mbt1, mbt2) of + (_, Nothing) -> return emptyType + (Nothing, _) -> return emptyType + (Just bt1, Just bt2) -> do + mbt <- case (bt1, bt2) of + (_ , TypeDoubleComplex ) -> return . Just $ TypeDoubleComplex + (TypeDoubleComplex , _ ) -> return . Just $ TypeDoubleComplex + (_ , TypeComplex ) -> return . Just $ TypeComplex + (TypeComplex , _ ) -> return . Just $ TypeComplex + (_ , TypeDoublePrecision ) -> return . Just $ TypeDoublePrecision + (TypeDoublePrecision , _ ) -> return . Just $ TypeDoublePrecision + (_ , TypeReal ) -> return . Just $ TypeReal + (TypeReal , _ ) -> return . Just $ TypeReal + (_ , TypeInteger ) -> return . Just $ TypeInteger + (TypeInteger , _ ) -> return . Just $ TypeInteger + (TypeByte , TypeByte ) -> return . Just $ TypeByte + (TypeLogical , TypeLogical ) -> return . Just $ TypeLogical + (TypeCustom _ , TypeCustom _ ) -> do + typeError "custom types / binary op not supported" ss + return Nothing + (TypeCharacter l1 k1 , TypeCharacter l2 _ ) + | op == Concatenation -> return . Just $ TypeCharacter (liftM2 charLenConcat l1 l2) k1 + | op `elem` [EQ, NE] -> return $ Just TypeLogical + | otherwise -> do typeError "Invalid op on character strings" ss + return Nothing + _ -> do typeError "Type error between operands of binary operator" ss + return Nothing + mbt' <- case mbt of + Just bt + | op `elem` [ Addition, Subtraction, Multiplication, Division + , Exponentiation, Concatenation, Or, XOr, And ] -> return $ Just bt + | op `elem` [GT, GTE, LT, LTE, EQ, NE, Equivalent, NotEquivalent] -> return $ Just TypeLogical + | BinCustom{} <- op -> typeError "custom binary ops not supported" ss >> return Nothing + _ -> return Nothing + + return $ IDType mbt' Nothing + +unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType +unaryOpType ss op e = do + mbt <- case getIDType e of + Just (IDType (Just bt) _) -> return $ Just bt + _ -> typeError "Unable to obtain type for" (getSpan e) >> return Nothing + mbt' <- case (mbt, op) of + (Nothing, _) -> return Nothing + (Just TypeCustom{}, _) -> typeError "custom types / unary ops not supported" ss >> return Nothing + (_, UnCustom{}) -> typeError "custom unary ops not supported" ss >> return Nothing + (Just TypeLogical, Not) -> return $ Just TypeLogical + (Just bt, _) + | op `elem` [Plus, Minus] && + bt `elem` numericTypes -> return $ Just bt + _ -> typeError "Type error for unary operator" ss >> return Nothing + return $ IDType mbt' Nothing + +subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType +subscriptType ss e1 (AList _ _ idxs) = do + let isInteger ie | Just (IDType (Just TypeInteger) _) <- getIDType ie = True | otherwise = False + forM_ idxs $ \ idx -> case idx of + IxSingle _ _ _ ie + | not (isInteger ie) -> typeError "Invalid or unknown type for index" (getSpan ie) + IxRange _ _ mie1 mie2 mie3 + | Just ie1 <- mie1, not (isInteger ie1) -> typeError "Invalid or unknown type for index" (getSpan ie1) + | Just ie2 <- mie2, not (isInteger ie2) -> typeError "Invalid or unknown type for index" (getSpan ie2) + | Just ie3 <- mie3, not (isInteger ie3) -> typeError "Invalid or unknown type for index" (getSpan ie3) + _ -> return () + case getIDType e1 of + Just ty@(IDType mbt (Just (CTArray dds))) -> do + when (length idxs /= length dds) $ typeError "Length of indices does not match rank of array." ss + let isSingle (IxSingle{}) = True; isSingle _ = False + if all isSingle idxs + then return $ IDType mbt Nothing + 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 + itab <- gets intrinsics + let mRetType = getIntrinsicReturnType n itab + case mRetType of + Nothing -> return emptyType + Just retType -> do + mbt <- case retType of + ITReal -> return $ Just TypeReal + ITInteger -> return $ Just TypeInteger + ITComplex -> return $ Just TypeComplex + ITDouble -> return $ Just TypeDoublePrecision + ITLogical -> return $ Just TypeLogical + ITCharacter -> return . Just $ TypeCharacter Nothing Nothing + ITParam i + | length params >= i, Argument _ _ _ e <- params !! (i-1) + -> return $ idVType =<< getIDType e + | otherwise -> typeError ("Invalid parameter list to intrinsic '" ++ n ++ "'") ss >> return Nothing + case mbt of + Nothing -> return emptyType + Just _ -> return $ IDType mbt Nothing +functionCallType ss e1 _ = case getIDType e1 of + Just (IDType (Just bt) (Just CTFunction)) -> return $ IDType (Just bt) Nothing + Just (IDType (Just bt) (Just CTExternal)) -> return $ IDType (Just bt) Nothing + _ -> typeError "non-function invoked by call" ss >> return emptyType + +charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen +charLenConcat l1 l2 = case (l1, l2) of + (CharLenExp , _ ) -> CharLenExp + (_ , CharLenExp ) -> CharLenExp + (CharLenStar , _ ) -> CharLenStar + (_ , CharLenStar ) -> CharLenStar + (CharLenColon , _ ) -> CharLenColon + (_ , CharLenColon ) -> CharLenColon + (CharLenInt i1 , CharLenInt i2 ) -> CharLenInt (i1 + i2) + +numericTypes :: [BaseType] +numericTypes = [TypeDoubleComplex, TypeComplex, TypeDoublePrecision, TypeReal, TypeInteger, TypeByte] + -------------------------------------------------- -- Monadic helper combinators. -inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v, intrinsics = getVersionIntrinsics v } +inferState0 :: FortranVersion -> InferState +inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v + , intrinsics = getVersionIntrinsics v, typeErrors = [] } runInfer :: FortranVersion -> TypeEnv -> State InferState a -> (a, InferState) runInfer v env = flip runState ((inferState0 v) { environ = env }) +typeError :: String -> SrcSpan -> Infer () +typeError msg ss = modify $ \ s -> s { typeErrors = (msg, ss):typeErrors s } + +emptyType :: IDType +emptyType = IDType Nothing Nothing + -- Record the type of the given name. recordType :: BaseType -> ConstructType -> Name -> Infer () recordType bt ct n = modify $ \ s -> s { environ = insert n (IDType (Just bt) (Just ct)) (environ s) } -- Record the type (maybe) of the given name. recordMType :: Maybe BaseType -> Maybe ConstructType -> Name -> Infer () -recordMType bt ct n = modify $ \ s -> s { environ = insert n (IDType (bt) (ct)) (environ s) } +recordMType bt ct n = modify $ \ s -> s { environ = insert n (IDType bt ct) (environ s) } -- Record the CType of the given name. recordCType :: ConstructType -> Name -> Infer () @@ -204,7 +392,7 @@ -- Set the idType annotation setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a) setIDType ty x - | a@(Analysis {}) <- getAnnotation x = setAnnotation (a { idType = Just ty }) x + | a@Analysis {} <- getAnnotation x = setAnnotation (a { idType = Just ty }) x | otherwise = x -- Get the idType annotation @@ -212,10 +400,10 @@ getIDType x = idType (getAnnotation x) -- Set the CType part of idType annotation -setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a) -setCType ct x - | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x - | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x +--setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a) +--setCType ct x +-- | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x +-- | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x type UniFunc f g a = f (Analysis a) -> [g (Analysis a)] @@ -231,16 +419,20 @@ allExpressions :: (Data a, Data (f (Analysis a))) => UniFunc f Expression a allExpressions = universeBi -isAttrDimension (AttrDimension {}) = True -isAttrDimension _ = False +isAttrDimension :: Attribute a -> Bool +isAttrDimension AttrDimension {} = True +isAttrDimension _ = False -isAttrParameter (AttrParameter {}) = True +isAttrParameter :: Attribute a -> Bool +isAttrParameter AttrParameter {} = True isAttrParameter _ = False -isAttrExternal (AttrExternal {}) = True +isAttrExternal :: Attribute a -> Bool +isAttrExternal AttrExternal {} = True isAttrExternal _ = False -isIxSingle (IxSingle {}) = True +isIxSingle :: Index a -> Bool +isIxSingle IxSingle {} = True isIxSingle _ = False -------------------------------------------------- diff --git a/src/Language/Fortran/Intrinsics.hs b/src/Language/Fortran/Intrinsics.hs --- a/src/Language/Fortran/Intrinsics.hs +++ b/src/Language/Fortran/Intrinsics.hs @@ -19,11 +19,13 @@ data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) } deriving (Show, Eq, Ord, Typeable, Generic) -mkIEntry ty du = IEntry ty du +mkIEntry :: IntrinsicType -> ([Int], [Int]) -> IntrinsicsEntry +mkIEntry = IEntry type IntrinsicsTable = M.Map String IntrinsicsEntry -- Main table of Fortran intrinsics by version +fortranVersionIntrinsics :: [(FortranVersion, IntrinsicsTable)] fortranVersionIntrinsics = [ (Fortran66, fortran77intrinsics) -- FIXME: find list of original '66 intrinsics , (Fortran77, fortran77intrinsics) @@ -48,10 +50,15 @@ allIntrinsics :: IntrinsicsTable allIntrinsics = M.unions (map snd fortranVersionIntrinsics) +func1 :: ([Int], [Int]) func1 = ([0],[1]) +func2 :: ([Int], [Int]) func2 = ([0],[1,2]) +func3 :: ([Int], [Int]) func3 = ([0],[1,2,3]) +func4 :: ([Int], [Int]) func4 = ([0],[1,2,3,4]) +funcN :: ([Int], [Int]) funcN = func2 -- FIXME: implement arbitrary-# parameter functions -- | name => (return-unit, parameter-units) @@ -68,6 +75,7 @@ , ("cmplx" , mkIEntry ITComplex func1) , ("ichar" , mkIEntry ITInteger func1) , ("char" , mkIEntry ITCharacter func1) + , ("achar" , mkIEntry ITCharacter func1) , ("aint" , mkIEntry (ITParam 1) func1) , ("dint" , mkIEntry ITDouble func1) , ("anint" , mkIEntry (ITParam 1) func1) @@ -151,19 +159,19 @@ fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList - [ ("present" , mkIEntry (ITLogical) func1) + [ ("present" , mkIEntry ITLogical func1) , ("modulo" , mkIEntry (ITParam 1) func2) , ("ceiling" , mkIEntry (ITParam 1) func1) - , ("iand" , mkIEntry (ITInteger) func2) - , ("ior" , mkIEntry (ITInteger) func2) - , ("ieor" , mkIEntry (ITInteger) func2) - , ("iany" , mkIEntry (ITInteger) func2) - , ("ibclr" , mkIEntry (ITInteger) func2) - , ("ibits" , mkIEntry (ITInteger) func3) - , ("ibset" , mkIEntry (ITInteger) func2) - , ("ishftc" , mkIEntry (ITInteger) func3) - , ("btest" , mkIEntry (ITInteger) func2) - , ("not" , mkIEntry (ITInteger) func1) + , ("iand" , mkIEntry ITInteger func2) + , ("ior" , mkIEntry ITInteger func2) + , ("ieor" , mkIEntry ITInteger func2) + , ("iany" , mkIEntry ITInteger func2) + , ("ibclr" , mkIEntry ITInteger func2) + , ("ibits" , mkIEntry ITInteger func3) + , ("ibset" , mkIEntry ITInteger func2) + , ("ishftc" , mkIEntry ITInteger func3) + , ("btest" , mkIEntry ITInteger func2) + , ("not" , mkIEntry ITInteger func1) , ("dot_product" , mkIEntry (ITParam 1) func2) , ("matmul" , mkIEntry (ITParam 1) func2) , ("all" , mkIEntry ITLogical func2) @@ -187,4 +195,5 @@ , ("transpose" , mkIEntry (ITParam 1) func1) , ("maxloc" , mkIEntry (ITParam 1) func2) , ("minloc" , mkIEntry (ITParam 1) func2) + , ("epsilon" , mkIEntry (ITReal) func1) ] diff --git a/src/Language/Fortran/LValue.hs b/src/Language/Fortran/LValue.hs --- a/src/Language/Fortran/LValue.hs +++ b/src/Language/Fortran/LValue.hs @@ -6,6 +6,7 @@ module Language.Fortran.LValue where +import Prelude hiding (exp) import Data.Data import GHC.Generics (Generic) diff --git a/src/Language/Fortran/Lexer/FixedForm.x b/src/Language/Fortran/Lexer/FixedForm.x --- a/src/Language/Fortran/Lexer/FixedForm.x +++ b/src/Language/Fortran/Lexer/FixedForm.x @@ -29,6 +29,7 @@ import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position +import Language.Fortran.Parser.Utils (readInteger) } @@ -37,6 +38,8 @@ $hexDigit = [a-f $digit] $bit = 0-1 +$hash = [\#] + @binary = b\'$bit+\' | \'$bit+\'b @octal = o\'$octalDigit+\' | \'$octalDigit+\'o @hex = x\'$hexDigit+\' | \'$hexDigit+\'x | z\'$hexDigit+\' | \'$hexDigit+\'z @@ -72,12 +75,14 @@ tokens :- - <0> [c!\*d] / { commentP } { lexComment Nothing } - "!" / { bangCommentP &&& legacy77P } { lexComment Nothing } + <0> [c!\*d] / { commentP } { lexComment } + "!" / { bangCommentP &&& legacy77P } { lexComment } <0> @label / { withinLabelColsP } { addSpanAndMatch TLabel } <0> . / { \_ ai _ _ -> atColP 6 ai } { toSC keyword } <0> " " ; + <0> $hash { lexHash } + <0,st,keyword,iif,assn,doo> \n { resetPar >> toSC 0 >> addSpan TNewline } <0,st,keyword,iif,assn,doo> \r ; <0,st,keyword,iif,assn,doo> ";" { resetPar >> toSC keyword >> addSpan TNewline } @@ -279,7 +284,7 @@ implicitTypeExtendedP fv b c d = extended77P fv b c d && implicitStP fv b c d implicitStP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -implicitStP fv _ _ ai = checkPreviousTokensInLine f ai +implicitStP _ _ _ ai = checkPreviousTokensInLine f ai where f (TImplicit _) = True f _ = False @@ -296,7 +301,7 @@ doP :: FortranVersion -> AlexInput -> Bool doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) && - case unParse (lexer $ f 0) ps of + case unParse (lexer $ f (0::Integer)) ps of ParseOk True _ -> True _ -> False where @@ -357,14 +362,14 @@ _ -> return False hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -hollerithP fv _ _ ai = isDigit (lookBack 2 ai) +hollerithP _ _ _ ai = isDigit (lookBack 2 ai) notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -notToP fv _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai) +notToP _ _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai) equalFollowsP :: FortranVersion -> AlexInput -> Bool equalFollowsP fv ai = - case unParse (lexer $ f False 0) ps of + case unParse (lexer $ f False (0::Integer)) ps of ParseOk True _ -> True _ -> False where @@ -383,6 +388,7 @@ TDot{} -> lexer $ f False 0 TId{} -> lexer $ f False 0 _ -> return False + f False _ _ = return False f True 0 t = case t of TOpAssign{} -> return True @@ -421,7 +427,7 @@ _endsWithLine = (posColumn . aiPosition) aiNew /= 1 bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -bangCommentP fv aiOld i aiNew = _endsWithLine +bangCommentP _ _ _ aiNew = _endsWithLine where _endsWithLine = (posColumn . aiPosition) aiNew /= 1 @@ -558,38 +564,44 @@ lexeme <- getLexeme return $ getSpan lexeme --- With the existing alexGetByte implementation comments are matched without --- whitespace characters. However, we have access to final column number, --- we know the comment would start at column, and we have access to the absolute --- offset so instead of using match, lexComment takes a slice from the original --- source input -lexComment :: Maybe Char -> LexAction (Maybe Token) -lexComment mc = do - m <- getMatch - s <- getLexemeSpan +-- Handle pragmas that begin with # +lexHash :: LexAction (Maybe Token) +lexHash = do + lexLineWithWhitespace $ \ m -> do + ai <- getAlex + case words (drop 1 m) of + -- 'line' pragma - rewrite the current line and filename + "line":lineStr:_ + | Just line <- readInteger lineStr -> do + let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"") + let file = revdropWNQ . revdropWNQ $ m + let lineOffs = fromIntegral line - posLine (aiPosition ai) - 1 + let newP = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file) + , posColumn = 1 } + putAlex $ ai { aiPosition = newP } + _ -> return () + return Nothing + +-- Lex comments with whitespace included +lexComment :: LexAction (Maybe Token) +lexComment = + lexLineWithWhitespace $ \ m -> do + s <- getLexemeSpan + return . Just . TComment s $ tail m + +-- Get a line without losing the whitespace, then call continuation with it. +lexLineWithWhitespace :: (String -> LexAction (Maybe Token)) -> LexAction (Maybe Token) +lexLineWithWhitespace k = do alex <- getAlex - version <- getVersion - let emitComment = case version of - Fortran77Legacy - -> return Nothing - _ -> return $ Just $ TComment s $ tail m let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 } - case mc of - Just '\n' -> emitComment - Just _ -> - case alexGetByte modifiedAlex of - Just (w, _) | fromIntegral w == ord '\n' -> do - emitComment - Just (_, newAlex) -> do - putAlex newAlex - lexComment Nothing - Nothing -> fail "Comment abruptly ended." - Nothing -> - case alexGetByte modifiedAlex of - Just (_, newAlex) -> lexComment (Just $ (head . lexemeMatch . aiLexeme) newAlex) - Nothing -> emitComment + case alexGetByte modifiedAlex of + Just (w, newAlex) + | fromIntegral w /= ord '\n' -> putAlex newAlex >> lexLineWithWhitespace k + _ -> getMatch >>= k +-------------------------------------------------- + {- Chars +-+ @@ -635,13 +647,13 @@ strAutomaton c 0 else strAutomaton c 2 Nothing -> strAutomaton c 2 -strAutomaton c 2 = do +strAutomaton _ 2 = do s <- getLexemeSpan m <- getMatch resetWhiteSensitiveCharCount setCaseInsensitive return $ Just $ TString s $ (init . tail) m -strAutomaton c 3 = fail "Unmatched string." +strAutomaton _ _ = fail "Unmatched string." lexHollerith :: LexAction (Maybe Token) lexHollerith = do @@ -665,7 +677,7 @@ then return $ Just match' else case alexGetByte alex of - Just (w, newAlex) | fromIntegral w == ord '\n' -> do + Just (w, _) | fromIntegral w == ord '\n' -> do return . Just $! pad match' Just (_, newAlex) -> do putAlex newAlex @@ -677,8 +689,8 @@ maybeToKeyword :: LexAction (Maybe Token) maybeToKeyword = do decPar - pcActual <- pcActual . psParanthesesCount <$> get - if pcActual == 0 + pcActual' <- pcActual . psParanthesesCount <$> get + if pcActual' == 0 then toSC keyword else return Nothing @@ -910,8 +922,8 @@ -- Skip the continuation line altogether | isContinuation ai && _isWhiteInsensitive = skip Continuation ai -- Skip the newline before a comment - | aiFortranVersion ai == Fortran77Legacy && - _isWhiteInsensitive && isNewlineComment ai = skip NewlineComment ai + | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive + && isNewlineCommentsFollowedByContinuation ai = skip NewlineComment ai -- If we are not parsing a Hollerith skip whitespace | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai -- Ignore inline comments @@ -968,6 +980,13 @@ _next1 = takeNChars 1 ai p = (aiPosition ai) { posAbsoluteOffset = posAbsoluteOffset (aiPosition ai) + 1 } +isNewlineCommentsFollowedByContinuation :: AlexInput -> Bool +isNewlineCommentsFollowedByContinuation ai + | isNewlineComment ai + = isNewlineCommentsFollowedByContinuation (ai { aiPosition = advance NewlineComment ai }) + | isContinuation ai = True + | otherwise = False + skip :: Move -> AlexInput -> Maybe (Word8, AlexInput) skip move ai = let _newPosition = advance move ai in @@ -1004,12 +1023,12 @@ skipCommentLines :: AlexInput -> Position -> Position skipCommentLines ai p = go p p where - go p' p + go p' p'' -- eof is not a comment line | not (null line) - , isCommentLine ai p - = go p p{ posAbsoluteOffset = posAbsoluteOffset p + length line + 1 -- skip the newline - , posColumn = 1, posLine = posLine p + 1 + , isCommentLine ai p'' + = go p'' p''{ posAbsoluteOffset = posAbsoluteOffset p'' + length line + 1 -- skip the newline + , posColumn = 1, posLine = posLine p'' + 1 } | isContinuation ai' = advance Continuation ai' @@ -1017,7 +1036,7 @@ -- after skipping comment lines, place cursor right at the last newline = p2 where - line = takeLine p ai + line = takeLine p'' ai line' = takeLine p' ai p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line' , posColumn = length line' + 1 @@ -1081,7 +1100,7 @@ parseState <- get fail $ psFilename parseState ++ ": lexing failed. " AlexSkip newAlex _ -> putAlex newAlex >> lexer' - AlexToken newAlex startCode action -> do + AlexToken newAlex _ action -> do putAlex newAlex maybeToken <- action case maybeToken of @@ -1110,7 +1129,8 @@ _vanillaAlexInput = vanillaAlexInput { aiSourceBytes = srcBytes , aiEndOffset = fromIntegral $ B.length srcBytes - , aiFortranVersion = fortranVersion } + , aiFortranVersion = fortranVersion + , aiPosition = initPosition {filePath = filename} } collectFixedTokens :: FortranVersion -> B.ByteString -> [Token] collectFixedTokens version srcInput = diff --git a/src/Language/Fortran/Lexer/FreeForm.x b/src/Language/Fortran/Lexer/FreeForm.x --- a/src/Language/Fortran/Lexer/FreeForm.x +++ b/src/Language/Fortran/Lexer/FreeForm.x @@ -10,8 +10,10 @@ module Language.Fortran.Lexer.FreeForm where +import Prelude hiding (span) import Data.Data import Data.Maybe (fromMaybe) +import Data.List (foldl') import Data.Char (toLower) import Data.Word (Word8) import qualified Data.ByteString.Char8 as B @@ -24,7 +26,7 @@ import Language.Fortran.ParserMonad import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter - +import Language.Fortran.Parser.Utils (readInteger) } @@ -36,6 +38,8 @@ $letter = a-z $alphanumeric = [$letter $digit \_] +$hash = [\#] + @label = $digit{1,5} @name = $letter $alphanumeric* @@ -77,8 +81,11 @@ -------------------------------------------------------------------------------- tokens :- +<0> "/*" { skipCComment } <0,scN> "!".*$ { adjustComment $ addSpanAndMatch TComment } +<0> $hash.*$ { lexHash } + <0,scN,scT> (\n\r|\r\n|\n) { resetPar >> toSC 0 >> addSpan TNewline } <0,scN,scI,scT> [\t\ ]+ ; @@ -87,6 +94,8 @@ ")" { decPar >> addSpan TRightPar } "(/" / { notDefinedOperP } { addSpan TLeftInitPar } "/)" / { notDefinedOperP } { addSpan TRightInitPar } + "[" / { notDefinedOperP } { addSpan TLeftInitPar } + "]" / { notDefinedOperP } { addSpan TRightInitPar } "," { comma } ";" { resetPar >> toSC 0 >> addSpan TSemiColon } ":" { addSpan TColon } @@ -120,8 +129,12 @@ <0> "contains" { addSpan TContains } <0> "use" { addSpan TUse } "only" / { useStP } { addSpan TOnly } +<0> "import" { addSpan TImport } +<0> "abstract" { addSpan TAbstract } <0> "interface" { addSpan TInterface } + "interface" / { genericSpecP } { addSpan TInterface } <0> "end"\ *"interface" { addSpan TEndInterface } +<0> "procedure" { addSpan TProcedure } <0> "module"\ \ *"procedure" { addSpan TModuleProcedure } "assignment"\ *"("\ *"="\ *")" / { genericSpecP } { addSpan TAssignment } "operator" / { genericSpecP } { addSpan TOperator } @@ -132,16 +145,27 @@ -- Type def related <0,scT> "type" { addSpan TType } + "type" / { allocateP } { addSpan TType } <0> "end"\ *"type" { addSpan TEndType } + "class" / { followsProcedureP } { addSpan TClass } <0> "sequence" { addSpan TSequence } +<0> "enum" { addSpan TEnum } +<0> "end"\ *"enum" { addSpan TEndEnum } +<0> "enumerator" { addSpan TEnumerator } -- Intrinsic types <0,scT> "integer" { addSpan TInteger } + "integer" / { allocateP } { addSpan TInteger } <0,scT> "real" { addSpan TReal } + "real" / { allocateP } { addSpan TReal } <0,scT> "double"\ *"precision" { addSpan TDoublePrecision } + "double"\ *"precision" / { allocateP } { addSpan TDoublePrecision } <0,scT> "logical" { addSpan TLogical } + "logical" / { allocateP } { addSpan TLogical } <0,scT> "character" { addSpan TCharacter } + "character" / { allocateP } { addSpan TCharacter } <0,scT> "complex" { addSpan TComplex } + "complex" / { allocateP } { addSpan TComplex } "kind" / { selectorP } { addSpan TKind } "len" / { selectorP } { addSpan TLen } @@ -151,10 +175,14 @@ "public" / { attributeP } { addSpan TPublic } <0> "private" { addSpan TPrivate } "private" / { attributeP } { addSpan TPrivate } +<0> "protected" { addSpan TProtected } + "protected" / { attributeP } { addSpan TProtected } <0> "parameter" { addSpan TParameter } "parameter" / { attributeP } { addSpan TParameter } <0> "allocatable" { addSpan TAllocatable } "allocatable" / { attributeP } { addSpan TAllocatable } +<0> "asynchronous" { addSpan TAsynchronous } + "asynchronous" / { attributeP } { addSpan TAsynchronous } <0> "dimension" { addSpan TDimension } "dimension" / { attributeP } { addSpan TDimension } <0> "external" { addSpan TExternal } @@ -163,6 +191,8 @@ "intent" / { attributeP } { addSpan TIntent } <0> "intrinsic" { addSpan TIntrinsic } "intrinsic" / { attributeP } { addSpan TIntrinsic } +<0> "non_intrinsic" { addSpan TNonIntrinsic } + "non_intrinsic" / { attributeP } { addSpan TNonIntrinsic } <0> "optional" { addSpan TOptional } "optional" / { attributeP } { addSpan TOptional } <0> "pointer" { addSpan TPointer } @@ -171,12 +201,23 @@ "save" / { attributeP } { addSpan TSave } <0> "target" { addSpan TTarget } "target" / { attributeP } { addSpan TTarget } +<0> "save" { addSpan TSave } + "save" / { attributeP } { addSpan TSave } +<0> "value" { addSpan TValue } + "value" / { attributeP } { addSpan TValue } +<0> "volatile" { addSpan TVolatile } + "volatile" / { attributeP } { addSpan TVolatile } -- Attribute values "in"\ *"out" / { followsIntentP } { addSpan TInOut } "in" / { followsIntentP } { addSpan TIn } "out" / { followsIntentP } { addSpan TOut } +-- language-binding-spec + "bind" / { bindP } { addSpan TBind } + "name" / { followsCP } { addSpan TName } + "c" / { followsBindP } { addSpan TC } + -- Control flow <0> "do" { addSpan TDo } "do" / { followsColonP } { addSpan TDo } @@ -207,12 +248,17 @@ -- Where construct <0,scI> "where" { addSpan TWhere } + "where" / { labelledWhereP } { addSpan TWhere } <0> "elsewhere" { addSpan TElsewhere } +<0> "else"\ *"where" { addSpan TElsewhere } <0> "end"\ *"where" { addSpan TEndWhere } -- Beginning keyword <0> "data" { addSpan TData } <0,scI> "allocate" { addSpan TAllocate } + "stat" / { allocateP } { addSpan TStat } + "errmsg" / { allocateP } { addSpan TErrMsg } + "source" / { allocateP } { addSpan TSource } <0,scI> "deallocate" { addSpan TDeallocate } <0,scI> "nullify" { addSpan TNullify } <0> "namelist" { addSpan TNamelist } @@ -233,6 +279,11 @@ <0,scI> "rewind" { addSpan TRewind } <0,scI> "inquire" { addSpan TInquire } <0,scI> "end"\ *"file" { addSpan TEndfile } +<0> "flush" { addSpan TFlush } + "unit" / { followsFlushP } { addSpan TUnit } + "iostat" / { followsFlushP } { addSpan TIOStat } + "iomsg" / { followsFlushP } { addSpan TIOMsg } + "err" / { followsFlushP } { addSpan TErr } -- Format <0> "format" { addSpan TFormat } @@ -293,6 +344,13 @@ | Just TColon{} <- aiPreviousToken ai = True | otherwise = False +labelledWhereP :: User -> AlexInput -> Int -> AlexInput -> Bool +labelledWhereP _ _ _ ai + | TId{}:TColon{}:[] <- prevTokens = True + | otherwise = False + where + prevTokens = reverse . aiPreviousTokensInLine $ ai + selectorP :: User -> AlexInput -> Int -> AlexInput -> Bool selectorP user _ _ ai = followsType && nextTokenIsOpAssign && precedesDoubleColon ai @@ -324,7 +382,7 @@ partOfExpOrPointerAssignmentP :: User -> AlexInput -> Int -> AlexInput -> Bool partOfExpOrPointerAssignmentP (User fv pc) _ _ ai = - case unParse (lexer $ f False 0) ps of + case unParse (lexer $ f False (0::Integer)) ps of ParseOk True _ -> True _ -> False where @@ -351,6 +409,8 @@ TOpAssign{} -> return True TArrow{} -> return True TPercent{} -> return True + TLeftPar{} -> lexer $ f True 1 + TLeftPar2{} -> lexer $ f True 1 _ -> return False | parCount > 0 = case token of @@ -367,18 +427,88 @@ precedesDoubleColon :: AlexInput -> Bool precedesDoubleColon ai = not . flip seenConstr ai . fillConstr $ TDoubleColon +parenLevel :: [Token] -> Int +parenLevel = foldl' f 0 + where + f n tok | fillConstr TLeftPar == toConstr tok = n + 1 + | fillConstr TRightPar == toConstr tok = n - 1 + | otherwise = n + +allocateP :: User -> AlexInput -> Int -> AlexInput -> Bool +allocateP _ _ _ ai + | alloc:lpar:rest <- prevTokens + , toConstr alloc `elem` [fillConstr TAllocate, fillConstr TDeallocate] + , fillConstr TLeftPar == toConstr lpar + = null rest || (followsComma && parenLevel prevTokens == 1) + | otherwise = False + where + prevTokens = reverse . aiPreviousTokensInLine $ ai + followsComma + | Just TComma{} <- aiPreviousToken ai = True + | otherwise = False + attributeP :: User -> AlexInput -> Int -> AlexInput -> Bool -attributeP _ _ _ ai = followsComma && precedesDoubleColon ai && startsWithTypeSpec +attributeP _ _ _ ai = followsComma && precedesDoubleColon ai && lineStartOK where followsComma | Just TComma{} <- aiPreviousToken ai = True | otherwise = False - startsWithTypeSpec - | (token:_) <- prevTokens = - isTypeSpec token || fillConstr TType == toConstr token + + lineStartOK + -- matches e.g.: TYPE (FOO), ATTR + | typ:lpar:_:rpar:com:_ <- prevTokens + , toConstr typ `elem` [fillConstr TType, fillConstr TClass] + , toConstr lpar == fillConstr TLeftPar + , toConstr rpar == fillConstr TRightPar + = fillConstr TComma == toConstr com + + -- matches e.g.: TYPE FOO, ATTR + | typ:com:_ <- prevTokens + , toConstr typ == fillConstr TType + = fillConstr TComma == toConstr com + + -- matches e.g.: INTEGER (KIND=...), ATTR + -- or: PROCEDURE (...), ATTR + | tok:lpar:rest <- prevTokens + , isTypeSpec tok || fillConstr TProcedure == toConstr tok + , fillConstr TLeftPar == toConstr lpar + , (_, _:com:_) <- break ((fillConstr TRightPar ==) . toConstr) rest + = fillConstr TComma == toConstr com + + -- matches e.g.: INTEGER*NUM, ATTR + | tok:star:num:com:_ <- prevTokens + , isTypeSpec tok + , fillConstr TStar == toConstr star + , TIntegerLiteral{} <- num + = fillConstr TComma == toConstr com + + -- matches e.g.: INTEGER, ATTR + -- or: USE, ATTR + | tok:com:_ <- prevTokens + , isTypeSpec tok || fillConstr TUse == toConstr tok + = fillConstr TComma == toConstr com + | otherwise = False + prevTokens = reverse . aiPreviousTokensInLine $ ai +bindP :: User -> AlexInput -> Int -> AlexInput -> Bool +bindP _ _ _ ai = (followsRightPar && isFunSub) || (followsComma && isProcEnum) + where + followsComma + | Just TComma{} <- aiPreviousToken ai = True + | otherwise = False + followsRightPar + | Just TRightPar{} <- aiPreviousToken ai = True + | otherwise = False + isFunSub = flip any prevTokens $ \ token -> + fillConstr TFunction == toConstr token || + fillConstr TSubroutine == toConstr token + isProcEnum = flip any prevTokens $ \ token -> + fillConstr TProcedure == toConstr token || + fillConstr TEnum == toConstr token + prevTokens = reverse . aiPreviousTokensInLine $ ai + constructNameP :: User -> AlexInput -> Int -> AlexInput -> Bool constructNameP user _ _ ai = case nextTokenConstr user ai of @@ -388,10 +518,13 @@ genericSpecP :: User -> AlexInput -> Int -> AlexInput -> Bool genericSpecP _ _ _ ai = Just True == do constr <- prevTokenConstr ai - if constr `elem` fmap fillConstr [ TInterface, TPublic, TPrivate ] + if constr `elem` fmap fillConstr [ TAbstract, TInterface, TPublic, TPrivate, TProtected ] then return True - else if constr `elem` fmap fillConstr [ TComma, TDoubleColon ] - then return $ seenConstr (fillConstr TPublic) ai || seenConstr (fillConstr TPrivate) ai + else if constr `elem` fmap fillConstr [ TComma, TDoubleColon, TColon ] + then return $ seenConstr (fillConstr TPublic) ai || + seenConstr (fillConstr TPrivate) ai || + seenConstr (fillConstr TProtected) ai || + seenConstr (fillConstr TOnly) ai else Nothing notDefinedOperP :: User -> AlexInput -> Int -> AlexInput -> Bool @@ -411,7 +544,7 @@ , isTypeSpec prevToken = True | otherwise = isTypeSpecImmediatelyBefore $ reverse prevTokens where - isTypeSpecImmediatelyBefore tokens@(x:xs) + isTypeSpecImmediatelyBefore tokens@(_:xs) | isTypeSpec tokens = True | otherwise = isTypeSpecImmediatelyBefore xs isTypeSpecImmediatelyBefore [] = False @@ -431,6 +564,25 @@ (map toConstr . take 2 . aiPreviousTokensInLine) ai == map fillConstr [ TLeftPar, TIntent ] +followsProcedureP :: User -> AlexInput -> Int -> AlexInput -> Bool +followsProcedureP _ _ _ ai = + (map toConstr . take 2 . aiPreviousTokensInLine) ai == + map fillConstr [ TLeftPar, TProcedure ] + +followsBindP :: User -> AlexInput -> Int -> AlexInput -> Bool +followsBindP _ _ _ ai = + (map toConstr . take 2 . aiPreviousTokensInLine) ai == + map fillConstr [ TLeftPar, TBind ] + +followsCP :: User -> AlexInput -> Int -> AlexInput -> Bool +followsCP _ _ _ ai = + (map toConstr . take 2 . aiPreviousTokensInLine) ai == + map fillConstr [ TComma, TC ] + +followsFlushP :: User -> AlexInput -> Int -> AlexInput -> Bool +followsFlushP _ _ _ ai = not (null toks) && fillConstr TFlush == toConstr (last toks) + where toks = aiPreviousTokensInLine ai + useStP :: User -> AlexInput -> Int -> AlexInput -> Bool useStP _ _ _ ai = seenConstr (toConstr $ TUse undefined) ai @@ -484,7 +636,7 @@ ParseOk tokenCons _ -> do span <- getLexemeSpan return $ Just $ tokenCons span - ParseFailed e -> fail "Left parantheses is not matched." + ParseFailed _ -> fail "Left parantheses is not matched." else addSpan TLeftPar where f :: LexAction (SrcSpan -> Token) @@ -493,7 +645,7 @@ mPrevToken <- aiPreviousToken <$> getAlex case mPrevToken of Just TRightPar{} | pc == 0 -> do - span <- getLexemeSpan + _ <- getLexemeSpan curToken <- lexer' case curToken of TComma{} -> return TLeftPar2 @@ -620,7 +772,7 @@ putAlex $ alex { aiStartCode = StartCode scC Stable } match <- getMatch let boundaryMarker = last match - _lexChar 0 boundaryMarker + _lexChar (0::Integer) boundaryMarker where _lexChar 0 bm = do alex <- getAlex @@ -650,6 +802,7 @@ match <- getMatch putMatch . init . tail $ match addSpanAndMatch TString + _lexChar _ _ = do fail "unhandled lexCharacter" toSC :: Int -> LexAction () toSC startCode = do @@ -675,7 +828,7 @@ -------------------------------------------------------------------------------- invalidPosition :: Position -invalidPosition = Position 0 0 0 +invalidPosition = Position 0 0 0 "" Nothing {-# INLINE isValidPosition #-} isValidPosition :: Position -> Bool @@ -774,8 +927,10 @@ currentChar :: AlexInput -> Char currentChar !ai -- case sensitivity matters only in character literals - | sCode == scC = _currentChar - | otherwise = {-# SCC toLower_currentChar #-} toLower _currentChar + | sCode == scC = _currentChar + | 'A' <= _currentChar && + _currentChar <= 'Z' = {-# SCC toLower_currentChar #-} toLower _currentChar + | otherwise = _currentChar where sCode = scActual (aiStartCode ai) -- _currentChar = w2c (BU.unsafeIndex srcBytes i) @@ -806,26 +961,27 @@ (scActual . aiStartCode) ai /= scC -- No continuation while lexing a comment. && (null match || not (lexemeIsCmt lexeme)) - && _isContinuation ai 0 + && _isContinuation ai (0::Integer) where match = lexemeMatch lexeme lexeme = aiLexeme $ ai - _isContinuation !ai 0 = - if currentChar ai == '&' - then _advance ai + _isContinuation !ai' 0 = + if currentChar ai' == '&' + then _advance ai' else False - _isContinuation !ai 1 = - case currentChar ai of - ' ' -> _advance ai - '\t' -> _advance ai - '\r' -> _advance ai + _isContinuation !ai' 1 = + case currentChar ai' of + ' ' -> _advance ai' + '\t' -> _advance ai' + '\r' -> _advance ai' '!' -> True '\n' -> True _ -> False + _isContinuation _ _ = False _advance :: AlexInput -> Bool - _advance !ai = - case advanceWithoutContinuation ai of - Just ai' -> _isContinuation ai' 1 + _advance !ai' = + case advanceWithoutContinuation ai' of + Just ai'' -> _isContinuation ai'' (1::Integer) Nothing -> False -- Here's the skip continuation automaton: @@ -850,7 +1006,7 @@ -- This version is more permissive than the specification -- as it allows empty lines to be used between continuations. skipContinuation :: AlexInput -> AlexInput -skipContinuation ai = _skipCont ai 0 +skipContinuation ai' = _skipCont ai' (0::Integer) where _skipCont ai 0 = if currentChar ai == '&' @@ -888,11 +1044,24 @@ -- previous ai, which either has whitespace or newline, so it will -- nicely delimit. else ai + _skipCont _ _ = error "unhandled _skipCont in skipContinuation" _advance ai state = case advanceWithoutContinuation ai of - Just ai' -> _skipCont ai' state + Just ai'' -> _skipCont ai'' state Nothing -> error "File has ended prematurely during a continuation." +-- skip a C comment (read until first "*/") +skipCComment :: LexAction (Maybe Token) +skipCComment = do + let loop (Just ai) 0 | currentChar ai == '*' = loop (advanceWithoutContinuation ai) 1 + | otherwise = loop (advanceWithoutContinuation ai) 0 + loop (Just ai) 1 | currentChar ai == '/' = ai `fromMaybe` advanceWithoutContinuation ai + | otherwise = loop (advanceWithoutContinuation ai) 0 + loop _ _ = error "File has ended prematurely during a C comment." + ai <- getAlex + putAlex $ loop (Just ai) (0 :: Int) + return Nothing + advance :: Move -> Position -> Position advance move position = case move of @@ -901,11 +1070,31 @@ { posAbsoluteOffset = _absl + 1 , posColumn = 1 , posLine = _line + 1 } Char -> position { posAbsoluteOffset = _absl + 1 , posColumn = _col + 1 } +-- for now just return the original position + _ -> position { posAbsoluteOffset = _absl, posColumn = _col } where _col = posColumn position _line = posLine position _absl = posAbsoluteOffset position +-- Handle pragmas that begin with # +lexHash :: LexAction (Maybe Token) +lexHash = do + ai <- getAlex + m <- getMatch + case words (drop 1 m) of + -- 'line' pragma - rewrite the current line and filename + "line":lineStr:_ + | Just line <- readInteger lineStr -> do + let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"") + let file = revdropWNQ . revdropWNQ $ m + let lineOffs = fromIntegral line - posLine (aiPosition ai) - 1 + let newP = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file) + , posColumn = 1 } + putAlex $ ai { aiPosition = newP } + _ -> return () + return Nothing + -------------------------------------------------------------------------------- -- Lexer definition -------------------------------------------------------------------------------- @@ -919,11 +1108,11 @@ alex <- getAlex let startCode = scActual . aiStartCode $ alex normaliseStartCode - newAlex <- getAlex + newAlex' <- getAlex version <- getVersion paranthesesCount <- getParanthesesCount let user = User version paranthesesCount - case alexScanUser user newAlex startCode of + case alexScanUser user newAlex' startCode of AlexEOF -> return $ TEOF $ SrcSpan (getPos alex) (getPos alex) AlexError _ -> do parseState <- get @@ -997,7 +1186,7 @@ | TFunction SrcSpan | TEndFunction SrcSpan | TResult SrcSpan - | TPure SrcSpan + | TPure SrcSpan | TElemental SrcSpan | TRecursive SrcSpan | TSubroutine SrcSpan @@ -1009,8 +1198,11 @@ | TContains SrcSpan | TUse SrcSpan | TOnly SrcSpan + | TImport SrcSpan + | TAbstract SrcSpan | TInterface SrcSpan | TEndInterface SrcSpan + | TProcedure SrcSpan | TModuleProcedure SrcSpan | TAssignment SrcSpan | TOperator SrcSpan @@ -1018,19 +1210,28 @@ | TReturn SrcSpan | TEntry SrcSpan | TInclude SrcSpan + -- language-binding-spec + | TBind SrcSpan + | TC SrcSpan + | TName SrcSpan -- Attributes - | TPublic SrcSpan - | TPrivate SrcSpan - | TParameter SrcSpan | TAllocatable SrcSpan + | TAsynchronous SrcSpan | TDimension SrcSpan | TExternal SrcSpan | TIntent SrcSpan | TIntrinsic SrcSpan + | TNonIntrinsic SrcSpan | TOptional SrcSpan + | TParameter SrcSpan | TPointer SrcSpan + | TPrivate SrcSpan + | TPublic SrcSpan + | TProtected SrcSpan | TSave SrcSpan | TTarget SrcSpan + | TValue SrcSpan + | TVolatile SrcSpan -- Attribute values | TIn SrcSpan | TOut SrcSpan @@ -1044,6 +1245,9 @@ | TFormat SrcSpan | TBlob SrcSpan String | TAllocate SrcSpan + | TStat SrcSpan + | TErrMsg SrcSpan + | TSource SrcSpan | TDeallocate SrcSpan | TNullify SrcSpan -- Misc @@ -1079,6 +1283,10 @@ | TType SrcSpan | TEndType SrcSpan | TSequence SrcSpan + | TClass SrcSpan + | TEnum SrcSpan + | TEnumerator SrcSpan + | TEndEnum SrcSpan -- Selector | TKind SrcSpan | TLen SrcSpan @@ -1103,6 +1311,11 @@ | TEnd SrcSpan | TNewline SrcSpan | TEOF SrcSpan + | TFlush SrcSpan + | TUnit SrcSpan + | TIOStat SrcSpan + | TIOMsg SrcSpan + | TErr SrcSpan deriving (Eq, Show, Data, Typeable, Generic) instance FirstParameter Token SrcSpan @@ -1158,7 +1371,8 @@ , psContext = [ ConStart ] } _vanillaAlexInput = vanillaAlexInput { aiSourceBytes = srcBytes - , aiEndOffset = B.length srcBytes } + , aiEndOffset = B.length srcBytes + , aiPosition = initPosition {filePath = filename} } collectFreeTokens :: FortranVersion -> B.ByteString -> [Token] collectFreeTokens version srcInput = diff --git a/src/Language/Fortran/Parser/Any.hs b/src/Language/Fortran/Parser/Any.hs --- a/src/Language/Fortran/Parser/Any.hs +++ b/src/Language/Fortran/Parser/Any.hs @@ -10,6 +10,7 @@ , legacy77Parser, legacy77ParserWithModFiles ) import Language.Fortran.Parser.Fortran90 ( fortran90Parser, fortran90ParserWithModFiles ) import Language.Fortran.Parser.Fortran95 ( fortran95Parser, fortran95ParserWithModFiles ) +import Language.Fortran.Parser.Fortran2003 ( fortran2003Parser, fortran2003ParserWithModFiles ) import qualified Data.ByteString.Char8 as B import Data.Char (toLower) @@ -39,7 +40,8 @@ , (Fortran77Extended, fromParseResult `after` extended77Parser) , (Fortran77Legacy, fromParseResult `after` legacy77Parser) , (Fortran90, fromParseResult `after` fortran90Parser) - , (Fortran95, fromParseResult `after` fortran95Parser) ] + , (Fortran95, fromParseResult `after` fortran95Parser) + , (Fortran2003, fromParseResult `after` fortran2003Parser) ] type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserWithModFilesVersions :: [(FortranVersion, ParserWithModFiles)] @@ -49,9 +51,11 @@ , (Fortran77Extended, \m s -> fromParseResult . extended77ParserWithModFiles m s) , (Fortran77Legacy, \m s -> fromParseResult . legacy77ParserWithModFiles m s) , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s) - , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) ] + , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) + , (Fortran2003, \m s -> fromParseResult . fortran2003ParserWithModFiles m s) ] -after g f x = g . (f x) +after :: (b -> c) -> (t -> a -> b) -> t -> a -> c +after g f x = g . f x -- | Deduce the type of parser from the filename and parse the -- contents of the file. @@ -65,4 +69,17 @@ fortranParserWithModFiles :: ParserWithModFiles fortranParserWithModFiles mods contents filename = do let Just parserF = lookup (deduceVersion filename) parserWithModFilesVersions + parserF mods contents filename + +-- | Given a FortranVersion, parse the contents of the file. +fortranParserWithVersion :: FortranVersion -> Parser +fortranParserWithVersion v contents filename = do + let Just parserF = lookup v parserVersions + parserF contents filename + +-- | Given a FortranVersion, parse the contents of the file, within +-- the context of given "mod files". +fortranParserWithModFilesAndVersion :: FortranVersion -> ParserWithModFiles +fortranParserWithModFilesAndVersion v mods contents filename = do + let Just parserF = lookup v parserWithModFilesVersions parserF mods contents filename diff --git a/src/Language/Fortran/Parser/Fortran2003.y b/src/Language/Fortran/Parser/Fortran2003.y new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Parser/Fortran2003.y @@ -0,0 +1,1328 @@ +-- -*- Mode: Haskell -*- +{ +-- Incomplete work-in-progress. +module Language.Fortran.Parser.Fortran2003 ( functionParser + , statementParser + , fortran2003Parser + , fortran2003ParserWithModFiles + ) where + +import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST +import Control.Monad.State +import Data.Maybe (fromMaybe, isJust) +import Data.List (nub) +import Data.Either (either, lefts, rights, partitionEithers) +import Control.Applicative +import qualified Data.ByteString.Char8 as B + +#ifdef DEBUG +import Data.Data (toConstr) +#endif + +import Language.Fortran.Util.Position +import Language.Fortran.Util.ModFile +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FreeForm +import Language.Fortran.AST +import Language.Fortran.Transformer + +import Debug.Trace + +} + +%name programParser PROGRAM +%name statementParser STATEMENT +%name functionParser SUBPROGRAM_UNIT +%monad { LexAction } +%lexer { lexer } { TEOF _ } +%tokentype { Token } +%error { parseError } + +%token + id { TId _ _ } + comment { TComment _ _ } + string { TString _ _ } + int { TIntegerLiteral _ _ } + float { TRealLiteral _ _ } + boz { TBozLiteral _ _ } + ',' { TComma _ } + ',2' { TComma2 _ } + ';' { TSemiColon _ } + ':' { TColon _ } + '::' { TDoubleColon _ } + '=' { TOpAssign _ } + '=>' { TArrow _ } + '%' { TPercent _ } + '(' { TLeftPar _ } + '(2' { TLeftPar2 _ } + ')' { TRightPar _ } + '(/' { TLeftInitPar _ } + '/)' { TRightInitPar _ } + opCustom { TOpCustom _ _ } + '**' { TOpExp _ } + '+' { TOpPlus _ } + '-' { TOpMinus _ } + '*' { TStar _ } + '/' { TOpDivision _ } + slash { TSlash _ } + or { TOpOr _ } + and { TOpAnd _ } + not { TOpNot _ } + eqv { TOpEquivalent _ } + neqv { TOpNotEquivalent _ } + '<' { TOpLT _ } + '<=' { TOpLE _ } + '==' { TOpEQ _ } + '!=' { TOpNE _ } + '>' { TOpGT _ } + '>=' { TOpGE _ } + bool { TLogicalLiteral _ _ } + program { TProgram _ } + endProgram { TEndProgram _ } + function { TFunction _ } + endFunction { TEndFunction _ } + result { TResult _ } + pure { TPure _ } + elemental { TElemental _ } + recursive { TRecursive _ } + subroutine { TSubroutine _ } + endSubroutine { TEndSubroutine _ } + blockData { TBlockData _ } + endBlockData { TEndBlockData _ } + module { TModule _ } + endModule { TEndModule _ } + contains { TContains _ } + use { TUse _ } + only { TOnly _ } + import { TImport _ } + abstract { TAbstract _ } + interface { TInterface _ } + endInterface { TEndInterface _ } + moduleProcedure { TModuleProcedure _ } + procedure { TProcedure _ } + assignment { TAssignment _ } + operator { TOperator _ } + call { TCall _ } + return { TReturn _ } + entry { TEntry _ } + include { TInclude _ } + public { TPublic _ } + private { TPrivate _ } + protected { TProtected _ } + parameter { TParameter _ } + allocatable { TAllocatable _ } + asynchronous { TAsynchronous _ } + dimension { TDimension _ } + external { TExternal _ } + intent { TIntent _ } + intrinsic { TIntrinsic _ } + nonintrinsic { TNonIntrinsic _ } + optional { TOptional _ } + pointer { TPointer _ } + save { TSave _ } + target { TTarget _ } + value { TValue _ } + volatile { TVolatile _ } + bind { TBind _ } + 'c' { TC _ } + name { TName _ } + in { TIn _ } + out { TOut _ } + inout { TInOut _ } + data { TData _ } + namelist { TNamelist _ } + implicit { TImplicit _ } + equivalence { TEquivalence _ } + common { TCommon _ } + allocate { TAllocate _ } + deallocate { TDeallocate _ } + stat { TStat _ } + errmsg { TErrMsg _ } + source { TSource _ } + nullify { TNullify _ } + none { TNone _ } + goto { TGoto _ } + to { TTo _ } + continue { TContinue _ } + stop { TStop _ } + do { TDo _ } + enddo { TEndDo _ } + while { TWhile _ } + if { TIf _ } + then { TThen _ } + else { TElse _ } + elsif { TElsif _ } + endif { TEndIf _ } + case { TCase _ } + selectcase { TSelectCase _ } + endselect { TEndSelect _ } + default { TDefault _ } + cycle { TCycle _ } + exit { TExit _ } + where { TWhere _ } + elsewhere { TElsewhere _ } + endwhere { TEndWhere _ } + type { TType _ } + endType { TEndType _ } + class { TClass _ } + enum { TEnum _ } + enumerator { TEnumerator _ } + endEnum { TEndEnum _ } + sequence { TSequence _ } + kind { TKind _ } + len { TLen _ } + integer { TInteger _ } + real { TReal _ } + doublePrecision { TDoublePrecision _ } + logical { TLogical _ } + character { TCharacter _ } + complex { TComplex _ } + open { TOpen _ } + close { TClose _ } + read { TRead _ } + write { TWrite _ } + print { TPrint _ } + flush { TFlush _ } + unit { TUnit _ } + iostat { TIOStat _ } + iomsg { TIOMsg _ } + err { TErr _ } + backspace { TBackspace _ } + rewind { TRewind _ } + inquire { TInquire _ } + endfile { TEndfile _ } + format { TFormat _ } + blob { TBlob _ _ } + end { TEnd _ } + newline { TNewline _ } + forall { TForall _ } + endforall { TEndForall _ } +-- Precedence of operators + +-- Level 6 +%left opCustom + +-- Level 5 +%left eqv neqv +%left or +%left and +%right not + +-- Level 4 +%nonassoc '==' '!=' '>' '<' '>=' '<=' +%nonassoc RELATIONAL + +-- Level 3 +%left CONCAT + +-- Level 2 +%left '+' '-' +%left '*' '/' +%right SIGN +%right '**' + +-- Level 1 +%right DEFINED_UNARY + +-- Level 0 +%left '%' + +%% + +-- This rule is to ignore leading whitespace +PROGRAM :: { ProgramFile A0 } +: NEWLINE PROGRAM_INNER { $2 } +| PROGRAM_INNER { $1 } + +PROGRAM_INNER :: { ProgramFile A0 } +: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran2003, miFilename = "" }) (reverse $1) } + +PROGRAM_UNITS :: { [ ProgramUnit A0 ] } +: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 } +| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] } + +PROGRAM_UNIT :: { ProgramUnit A0 } +: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END + {% do { unitNameCheck $6 $2; + return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } } +| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END + {% do { unitNameCheck $6 $2; + return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } } +| blockData NEWLINE BLOCKS BLOCK_DATA_END + { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } +| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END + {% do { unitNameCheck $5 $2; + return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } } +| SUBPROGRAM_UNIT { $1 } + +MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] } +: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 } +| {- Empty -} { Nothing } + +SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] } +: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 } +| {- EMPTY -} { [ ] } + +SUBPROGRAM_UNIT :: { ProgramUnit A0 } +: PREFIXES function NAME MAYBE_ARGUMENTS FUNC_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END + {% do { unitNameCheck $10 $3; + let (pfxs, typeSpec) = case partitionEithers $1 of + { (ps, t:_) -> (fromReverseList' ps, Just t) + ; (ps, []) -> (fromReverseList' ps, Nothing) } in + let (sfx, result) = $5 in + let sfx' = fmap (\ s -> AList () (getSpan s) [s]) sfx in + let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in + if validPrefixSuffix (pfxs, sfx') then + return $ PUFunction () ss typeSpec (pfxs, sfx') $3 $4 result (reverse $8) $9 + else fail "Cannot specify elemental along with recursive and/or bind." } } +| PREFIXES subroutine NAME MAYBE_ARGUMENTS SUBR_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END + {% do { unitNameCheck $10 $3; + (pfxs, typeSpec) <- case partitionEithers $1 of + { (ps, t:_) -> fail "Subroutines cannot have return types." + ; (ps, []) -> return (fromReverseList' ps, Nothing) }; + let sfx' = fmap (\ s -> AList () (getSpan s) [s]) $5 in + let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in + if validPrefixSuffix (pfxs, sfx') then + return $ PUSubroutine () ss (pfxs, sfx') $3 $4 (reverse $8) $9 + else fail "Cannot specify elemental along with recursive and/or bind." } } +| comment { let (TComment s c) = $1 in PUComment () s (Comment c) } + +-- (Fortran2003) R1227, Fortran95 (...) +PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] } +: PREFIXES PREFIX { $2:$1 } +| {- EMPTY -} { [] } + +-- (Fortran2003) R1228, Fortran95 (...) +PREFIX :: { Either (Prefix A0) (TypeSpec A0) } +: recursive { Left $ PfxRecursive () (getSpan $1) } +| elemental { Left $ PfxElemental () (getSpan $1) } +| pure { Left $ PfxPure () (getSpan $1) } +| TYPE_SPEC { Right $1 } + +FUNC_SUFFIX :: { (Maybe (Suffix A0), Maybe (Expression A0)) } +: SUFFIX RESULT { (Just $1, Just $2) } +| RESULT SUFFIX { (Just $2, Just $1) } +| SUFFIX { (Just $1, Nothing) } +| RESULT { (Nothing, Just $1) } +| {- empty -} { (Nothing, Nothing) } + +SUBR_SUFFIX :: { Maybe (Suffix A0) } +: SUFFIX { Just $1 } +| {- empty -} { Nothing } + +-- (Fortran2003) R1229 +SUFFIX :: { Suffix A0 } +-- (Fortran2003) R509 +: bind '(' 'c' ',' name '=' EXPRESSION ')' { SfxBind () (getTransSpan $1 $8) (Just $7) } +| bind '(' 'c' ')' { SfxBind () (getTransSpan $1 $4) Nothing } + +MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } +: '(' MAYBE_VARIABLES ')' { $2 } +| {- Nothing -} { Nothing } + +RESULT :: { Expression A0 } +: result '(' VARIABLE ')' { $3 } + +MAYBE_RESULT :: { Maybe (Expression A0) } +: RESULT { Just $1 } +| {- empty -} { Nothing} + +PROGRAM_END :: { Token } +: end { $1 } | endProgram { $1 } | endProgram id { $2 } +MODULE_END :: { Token } +: end { $1 } | endModule { $1 } | endModule id { $2 } +FUNCTION_END :: { Token } +: end { $1 } | endFunction { $1 } | endFunction id { $2 } +SUBROUTINE_END :: { Token } +: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 } +BLOCK_DATA_END :: { Token } +: end { $1 } | endBlockData { $1 } | endBlockData id { $2 } +INTERFACE_END :: { Token } +: end { $1 } | endInterface { $1 } | endInterface id { $2 } + +NAME :: { Name } : id { let (TId _ name) = $1 in name } + +IMPORT_NAME_LIST :: { [Expression A0] } +: IMPORT_NAME_LIST ',' VARIABLE { $3:$1 } +| VARIABLE { [$1] } + +BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } + +BLOCK :: { Block A0 } +: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE + { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } +| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } +| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $2 $10) $3 $1 (reverse $6) (reverse $7) } +| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $2 $9) $3 $1 [ ] (reverse $6) } +| COMMENT_BLOCK { $1 } + +ABSTRACTP :: { Bool } +: abstract { True } +| {- EMPTY -} { False } + +MAYBE_EXPRESSION :: { Maybe (Expression A0) } +: EXPRESSION { Just $1 } +| {- EMPTY -} { Nothing } + +MAYBE_COMMENT :: { Maybe Token } +: comment { Just $1 } +| {- EMPTY -} { Nothing } + +SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] } +: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 } + +MODULE_PROCEDURES :: { [ Block A0 ] } +: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 } +| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 } +| { [ ] } + +MODULE_PROCEDURE :: { Block A0 } +: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE + { let { al = fromReverseList $2; + st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) } + in BlStatement () (getTransSpan $1 $4) Nothing st } + +COMMENT_BLOCK :: { Block A0 } +: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } + +MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing } + +NEWLINE :: { Token } +: NEWLINE newline { $1 } +| NEWLINE ';' { $1 } +| newline { $1 } +| ';' { $1 } + +STATEMENT :: { Statement A0 } +: NONEXECUTABLE_STATEMENT { $1 } +| EXECUTABLE_STATEMENT { $1 } + +EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 } +: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 } + +NONEXECUTABLE_STATEMENT :: { Statement A0 } +: DECLARATION_STATEMENT { $1 } +| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $6 + in StIntent () (getTransSpan $1 expAList) $3 expAList } +| optional MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StOptional () (getTransSpan $1 expAList) expAList } +| public MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StPublic () (getTransSpan $1 expAList) (Just expAList) } +| public { StPublic () (getSpan $1) Nothing } +| private MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StPrivate () (getTransSpan $1 expAList) (Just expAList) } +| private { StPrivate () (getSpan $1) Nothing } +| protected MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StProtected () (getTransSpan $1 expAList) (Just expAList) } +| protected { StProtected () (getSpan $1) Nothing } +| save MAYBE_DCOLON SAVE_ARGS + { 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 } +| dimension MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StDimension () (getTransSpan $1 declAList) declAList } +| allocatable MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StAllocatable () (getTransSpan $1 declAList) declAList } +| asynchronous MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StAsynchronous () (getTransSpan $1 declAList) declAList } +| pointer MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StPointer () (getTransSpan $1 declAList) declAList } +| target MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StTarget () (getTransSpan $1 declAList) declAList } +| value MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StValue () (getTransSpan $1 declAList) declAList } +| volatile MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StVolatile () (getTransSpan $1 declAList) declAList } +| data cDATA DATA_GROUPS cPOP + { let dataAList = fromReverseList $3 + in StData () (getTransSpan $1 dataAList) dataAList } +| parameter '(' PARAMETER_ASSIGNMENTS ')' + { let declAList = fromReverseList $3 + in StParameter () (getTransSpan $1 $4) declAList } +| implicit none { StImplicit () (getTransSpan $1 $2) Nothing } +| implicit cIMPLICIT IMP_LISTS cPOP + { let impAList = fromReverseList $3 + in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList } +| namelist cNAMELIST NAMELISTS cPOP + { let nameALists = fromReverseList $3 + in StNamelist () (getTransSpan $1 nameALists) nameALists } +| equivalence EQUIVALENCE_GROUPS + { let eqALists = fromReverseList $2 + in StEquivalence () (getTransSpan $1 eqALists) eqALists } +| common cCOMMON COMMON_GROUPS cPOP + { let commonAList = fromReverseList $3 + in StCommon () (getTransSpan $1 commonAList) commonAList } +| external MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 + in StExternal () (getTransSpan $1 alist) alist } +| intrinsic MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 + in StIntrinsic () (getTransSpan $1 alist) alist } +| use MODULE_NATURE VARIABLE { StUse () (getTransSpan $1 $3) $3 $2 Permissive Nothing } +| use MODULE_NATURE VARIABLE ',' RENAME_LIST + { let alist = fromReverseList $5 + in StUse () (getTransSpan $1 alist) $3 $2 Permissive (Just alist) } +| use MODULE_NATURE VARIABLE ',' only ':' MAYBE_RENAME_LIST + { StUse () (getTransSpan $1 ($6, $7)) $3 $2 Exclusive $7 } +| entry VARIABLE MAYBE_RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 } +| entry VARIABLE '(' ')' MAYBE_RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 } +| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 } +| sequence { StSequence () (getSpan $1) } +| type ATTRIBUTE_LIST '::' id + { let { TId span id = $4; + alist = if null $2 then Nothing else (Just . fromReverseList) $2 } + in StType () (getTransSpan $1 span) alist id } +| type id + { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id } +| endType { StEndType () (getSpan $1) Nothing } +| endType id + { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) } +-- R461-R464 +| enum ',' bind '(' 'c' ')' { StEnum () (getTransSpan $1 $6) } +| enumerator MAYBE_DCOLON ENUMERATOR_LIST { StEnumerator () (getTransSpan $1 $3) (fromReverseList $3) } +| endEnum { StEndEnum () (getSpan $1) } +| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing } +-- R1209 +| import '::' IMPORT_NAME_LIST { StImport () (getTransSpan $1 $3) (fromReverseList $3) } +| import IMPORT_NAME_LIST { StImport () (getTransSpan $1 $2) (fromReverseList $2) } +-- Following is a fake node to make arbitrary FORMAT statements parsable. +-- Must be fixed in the future. TODO +| format blob + { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } + +ENUMERATOR_LIST :: { [Declarator A0] } +: ENUMERATOR_LIST ',' ENUMERATOR { $3:$1 } +| ENUMERATOR { [$1] } + +-- R463 +ENUMERATOR :: { Declarator A0 } +: VARIABLE '=' EXPRESSION { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) } +| VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing } + +MAYBE_PROC_INTERFACE :: { Maybe (ProcInterface A0) } +: TYPE_SPEC { Just $ ProcInterfaceType () (getSpan $1) $1 } +| VARIABLE { Just $ ProcInterfaceName () (getSpan $1) $1 } +| {- EMPTY -} { Nothing } + +PROC_DECLS :: { [ProcDecl A0] } +: PROC_DECLS ',' PROC_DECL { $3 : $1 } +| PROC_DECL { [ $1 ] } + +PROC_DECL :: { ProcDecl A0 } +: VARIABLE '=>' EXPRESSION { ProcDecl () (getTransSpan $1 $3) $1 (Just $3) } +| VARIABLE { ProcDecl () (getSpan $1) $1 Nothing } + +MODULE_NATURE :: { Maybe ModuleNature } +: ',' intrinsic '::' { Just ModIntrinsic } +| ',' nonintrinsic '::' { Just ModNonIntrinsic } +| '::' { Nothing } +| {- empty -} { Nothing } + +EXECUTABLE_STATEMENT :: { Statement A0 } +: allocate '(' MAYBE_TYPE_SPEC DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StAllocate () (getTransSpan $1 $6) $3 (fromReverseList $4) $5 } +| nullify '(' DATA_REFS ')' + { StNullify () (getTransSpan $1 $4) (fromReverseList $3) } +| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 } +| EXPRESSION_ASSIGNMENT_STATEMENT { $1 } +| POINTER_ASSIGNMENT_STMT { $1 } +| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT + { StWhere () (getTransSpan $1 $5) $3 $5 } +| id ':' where '(' EXPRESSION ')' { let (TId s1 id) = $1 in StWhereConstruct () (getTransSpan $1 $6) (Just id) $5 } +| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 } +| elsewhere '(' EXPRESSION ')' id { let TId _ id = $5 in StElsewhere () (getTransSpan $1 $5) (Just id) (Just $3) } +| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) } +| elsewhere id { let TId _ id = $2 in StElsewhere () (getTransSpan $1 $2) (Just id) Nothing } +| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing } +| endwhere id { let TId _ id = $2 in StEndWhere () (getTransSpan $1 $2) (Just id) } +| endwhere { StEndWhere () (getSpan $1) Nothing } +| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL + { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } +| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 } +| id ':' if '(' EXPRESSION ')' then + { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 } +| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 } +| elsif '(' EXPRESSION ')' then id + { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 } +| else { StElse () (getSpan $1) Nothing } +| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) } +| endif { StEndif () (getSpan $1) Nothing } +| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) } +| do { StDo () (getSpan $1) Nothing Nothing Nothing } +| id ':' do + { let TId s id = $1 + in StDo () (getTransSpan s $3) (Just id) Nothing Nothing } +| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION + { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) } +| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) } +| id ':' do DO_SPECIFICATION + { let TId s id = $1 + in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) } +| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 } +| do while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 } +| id ':' do while '(' EXPRESSION ')' + { let TId s id = $1 + in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 } +| enddo { StEnddo () (getSpan $1) Nothing } +| enddo id + { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) } +| cycle { StCycle () (getSpan $1) Nothing } +| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) } +| exit { StExit () (getSpan $1) Nothing } +| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) } +-- GO TO label +| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 } +-- GO TO label-list [,] scalar-int-expression +| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION + { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 } +| continue { StContinue () (getSpan $1) } +| stop { StStop () (getSpan $1) Nothing } +| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) } +| selectcase '(' EXPRESSION ')' + { StSelectCase () (getTransSpan $1 $4) Nothing $3 } +| id ':' selectcase '(' EXPRESSION ')' + { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 } +| case default { StCase () (getTransSpan $1 $2) Nothing Nothing } +| case default id + { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing } +| case '(' INDICIES ')' + { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) } +| case '(' INDICIES ')' id + { let TId s id = $5 + in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) } +| endselect { StEndcase () (getSpan $1) Nothing } +| endselect id + { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } +| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT + { StIfLogical () (getTransSpan $1 $5) $3 $5 } +| read CILIST IN_IOLIST + { let alist = fromReverseList $3 + in StRead () (getTransSpan $1 alist) $2 (Just alist) } +| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing } +| read FORMAT_ID ',' IN_IOLIST + { let alist = fromReverseList $4 + in StRead2 () (getTransSpan $1 alist) $2 (Just alist) } +| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing } +| write CILIST OUT_IOLIST + { let alist = fromReverseList $3 + in StWrite () (getTransSpan $1 alist) $2 (Just alist) } +| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing } +| print FORMAT_ID ',' OUT_IOLIST + { let alist = fromReverseList $4 + in StPrint () (getTransSpan $1 alist) $2 (Just alist) } +| print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing } +| open CILIST { StOpen () (getTransSpan $1 $2) $2 } +| close CILIST { StClose () (getTransSpan $1 $2) $2 } +| inquire CILIST { StInquire () (getTransSpan $1 $2) $2 } +| rewind CILIST { StRewind () (getTransSpan $1 $2) $2 } +| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 } +| endfile CILIST { StEndfile () (getTransSpan $1 $2) $2 } +| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 } +| backspace CILIST { StBackspace () (getTransSpan $1 $2) $2 } +| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 } +| 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 '(' ARGUMENTS ')' + { let alist = fromReverseList $4 + in StCall () (getTransSpan $1 $5) $2 (Just alist) } +| return { StReturn () (getSpan $1) Nothing } +| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) } +| FORALL { $1 } +| END_FORALL { $1 } + +ARGUMENTS :: { [ Argument A0 ] } +: ARGUMENTS ',' ARGUMENT { $3 : $1 } +| ARGUMENT { [ $1 ] } + +ARGUMENT :: { Argument A0 } +: id '=' EXPRESSION + { let TId span keyword = $1 + in Argument () (getTransSpan span $3) (Just keyword) $3 } +| EXPRESSION + { Argument () (getSpan $1) Nothing $1 } + +MAYBE_RENAME_LIST :: { Maybe (AList Use A0) } +: RENAME_LIST { Just $ fromReverseList $1 } +| {- empty -} { Nothing } + +RENAME_LIST :: { [ Use A0 ] } +: RENAME_LIST ',' RENAME { $3 : $1 } +| RENAME { [ $1 ] } + +RENAME :: { Use A0 } +: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 } +| VARIABLE { UseID () (getSpan $1) $1 } +| operator '(' opCustom ')' + { let TOpCustom ss op = $3 + in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) } +| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) } + +MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () } + +FORMAT_ID :: { Expression A0 } +: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| INTEGER_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +UNIT :: { Expression A0 } +: INTEGER_LITERAL { $1 } +| DATA_REF { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +{- R928 -} +FLUSH_SPEC_LIST :: { [ FlushSpec A0 ] } +: FLUSH_SPEC_LIST ',' FLUSH_SPEC { $3 : $1 } +| FLUSH_SPEC { [ $1 ] } + +{- R928 -} +FLUSH_SPEC :: { FlushSpec A0 } +: 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 } + +CILIST :: { AList ControlPair A0 } +: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + cp2 = ControlPair () (getSpan $4) Nothing $4; + tail = fromReverseList $6 } + in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail } +| '(' CILIST_ELEMENT ',' FORMAT_ID ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + cp2 = ControlPair () (getSpan $4) Nothing $4 } + in AList () (getTransSpan $1 $5) [ cp1, cp2 ] } +| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + tail = fromReverseList $4 } + in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail } +| '(' CILIST_ELEMENT ')' + { let cp1 = ControlPair () (getSpan $2) Nothing $2 + in AList () (getTransSpan $1 $3) [ cp1 ] } +| '(' CILIST_PAIRS ')' { fromReverseList $2 } + +CILIST_PAIRS :: { [ ControlPair A0 ] } +: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 } +| CILIST_PAIR { [ $1 ] } + +CILIST_PAIR :: { ControlPair A0 } +: id '=' CILIST_ELEMENT + { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 } + +CILIST_ELEMENT :: { Expression A0 } +: CI_EXPRESSION { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +CI_EXPRESSION :: { Expression A0 } +: CI_EXPRESSION '+' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } +| CI_EXPRESSION '-' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } +| CI_EXPRESSION '*' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +| CI_EXPRESSION '/' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Division $1 $3 } +| CI_EXPRESSION '**' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 } +| CI_EXPRESSION '/' '/' CI_EXPRESSION %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| ARITHMETIC_SIGN CI_EXPRESSION %prec SIGN + { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } +| CI_EXPRESSION or CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| CI_EXPRESSION and CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) And $1 $3 } +| not CI_EXPRESSION + { ExpUnary () (getTransSpan $1 $2) Not $2 } +| CI_EXPRESSION eqv CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } +| CI_EXPRESSION neqv CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 } +| CI_EXPRESSION RELATIONAL_OPERATOR CI_EXPRESSION %prec RELATIONAL + { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } +| opCustom CI_EXPRESSION %prec DEFINED_UNARY + { let TOpCustom span str = $1 + in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 } +| CI_EXPRESSION opCustom CI_EXPRESSION + { let TOpCustom _ str = $2 + in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 } +| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } +| INTEGER_LITERAL { $1 } +| LOGICAL_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } + +MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) } +: ',' ALLOC_OPT_LIST { Just $ fromReverseList $2 } +| {- empty -} { Nothing } + +ALLOC_OPT_LIST :: { [ AllocOpt A0 ] } +: ALLOC_OPT_LIST ',' ALLOC_OPT { $3 : $1 } +| ALLOC_OPT { [ $1 ] } + +{- R624 -} +ALLOC_OPT :: { AllocOpt A0 } +: stat '=' EXPRESSION { AOStat () (getTransSpan $1 $3) $3 } +| errmsg '=' EXPRESSION { AOErrMsg () (getTransSpan $1 $3) $3 } +| source '=' EXPRESSION { AOSource () (getTransSpan $1 $3) $3 } + +IN_IOLIST :: { [ Expression A0 ] } +: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1} +| IN_IO_ELEMENT { [ $1 ] } + +IN_IO_ELEMENT :: { Expression A0 } +: DATA_REF { $1 } +| '(' IN_IOLIST ',' DO_SPECIFICATION ')' + { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 } + +OUT_IOLIST :: { [ Expression A0 ] } +: OUT_IOLIST ',' EXPRESSION { $3 : $1} +| EXPRESSION { [ $1 ] } + +COMMON_GROUPS :: { [ CommonGroup A0 ] } +: COMMON_GROUPS COMMON_GROUP { $2 : $1 } +| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 } +| INIT_COMMON_GROUP { [ $1 ] } + +COMMON_GROUP :: { CommonGroup A0 } +: COMMON_NAME PART_REFS + { let alist = fromReverseList $2 + in CommonGroup () (getTransSpan $1 alist) (Just $1) alist } +| '/' '/' PART_REFS + { let alist = fromReverseList $3 + in CommonGroup () (getTransSpan $1 alist) Nothing alist } + +INIT_COMMON_GROUP :: { CommonGroup A0 } +: COMMON_NAME PART_REFS + { let alist = fromReverseList $2 + in CommonGroup () (getTransSpan $1 alist) (Just $1) alist } +| '/' '/' PART_REFS + { let alist = fromReverseList $3 + in CommonGroup () (getTransSpan $1 alist) Nothing alist } +| PART_REFS + { let alist = fromReverseList $1 + in CommonGroup () (getSpan alist) Nothing alist } + +EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] } +: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')' + { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 } +| '(' PART_REFS ')' + { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] } + +NAMELISTS :: { [ Namelist A0 ] } +: NAMELISTS NAMELIST { $2 : $1 } +| NAMELISTS ',2' NAMELIST { $3 : $1 } +| NAMELIST { [ $1 ] } + +NAMELIST :: { Namelist A0 } +: '/' VARIABLE '/' VARIABLES + { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 } + +MAYBE_VARIABLES :: { Maybe (AList Expression A0) } +: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing } + +VARIABLES :: { [ Expression A0 ] } +: VARIABLES ',' VARIABLE { $3 : $1 } +| VARIABLE { [ $1 ] } + +IMP_LISTS :: { [ ImpList A0 ] } +: IMP_LISTS ',' IMP_LIST { $3 : $1 } +| IMP_LIST { [ $1 ] } + +IMP_LIST :: { ImpList A0 } +: TYPE_SPEC '(2' IMP_ELEMENTS ')' + { ImpList () (getTransSpan $1 $4) $1 (aReverse $3) } + +IMP_ELEMENTS :: { AList ImpElement A0 } +: IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } +| IMP_ELEMENT { AList () (getSpan $1) [ $1 ] } + +IMP_ELEMENT :: { ImpElement A0 } +: id {% do + let (TId s id) = $1 + if length id /= 1 + then fail "Implicit argument must be a character." + else return $ ImpCharacter () s id + } +| id '-' id {% do + let (TId _ id1) = $1 + let (TId _ id2) = $3 + if length id1 /= 1 || length id2 /= 1 + then fail "Implicit argument must be a character." + else return $ ImpRange () (getTransSpan $1 $3) id1 id2 + } + +PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] } +: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 } +| PARAMETER_ASSIGNMENT { [ $1 ] } + +PARAMETER_ASSIGNMENT :: { Declarator A0 } +: VARIABLE '=' EXPRESSION + { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) } + +DECLARATION_STATEMENT :: { Statement A0 } +: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST + { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2; + declAList = fromReverseList $4 } + in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList } +| TYPE_SPEC DECLARATOR_LIST + { let { declAList = fromReverseList $2 } + in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } + +ATTRIBUTE_LIST :: { [ Attribute A0 ] } +: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 } +| {- EMPTY -} { [ ] } + +ATTRIBUTE_SPEC :: { Attribute A0 } +: public { AttrPublic () (getSpan $1) } +| private { AttrPrivate () (getSpan $1) } +| protected { AttrProtected () (getSpan $1) } +| allocatable { AttrAllocatable () (getSpan $1) } +| asynchronous { AttrAsynchronous () (getSpan $1) } +| dimension '(' DIMENSION_DECLARATORS ')' + { AttrDimension () (getTransSpan $1 $4) (aReverse $3) } +| external { AttrExternal () (getSpan $1) } +| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 } +| intrinsic { AttrIntrinsic () (getSpan $1) } +| optional { AttrOptional () (getSpan $1) } +| pointer { AttrPointer () (getSpan $1) } +| parameter { AttrParameter () (getSpan $1) } +| save { AttrSave () (getSpan $1) } +| target { AttrTarget () (getSpan $1) } +| value { AttrValue () (getSpan $1) } +| volatile { AttrVolatile () (getSpan $1) } +| SUFFIX { AttrSuffix () (getSpan $1) $1 } + +INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut } + +DATA_GROUPS :: { [ DataGroup A0 ] } +: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash + { let { nameAList = fromReverseList $3; + dataAList = fromReverseList $5 } + in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 } +| DATA_LIST slash EXPRESSION_LIST slash + { let { nameAList = fromReverseList $1; + dataAList = fromReverseList $3 } + in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] } + +MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () } + +DATA_LIST :: { [ Expression A0 ] } +: DATA_LIST ',' DATA_ELEMENT { $3 : $1 } +| DATA_ELEMENT { [ $1 ] } + +DATA_ELEMENT :: { Expression A0 } +: DATA_REF { $1 } | IMPLIED_DO { $1 } + +SAVE_ARGS :: { [ Expression A0 ] } +: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] } + +SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 } + +COMMON_NAME :: { Expression A0 } +: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 } + +DECLARATOR_LIST :: { [ Declarator A0 ] } +: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 } +| INITIALISED_DECLARATOR { [ $1 ] } + +INITIALISED_DECLARATOR :: { Declarator A0 } +: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 } +| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 } +| DECLARATOR { $1 } + +DECLARATOR :: { Declarator A0 } +: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing } +| VARIABLE '*' EXPRESSION + { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing } +| VARIABLE '*' '(' '*' ')' + { let star = ExpValue () (getSpan $4) ValStar + in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' + { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION + { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')' + { let star = ExpValue () (getSpan $7) ValStar + in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing } + +DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } +: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR + { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } +| DIMENSION_DECLARATOR + { AList () (getSpan $1) [ $1 ] } + +DIMENSION_DECLARATOR :: { DimensionDeclarator A0 } +: EXPRESSION ':' EXPRESSION + { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) } +| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) } +-- Lower bound only +| EXPRESSION ':' + { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing } +| EXPRESSION ':' '*' + { let { span = getSpan $3; + star = ExpValue () span ValStar } + in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) } +| '*' + { let { span = getSpan $1; + star = ExpValue () span ValStar } + in DimensionDeclarator () span Nothing (Just star) } +| ':' + { let span = getSpan $1 + in DimensionDeclarator () span Nothing Nothing } + +MAYBE_TYPE_SPEC :: { Maybe (TypeSpec A0) } +: TYPE_SPEC '::' { Just $1 } +| {- empty -} { Nothing } + +TYPE_SPEC :: { TypeSpec A0 } +: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 } +| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 } +| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } +| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } +| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } +| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } +| type '(' id ')' + { let TId _ id = $3 + in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing } +-- R502 +| class '(' '*' ')' { TypeSpec () (getSpan ($1, $4)) ClassStar Nothing } +-- FIXME: this (and TypeCustom) can accept parameterised types. See type-param-value. +-- Needs refactoring as this is used in various parts of the spec to consolidate +-- uses of ':', '*' and scalar-int-exp. +| class '(' id ')' + { let TId _ id = $3 + in TypeSpec () (getSpan ($1, $4)) (ClassCustom id) Nothing } + +KIND_SELECTOR :: { Maybe (Selector A0) } +: '(' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) } +| '(' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } +| '*' EXPRESSION -- non-standard but commonly used extension + { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) } +| {- EMPTY -} { Nothing } + +CHAR_SELECTOR :: { Maybe (Selector A0) } +: '*' EXPRESSION + { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing } +-- The following rule is a bug in the spec. +-- | '*' EXPRESSION ',' +-- { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing } +| '*' '(' '*' ')' + { let star = ExpValue () (getSpan $3) ValStar + in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing } +| '(' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing } +| '(' len '=' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing } +| '(' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } +| '(' LEN_EXPRESSION ',' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) } +| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) } +| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) } +| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) } +| {- EMPTY -} { Nothing } + +{- R402 -} +LEN_EXPRESSION :: { Expression A0 } +: EXPRESSION { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } +| ':' { ExpValue () (getSpan $1) ValColon } + +EXPRESSION :: { Expression A0 } +: EXPRESSION '+' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } +| EXPRESSION '-' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } +| EXPRESSION '*' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +| EXPRESSION '/' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Division $1 $3 } +| EXPRESSION '**' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 } +| EXPRESSION '/' '/' EXPRESSION %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| ARITHMETIC_SIGN EXPRESSION %prec SIGN + { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } +| EXPRESSION or EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| EXPRESSION and EXPRESSION + { ExpBinary () (getTransSpan $1 $3) And $1 $3 } +| not EXPRESSION + { ExpUnary () (getTransSpan $1 $2) Not $2 } +| EXPRESSION eqv EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } +| EXPRESSION neqv EXPRESSION + { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 } +| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL + { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } +| opCustom EXPRESSION %prec DEFINED_UNARY + { let TOpCustom span str = $1 + in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 } +| EXPRESSION opCustom EXPRESSION + { let TOpCustom _ str = $2 + in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 } +| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } +| NUMERIC_LITERAL { $1 } +| '(' EXPRESSION ',' EXPRESSION ')' + { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) } +| LOGICAL_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } +| IMPLIED_DO { $1 } +| '(/' EXPRESSION_LIST '/)' + { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) } +| operator '(' opCustom ')' + { let TOpCustom _ op = $3 + in ExpValue () (getTransSpan $1 $4) (ValOperator op) } +| assignment { ExpValue () (getSpan $1) ValAssignment } +| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 } + +DATA_REFS :: { [ Expression A0 ] } +: DATA_REFS ',' DATA_REF { $3 : $1 } +| DATA_REF { [ $1 ] } + +DATA_REF :: { Expression A0 } +: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 } +| PART_REF { $1 } + +PART_REFS :: { [ Expression A0 ] } +: PART_REFS ',' PART_REF { $3 : $1 } +| PART_REF { [ $1 ] } + +PART_REF :: { Expression A0 } +: VARIABLE { $1 } +| VARIABLE '(' ')' + { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing } +| VARIABLE '(' INDICIES ')' + { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } +| VARIABLE '(' INDICIES ')' '(' INDICIES ')' + { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) + in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) } + +INDICIES :: { [ Index A0 ] } +: INDICIES ',' INDEX { $3 : $1 } +| INDEX { [ $1 ] } + +INDEX :: { Index A0 } +: RANGE { $1 } +| RANGE ':' EXPRESSION + { let IxRange () s lower upper _ = $1 + in IxRange () (getTransSpan s $3) lower upper (Just $3) } +| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 } +-- Following is only as an intermediate stage before having been turned into +-- an argument by later transformation. +| id '=' EXPRESSION + { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 } + +RANGE :: { Index A0 } +: ':' { IxRange () (getSpan $1) Nothing Nothing Nothing } +| ':' EXPRESSION { IxRange () (getTransSpan $1 $2) Nothing (Just $2) Nothing } +| EXPRESSION ':' { IxRange () (getTransSpan $1 $2) (Just $1) Nothing Nothing } +| EXPRESSION ':' EXPRESSION + { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing } + +DO_SPECIFICATION :: { DoSpecification A0 } +: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) } +| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing } + +IMPLIED_DO :: { Expression A0 } +: '(' EXPRESSION ',' DO_SPECIFICATION ')' + { let expList = AList () (getSpan $2) [ $2 ] + in ExpImpliedDo () (getTransSpan $1 $5) expList $4 } +| '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')' + { let expList = AList () (getTransSpan $2 $4) [ $2, $4 ] + in ExpImpliedDo () (getTransSpan $1 $5) expList $6 } +| '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')' + { let { exps = reverse $6; + expList = AList () (getTransSpan $2 exps) ($2 : $4 : reverse $6) } + in ExpImpliedDo () (getTransSpan $1 $9) expList $8 } + +FORALL :: { Statement A0 } +: id ':' forall FORALL_HEADER { + let (TId s1 id) = $1 in + let (h,s2) = $4 in + StForall () (getTransSpan s1 s2) (Just id) h +} +| forall FORALL_HEADER { + let (h,s) = $2 in + StForall () (getTransSpan $1 s) Nothing h +} +| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT { + let (h,_) = $2 in + StForallStatement () (getTransSpan $1 $3) h $3 +} + +FORALL_HEADER + :: { (ForallHeader A0, SrcSpan) } +FORALL_HEADER : + -- Standard simple forall header + '(' FORALL_TRIPLET_SPEC ')' { (ForallHeader [$2] Nothing, getTransSpan $1 $3) } + -- forall header with scale expression + | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')' + { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) } + -- multi forall header + | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')' + { (ForallHeader $2 Nothing, getTransSpan $1 $3) } + -- multi forall header with scale + | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')' + { (ForallHeader $2 (Just $4), getTransSpan $1 $5) } + +FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE + :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] } +FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE +: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 } +| {- empty -} { [] } + +FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) } +FORALL_TRIPLET_SPEC +: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) } +| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) } + +FORALL_ASSIGNMENT_STMT :: { Statement A0 } +FORALL_ASSIGNMENT_STMT : + EXPRESSION_ASSIGNMENT_STATEMENT { $1 } + | POINTER_ASSIGNMENT_STMT { $1 } + +POINTER_ASSIGNMENT_STMT :: { Statement A0 } +POINTER_ASSIGNMENT_STMT : + DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 } + +END_FORALL :: { Statement A0 } +END_FORALL : + endforall { StEndForall () (getSpan $1) Nothing } + | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)} + +EXPRESSION_LIST :: { [ Expression A0 ] } +: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 } +| EXPRESSION { [ $1 ] } + +ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) } +: '-' { (getSpan $1, Minus) } +| '+' { (getSpan $1, Plus) } + +RELATIONAL_OPERATOR :: { BinaryOp } +: '==' { EQ } +| '!=' { NE } +| '>' { GT } +| '>=' { GTE } +| '<' { LT } +| '<=' { LTE } + +VARIABLE :: { Expression A0 } +: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s } + +NUMERIC_LITERAL :: { Expression A0 } +: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 } + +INTEGERS :: { [ Expression A0 ] } +: INTEGERS ',' INTEGER_LITERAL { $3 : $1 } +| INTEGER_LITERAL { [ $1 ] } + +INTEGER_LITERAL :: { Expression A0 } +: int { let TIntegerLiteral s i = $1 in ExpValue () s $ ValInteger i } +| boz { let TBozLiteral s i = $1 in ExpValue () s $ ValInteger i } + +REAL_LITERAL :: { Expression A0 } +: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r } + +LOGICAL_LITERAL :: { Expression A0 } +: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b } + +STRING :: { Expression A0 } +: string { let TString s c = $1 in ExpValue () s $ ValString c } + +cDATA :: { () } : {% pushContext ConData } +cIMPLICIT :: { () } : {% pushContext ConImplicit } +cNAMELIST :: { () } : {% pushContext ConNamelist } +cCOMMON :: { () } : {% pushContext ConCommon } +cPOP :: { () } : {% popContext } + +{ + +unitNameCheck :: Token -> String -> Parse AlexInput Token () +unitNameCheck (TId _ name1) name2 + | name1 == name2 = return () + | otherwise = fail "Unit name does not match the corresponding END statement." +unitNameCheck _ _ = return () + +parse = runParse programParser + +transformations2003 = + [ GroupLabeledDo + , GroupDo + , GroupIf + , GroupCase + , DisambiguateIntrinsic + , DisambiguateFunction + ] + +fortran2003Parser :: + B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +fortran2003Parser sourceCode filename = + (pfSetFilename filename . transform transformations2003) <$> parse parseState + where + parseState = initParseState sourceCode Fortran2003 filename + +fortran2003ParserWithModFiles :: + ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +fortran2003ParserWithModFiles mods sourceCode filename = + fmap (pfSetFilename filename . transform) $ parse parseState + where + transform = transformWithModFiles mods transformations2003 + parseState = initParseState sourceCode Fortran2003 filename + +parseError :: Token -> LexAction a +parseError token = do + parseState <- get +#ifdef DEBUG + tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex +#endif + fail $ psFilename parseState ++ ": parsing failed. " + ++ specifics token +#ifdef DEBUG + ++ '\n' : show tokens +#endif + where specifics (TPause _) = "\nPAUSE statements are not supported in Fortran 2003 or later. " + specifics (TAssign _) = "\nASSIGN statements are not supported in Fortran 2003 or later. " + specifics _ = "" + +} diff --git a/src/Language/Fortran/Parser/Fortran66.y b/src/Language/Fortran/Parser/Fortran66.y --- a/src/Language/Fortran/Parser/Fortran66.y +++ b/src/Language/Fortran/Parser/Fortran66.y @@ -128,11 +128,11 @@ OTHER_PROGRAM_UNIT :: { ProgramUnit A0 } OTHER_PROGRAM_UNIT : TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE - { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing } + { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing } | function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE - { PUFunction () (getTransSpan $1 $6) Nothing (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing } + { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing } | subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE - { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing } + { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing } | blockData NEWLINE BLOCKS end MAYBE_NEWLINE { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y --- a/src/Language/Fortran/Parser/Fortran77.y +++ b/src/Language/Fortran/Parser/Fortran77.y @@ -207,11 +207,11 @@ : program NAME NEWLINE BLOCKS ENDPROG { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing } | TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN - { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing } + { 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 (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing } + { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing } | subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB - { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing } + { 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) } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } @@ -1003,7 +1003,7 @@ | complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } | doubleComplex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeDoubleComplex $2 } -| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } | byte KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 } | record '/' NAME '/' { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing } @@ -1121,10 +1121,10 @@ doParse = case parse parseState of ParseFailed e -> return (ParseFailed e) ParseOk p x -> do - p' <- descendBiM (inlineInclude Fortran77Legacy incs) p + p' <- descendBiM (inlineInclude Fortran77Legacy incs []) p return (ParseOk p' x) transform = transformWithModFiles emptyModFiles transformations77Legacy - parseState = initParseState sourceCode Fortran77Legacy filename + parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename includeParser :: FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0] @@ -1134,15 +1134,17 @@ -- ensure the file ends with a newline.. parseState = initParseState (sourceCode `B.snoc` '\n') version filename -inlineInclude :: FortranVersion -> [String] -> Statement A0 -> IO (Statement A0) -inlineInclude fv dirs st = case st of +inlineInclude :: FortranVersion -> [String] -> [String] -> Statement A0 -> IO (Statement A0) +inlineInclude fv dirs seen st = case st of StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do - inc <- truncateLines <$> readInDirs dirs path - case includeParser fv inc path of - ParseOk blocks _ -> do - blocks' <- descendBiM (inlineInclude fv dirs) blocks - return $ StInclude a s e (Just blocks') - ParseFailed e -> throwIO e + if notElem path seen then do + inc <- truncateLines <$> readInDirs dirs path + case includeParser fv inc path of + ParseOk blocks _ -> do + blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks + return $ StInclude a s e (Just blocks') + ParseFailed e -> throwIO e + else return st _ -> return st readInDirs :: [String] -> String -> IO B.ByteString diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y --- a/src/Language/Fortran/Parser/Fortran90.y +++ b/src/Language/Fortran/Parser/Fortran90.y @@ -9,6 +9,7 @@ import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST import Control.Monad.State (get) import Data.Maybe (fromMaybe) +import Data.Either (partitionEithers) import qualified Data.ByteString.Char8 as B import Control.Monad.State @@ -119,6 +120,7 @@ equivalence { TEquivalence _ } common { TCommon _ } allocate { TAllocate _ } + stat { TStat _ } deallocate { TDeallocate _ } nullify { TNullify _ } none { TNone _ } @@ -237,37 +239,45 @@ | {- EMPTY -} { [ ] } SUBPROGRAM_UNIT :: { ProgramUnit A0 } -: TYPE_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END - {% do { unitNameCheck $10 $3; - return $ PUFunction () (getTransSpan $1 $10) (Just $1) (None () initSrcSpan False) $3 $4 $6 (reverse $8) $9 } } -| TYPE_SPEC recursive function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END - {% do { unitNameCheck $11 $4; - return $ PUFunction () (getTransSpan $1 $11) (Just $1) (None () (getSpan $2) True) $4 $5 $7 (reverse $9) $10 } } -| recursive TYPE_SPEC function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END - {% do { unitNameCheck $11 $4; - return $ PUFunction () (getTransSpan $1 $11) (Just $2) (None () (getSpan $1) True) $4 $5 $6 (reverse $9) $10 } } -| function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END - {% do { unitNameCheck $9 $2; - return $ PUFunction () (getTransSpan $1 $9) Nothing (None () initSrcSpan False) $2 $3 $4 (reverse $7) $8 } } -| recursive function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END +: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $10 $3; - return $ PUFunction () (getTransSpan $1 $10) Nothing (None () initSrcSpan True) $3 $4 $5 (reverse $8) $9 } } -| subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END - {% do { unitNameCheck $8 $2; - return $ PUSubroutine () (getTransSpan $1 $8) (None () initSrcSpan False) $2 $3 (reverse $6) $7 } } -| recursive subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END + let (pfxs, typeSpec) = case partitionEithers $1 of + { (ps, t:_) -> (fromReverseList' ps, Just t) + ; (ps, []) -> (fromReverseList' ps, Nothing) } in + let sfx = emptySuffixes in + let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in + return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9 } } +| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END {% do { unitNameCheck $9 $3; - return $ PUSubroutine () (getTransSpan $1 $9) (None () initSrcSpan True) $3 $4 (reverse $7) $8 } } + (pfxs, typeSpec) <- case partitionEithers $1 of + { (ps, t:_) -> fail "Subroutines cannot have return types." + ; (ps, []) -> return (fromReverseList' ps, Nothing) }; + let sfx = emptySuffixes in + let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in + return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8 } } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } +-- (Fortran2003) R1227, Fortran95/90 (...) +PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] } +: PREFIXES PREFIX { $2:$1 } +| {- EMPTY -} { [] } + +-- (Fortran2003) R1228, Fortran95/90 (...) +PREFIX :: { Either (Prefix A0) (TypeSpec A0) } +: recursive { Left $ PfxRecursive () (getSpan $1) } +| TYPE_SPEC { Right $1 } + +RESULT :: { Expression A0 } +: result '(' VARIABLE ')' { $3 } + +MAYBE_RESULT :: { Maybe (Expression A0) } +: RESULT { Just $1 } +| {- empty -} { Nothing } + MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } : '(' MAYBE_VARIABLES ')' { $2 } | {- Nothing -} { Nothing } -RESULT :: { Maybe (Expression a) } -: result '(' VARIABLE ')' { Just $3 } -| {- EMPTY -} { Nothing } - PROGRAM_END :: { Token } : end { $1 } | endProgram { $1 } | endProgram id { $2 } MODULE_END :: { Token } @@ -278,6 +288,8 @@ : end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 } BLOCK_DATA_END :: { Token } : end { $1 } | endBlockData { $1 } | endBlockData id { $2 } +INTERFACE_END :: { Token } +: end { $1 } | endInterface { $1 } | endInterface id { $2 } NAME :: { Name } : id { let (TId _ name) = $1 in name } @@ -287,10 +299,10 @@ : INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } -| interface MAYBE_EXPRESSION NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE - { BlInterface () (getTransSpan $1 $7) $2 $4 $5 } -| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE - { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 } +| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) } +| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) } | COMMENT_BLOCK { $1 } MAYBE_EXPRESSION :: { Maybe (Expression A0) } @@ -306,13 +318,14 @@ MODULE_PROCEDURES :: { [ Block A0 ] } : MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 } +| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 } | { [ ] } MODULE_PROCEDURE :: { Block A0 } -: moduleProcedure VARIABLES NEWLINE +: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE { let { al = fromReverseList $2; st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) } - in BlStatement () (getTransSpan $1 $3) Nothing st } + in BlStatement () (getTransSpan $1 $4) Nothing st } COMMENT_BLOCK :: { Block A0 } : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } @@ -383,24 +396,23 @@ | common cCOMMON COMMON_GROUPS cPOP { let commonAList = fromReverseList $3 in StCommon () (getTransSpan $1 commonAList) commonAList } -| external VARIABLES - { let alist = fromReverseList $2 +| external MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 in StExternal () (getTransSpan $1 alist) alist } -| intrinsic VARIABLES - { let alist = fromReverseList $2 +| intrinsic MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 in StIntrinsic () (getTransSpan $1 alist) alist } -| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing } +| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing } | use VARIABLE ',' RENAME_LIST { let alist = fromReverseList $4 - in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) } -| use VARIABLE ',' only ':' RENAME_LIST - { let alist = fromReverseList $6 - in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) } -| entry VARIABLE RESULT + in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) } +| use VARIABLE ',' only ':' MAYBE_RENAME_LIST + { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 } +| entry VARIABLE MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 } -| entry VARIABLE '(' ')' RESULT +| entry VARIABLE '(' ')' MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 } -| entry VARIABLE '(' VARIABLES ')' RESULT +| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 } | sequence { StSequence () (getSpan $1) } | type ATTRIBUTE_LIST '::' id @@ -419,23 +431,20 @@ { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } EXECUTABLE_STATEMENT :: { Statement A0 } -: allocate '(' DATA_REFS ')' - { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } -| allocate '(' DATA_REFS ',' CILIST_PAIR ')' - { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 } | nullify '(' DATA_REFS ')' { StNullify () (getTransSpan $1 $4) (fromReverseList $3) } -| deallocate '(' DATA_REFS ')' - { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } -| deallocate '(' DATA_REFS ',' CILIST_PAIR ')' - { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 } | EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 } | where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT { StWhere () (getTransSpan $1 $5) $3 $5 } -| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) $3 } -| elsewhere { StElsewhere () (getSpan $1) } -| endwhere { StEndWhere () (getSpan $1) } +| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 } +| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) } +| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing } +| endwhere { StEndWhere () (getSpan $1) Nothing } | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } | if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 } @@ -550,6 +559,10 @@ | EXPRESSION { Argument () (getSpan $1) Nothing $1 } +MAYBE_RENAME_LIST :: { Maybe (AList Use A0) } +: RENAME_LIST { Just $ fromReverseList $1 } +| {- empty -} { Nothing } + RENAME_LIST :: { [ Use A0 ] } : RENAME_LIST ',' RENAME { $3 : $1 } | RENAME { [ $1 ] } @@ -557,6 +570,10 @@ RENAME :: { Use A0 } : VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 } | VARIABLE { UseID () (getSpan $1) $1 } +| operator '(' opCustom ')' + { let TOpCustom ss op = $3 + in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) } +| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) } MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () } @@ -643,6 +660,10 @@ | STRING { $1 } | DATA_REF { $1 } +MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) } +: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) } +| {- empty -} { Nothing } + IN_IOLIST :: { [ Expression A0 ] } : IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1} | IN_IO_ELEMENT { [ $1 ] } @@ -755,7 +776,7 @@ | private { AttrPrivate () (getSpan $1) } | allocatable { AttrAllocatable () (getSpan $1) } | dimension '(' DIMENSION_DECLARATORS ')' - { AttrDimension () (getTransSpan $1 $4) $3 } + { AttrDimension () (getTransSpan $1 $4) (aReverse $3) } | external { AttrExternal () (getSpan $1) } | intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 } | intrinsic { AttrIntrinsic () (getSpan $1) } @@ -811,12 +832,12 @@ { let star = ExpValue () (getSpan $4) ValStar in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' - { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing } + { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION - { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing } + { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')' { let star = ExpValue () (getSpan $7) ValStar - in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing } + in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing } DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR @@ -848,7 +869,7 @@ | real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 } | doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } | complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } -| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } | logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } | type '(' id ')' { let TId _ id = $3 @@ -859,6 +880,8 @@ { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) } | '(' kind '=' EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } +| '*' EXPRESSION -- non-standard but commonly used extension + { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) } | {- EMPTY -} { Nothing } CHAR_SELECTOR :: { Maybe (Selector A0) } @@ -874,6 +897,8 @@ { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing } | '(' len '=' LEN_EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing } +| '(' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } | '(' LEN_EXPRESSION ',' EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) } | '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y --- a/src/Language/Fortran/Parser/Fortran95.y +++ b/src/Language/Fortran/Parser/Fortran95.y @@ -10,7 +10,7 @@ import Control.Monad.State import Data.Maybe (fromMaybe, isJust) import Data.List (nub) -import Data.Either (either, lefts, rights) +import Data.Either (either, lefts, rights, partitionEithers) import Control.Applicative import qualified Data.ByteString.Char8 as B @@ -31,7 +31,7 @@ %name programParser PROGRAM %name statementParser STATEMENT -%name functionParser SUBPROGRAM_UNIT +%name functionParser SUBPROGRAM_UNIT %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -114,6 +114,8 @@ pointer { TPointer _ } save { TSave _ } target { TTarget _ } + value { TValue _ } + volatile { TVolatile _ } in { TIn _ } out { TOut _ } inout { TInOut _ } @@ -123,6 +125,7 @@ equivalence { TEquivalence _ } common { TCommon _ } allocate { TAllocate _ } + stat { TStat _ } deallocate { TDeallocate _ } nullify { TNullify _ } none { TNone _ } @@ -240,68 +243,51 @@ | {- EMPTY -} { [ ] } SUBPROGRAM_UNIT :: { ProgramUnit A0 } -: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END +: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $10 $3; - let (fSpec, typeSpec) = $1 in - return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9 } } -| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END + let (pfxs, typeSpec) = case partitionEithers $1 of + { (ps, t:_) -> (fromReverseList' ps, Just t) + ; (ps, []) -> (fromReverseList' ps, Nothing) } in + let sfx = emptySuffixes in + let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in + if validPrefixSuffix (pfxs, sfx) then + return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9 + else fail "Cannot specify elemental along with recursive." } } +| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END {% do { unitNameCheck $9 $3; - let (fSpec, _) = $1 in - return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8 } } + (pfxs, typeSpec) <- case partitionEithers $1 of + { (ps, t:_) -> fail "Subroutines cannot have return types." + ; (ps, []) -> return (fromReverseList' ps, Nothing) }; + let sfx = emptySuffixes in + let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in + if validPrefixSuffix (pfxs, sfx) then + return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8 + else fail "Cannot specify elemental along with recursive." } } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } -| recursive RECURSIVE_SUBPROGRAM_UNIT { setSpan (getTransSpan $1 $2) $2 } -RECURSIVE_SUBPROGRAM_UNIT :: { ProgramUnit A0 } -: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END - {% do - unitNameCheck $10 $3 - fSpec <- either fail return $ fst $1 `buildPUFunctionOpt` None () (getSpan $ fst $1) True - let typeSpec = snd $1 - return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9 - } -| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END - {% do - unitNameCheck $9 $3 - fSpec <- either fail return $ fst $1 `buildPUFunctionOpt` None () (getSpan $ fst $1) True - return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8 - } - - -FUNCTION_SPEC :: { (PUFunctionOpt A0, Maybe (TypeSpec A0)) } -: PFUNCTION_SPECS {% do - let funcSpecs = lefts $1 - let typeSpecs = rights $1 - if length typeSpecs > 1 - then fail "Specified a type spec multiple times in a function spec." - else if length (nub funcSpecs) /= length funcSpecs then fail "Specified a function spec multiple times." - else do - let typeSpec = case typeSpecs of - [] -> Nothing - (x:_) -> Just x - funcSpec <- either fail return $ buildPUFunctionOpts funcSpecs - return (funcSpec, typeSpec) - } +-- (Fortran2003) R1227, Fortran95 (...) +PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] } +: PREFIXES PREFIX { $2:$1 } +| {- EMPTY -} { [] } -PFUNCTION_SPECS :: { [Either (PUFunctionOpt A0) (TypeSpec A0)] } -: {- EMPTY -} { [] } -| PFUNCTION_SPEC PFUNCTION_SPECS { $1 : $2 } +-- (Fortran2003) R1228, Fortran95 (...) +PREFIX :: { Either (Prefix A0) (TypeSpec A0) } +: recursive { Left $ PfxRecursive () (getSpan $1) } +| elemental { Left $ PfxElemental () (getSpan $1) } +| pure { Left $ PfxPure () (getSpan $1) } +| TYPE_SPEC { Right $1 } --- crucically, recursive cannot appear first, which is dealt with in SUBPROGRAM_UNIT -| PFUNCTION_SPEC recursive PFUNCTION_SPECS { $1 : Left (None () (getSpan $2) True) : $3 } +RESULT :: { Expression A0 } +: result '(' VARIABLE ')' { $3 } -PFUNCTION_SPEC :: { Either (PUFunctionOpt A0) (TypeSpec A0) } -: pure { Left $ Pure () (getSpan $1) False } -| elemental { Left $ Elemental () (getSpan $1) } -| TYPE_SPEC { Right $ $1 } +MAYBE_RESULT :: { Maybe (Expression A0) } +: RESULT { Just $1 } +| {- empty -} { Nothing} MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } : '(' MAYBE_VARIABLES ')' { $2 } | {- Nothing -} { Nothing } -RESULT :: { Maybe (Expression a) } -: result '(' VARIABLE ')' { Just $3 } -| {- EMPTY -} { Nothing } - PROGRAM_END :: { Token } : end { $1 } | endProgram { $1 } | endProgram id { $2 } MODULE_END :: { Token } @@ -312,6 +298,8 @@ : end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 } BLOCK_DATA_END :: { Token } : end { $1 } | endBlockData { $1 } | endBlockData id { $2 } +INTERFACE_END :: { Token } +: end { $1 } | endInterface { $1 } | endInterface id { $2 } NAME :: { Name } : id { let (TId _ name) = $1 in name } @@ -321,10 +309,10 @@ : INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } -| interface MAYBE_EXPRESSION NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE - { BlInterface () (getTransSpan $1 $7) $2 $4 $5 } -| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE - { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 } +| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) } +| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE + { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) } | COMMENT_BLOCK { $1 } MAYBE_EXPRESSION :: { Maybe (Expression A0) } @@ -340,13 +328,14 @@ MODULE_PROCEDURES :: { [ Block A0 ] } : MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 } +| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 } | { [ ] } MODULE_PROCEDURE :: { Block A0 } -: moduleProcedure VARIABLES NEWLINE +: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE { let { al = fromReverseList $2; st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) } - in BlStatement () (getTransSpan $1 $3) Nothing st } + in BlStatement () (getTransSpan $1 $4) Nothing st } COMMENT_BLOCK :: { Block A0 } : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } @@ -398,6 +387,12 @@ | target MAYBE_DCOLON DECLARATOR_LIST { let declAList = fromReverseList $3 in StTarget () (getTransSpan $1 declAList) declAList } +| value MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StValue () (getTransSpan $1 declAList) declAList } +| volatile MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StVolatile () (getTransSpan $1 declAList) declAList } | data cDATA DATA_GROUPS cPOP { let dataAList = fromReverseList $3 in StData () (getTransSpan $1 dataAList) dataAList } @@ -417,24 +412,23 @@ | common cCOMMON COMMON_GROUPS cPOP { let commonAList = fromReverseList $3 in StCommon () (getTransSpan $1 commonAList) commonAList } -| external VARIABLES - { let alist = fromReverseList $2 +| external MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 in StExternal () (getTransSpan $1 alist) alist } -| intrinsic VARIABLES - { let alist = fromReverseList $2 +| intrinsic MAYBE_DCOLON VARIABLES + { let alist = fromReverseList $3 in StIntrinsic () (getTransSpan $1 alist) alist } -| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing } +| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing } | use VARIABLE ',' RENAME_LIST { let alist = fromReverseList $4 - in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) } -| use VARIABLE ',' only ':' RENAME_LIST - { let alist = fromReverseList $6 - in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) } -| entry VARIABLE RESULT + in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) } +| use VARIABLE ',' only ':' MAYBE_RENAME_LIST + { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 } +| entry VARIABLE MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 } -| entry VARIABLE '(' ')' RESULT +| entry VARIABLE '(' ')' MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 } -| entry VARIABLE '(' VARIABLES ')' RESULT +| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 } | sequence { StSequence () (getSpan $1) } | type ATTRIBUTE_LIST '::' id @@ -453,23 +447,20 @@ { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } EXECUTABLE_STATEMENT :: { Statement A0 } -: allocate '(' DATA_REFS ')' - { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } -| allocate '(' DATA_REFS ',' CILIST_PAIR ')' - { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 } | nullify '(' DATA_REFS ')' { StNullify () (getTransSpan $1 $4) (fromReverseList $3) } -| deallocate '(' DATA_REFS ')' - { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } -| deallocate '(' DATA_REFS ',' CILIST_PAIR ')' - { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' + { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 } | EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | POINTER_ASSIGNMENT_STMT { $1 } | where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT { StWhere () (getTransSpan $1 $5) $3 $5 } -| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) $3 } -| elsewhere { StElsewhere () (getSpan $1) } -| endwhere { StEndWhere () (getSpan $1) } +| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 } +| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) } +| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing } +| endwhere { StEndWhere () (getSpan $1) Nothing } | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } | if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 } @@ -577,6 +568,10 @@ | EXPRESSION { Argument () (getSpan $1) Nothing $1 } +MAYBE_RENAME_LIST :: { Maybe (AList Use A0) } +: RENAME_LIST { Just $ fromReverseList $1 } +| {- empty -} { Nothing } + RENAME_LIST :: { [ Use A0 ] } : RENAME_LIST ',' RENAME { $3 : $1 } | RENAME { [ $1 ] } @@ -584,6 +579,10 @@ RENAME :: { Use A0 } : VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 } | VARIABLE { UseID () (getSpan $1) $1 } +| operator '(' opCustom ')' + { let TOpCustom ss op = $3 + in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) } +| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) } MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () } @@ -670,6 +669,11 @@ | STRING { $1 } | DATA_REF { $1 } +{- p67 ALLOCATE statement -} +MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) } +: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) } +| {- empty -} { Nothing } + IN_IOLIST :: { [ Expression A0 ] } : IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1} | IN_IO_ELEMENT { [ $1 ] } @@ -782,7 +786,7 @@ | private { AttrPrivate () (getSpan $1) } | allocatable { AttrAllocatable () (getSpan $1) } | dimension '(' DIMENSION_DECLARATORS ')' - { AttrDimension () (getTransSpan $1 $4) $3 } + { AttrDimension () (getTransSpan $1 $4) (aReverse $3) } | external { AttrExternal () (getSpan $1) } | intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 } | intrinsic { AttrIntrinsic () (getSpan $1) } @@ -791,6 +795,8 @@ | parameter { AttrParameter () (getSpan $1) } | save { AttrSave () (getSpan $1) } | target { AttrTarget () (getSpan $1) } +| value { AttrValue () (getSpan $1) } +| volatile { AttrVolatile () (getSpan $1) } INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut } @@ -838,12 +844,12 @@ { let star = ExpValue () (getSpan $4) ValStar in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' - { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing } + { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION - { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing } + { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')' { let star = ExpValue () (getSpan $7) ValStar - in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing } + in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing } DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR @@ -875,7 +881,7 @@ | real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 } | doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } | complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } -| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } | logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } | type '(' id ')' { let TId _ id = $3 @@ -886,6 +892,8 @@ { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) } | '(' kind '=' EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } +| '*' EXPRESSION -- non-standard but commonly used extension + { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) } | {- EMPTY -} { Nothing } CHAR_SELECTOR :: { Maybe (Selector A0) } @@ -901,6 +909,8 @@ { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing } | '(' len '=' LEN_EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing } +| '(' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } | '(' LEN_EXPRESSION ',' EXPRESSION ')' { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) } | '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' diff --git a/src/Language/Fortran/Parser/Utils.hs b/src/Language/Fortran/Parser/Utils.hs --- a/src/Language/Fortran/Parser/Utils.hs +++ b/src/Language/Fortran/Parser/Utils.hs @@ -3,6 +3,13 @@ import Data.Char import Numeric +breakAtDot :: String -> (String, String) +replaceDwithE :: Char -> Char +readsToMaybe :: [(a, b)] -> Maybe a +fixAtDot :: (String, String) -> (String, String) +fixAtDot' :: (String, String) -> (String, String) +combineAtDot :: (String, String) -> String + -- | Convert a Fortran literal Real into a Haskell Double. readReal :: String -> Maybe Double readReal = readsToMaybe . reads . filter (/= '+') . combineAtDot . fixAtDot . breakAtDot . map replaceDwithE . takeWhile (/= '_') diff --git a/src/Language/Fortran/ParserMonad.hs b/src/Language/Fortran/ParserMonad.hs --- a/src/Language/Fortran/ParserMonad.hs +++ b/src/Language/Fortran/ParserMonad.hs @@ -11,13 +11,15 @@ import GHC.IO.Exception import Control.Exception -import Control.Monad.State +import Control.Monad.State hiding (state) import Control.Monad.Except import Data.Typeable import Data.Data import GHC.Generics (Generic) import Language.Fortran.Util.Position +import Data.Char (toLower) +import Data.List (isInfixOf, find) ------------------------------------------------------------------------------- -- Helper datatype definitions @@ -43,6 +45,19 @@ show Fortran2003 = "Fortran 2003" show Fortran2008 = "Fortran 2008" +fortranVersionAliases :: [(String, FortranVersion)] +fortranVersionAliases = [ ("66" , Fortran66) + , ("77e", Fortran77Extended) + , ("77l", Fortran77Legacy) + , ("77" , Fortran77) + , ("90" , Fortran90) + , ("95" , Fortran95) + , ("03" , Fortran2003) + , ("08" , Fortran2008) ] + +selectFortranVersion :: String -> Maybe FortranVersion +selectFortranVersion alias = snd <$> find (\ entry -> fst entry `isInfixOf` map toLower alias) fortranVersionAliases + data ParanthesesCount = ParanthesesCount { pcActual :: Integer , pcHasReached0 :: Bool } @@ -77,12 +92,13 @@ where lastTokenMsg = tokenMsg (errLastToken err) +tokenMsg :: Show a => Maybe a -> String tokenMsg (Just a) = "Last parsed token: " ++ show a ++ "." tokenMsg Nothing = "No token had been lexed." instance Functor (ParseResult b c) where fmap f (ParseOk a s) = ParseOk (f a) s - fmap f (ParseFailed err) = ParseFailed err + fmap _ (ParseFailed err) = ParseFailed err instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b) @@ -106,10 +122,10 @@ fromParseResult :: (Show c) => ParseResult b c a -> Either ParseErrorSimple a fromParseResult (ParseOk a _) = Right a fromParseResult (ParseFailed err) = - Left $ ParseErrorSimple + Left ParseErrorSimple { errorPos = errPos err , errorFilename = errFilename err - , errorMsg = errMsg err ++ "\n" ++ (tokenMsg $ errLastToken err) } + , errorMsg = errMsg err ++ "\n" ++ tokenMsg (errLastToken err) } instance Show ParseErrorSimple where show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err @@ -221,7 +237,8 @@ -- Generic token collection and functions ------------------------------------------------------------------------------- -throwIOerror s = throw $ +throwIOerror :: String -> a +throwIOerror s = throw IOError { ioe_handle = Nothing , ioe_type = UserError , ioe_location = "fortran-src" @@ -230,7 +247,7 @@ , ioe_filename = Nothing } runParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> ParseResult b c a -runParse lexer initState = unParse lexer initState +runParse = unParse runParseUnsafe :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> (a, ParseState b) runParseUnsafe lexer initState = 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 @@ -2,13 +2,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Language.Fortran.PrettyPrint where -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust, isNothing, listToMaybe) import Data.List (foldl') -import Prelude hiding (EQ,LT,GT,(<>)) +import Prelude hiding (EQ,LT,GT,pred,exp,(<>)) import Language.Fortran.AST import Language.Fortran.ParserMonad @@ -45,8 +46,10 @@ overlay top bottom = text $ top' ++ drop (length top') (render bottom) where top' = render top +fixedForm :: Maybe Int fixedForm = Just 6 +pprintAndRender :: IndentablePretty t => FortranVersion -> t -> Indentation -> String pprintAndRender v t i = render $ pprint v t i class IndentablePretty t where @@ -108,61 +111,83 @@ where nextI = incIndentation i - pprint v (PUSubroutine _ _ funcSpec name mArgs body mSubs) i - | Pure _ _ _ <- funcSpec, v < Fortran95 = tooOld v "Pure subroutine" Fortran90 - | Elemental _ _ <- funcSpec, v < Fortran90 = tooOld v "Elemental subroutine" Fortran90 - | functionIsRecursive funcSpec, v < Fortran90 = tooOld v "Recursive subroutine" Fortran90 - | isJust mSubs, v < Fortran90 = tooOld v "Subroutine subprogram" Fortran90 - | otherwise = + pprint v (PUSubroutine _ _ (mpfxs, msfxs) name mArgs body mSubs) i = indent curI - ((case funcSpec of - (Elemental _ _) -> "elemental" - (Pure _ _ _) -> "pure" - otherwise -> empty) <+> - (if functionIsRecursive funcSpec then "recursive" else empty) <+> - "subroutine" <+> text name <> - lparen pprint' v mArgs rparen <> newline) <> + (prefix <+> "subroutine" <+> text name <> + lparen pprint' v mArgs rparen <+> suffix <> newline) <> pprint v body nextI <> newline indent nextI ("contains" <> newline) newline - pprint v mSubs nextI <> + subs <> endGen v "subroutine" name curI - where - curI = if v >= Fortran90 then i else fixedForm - nextI = if v >= Fortran90 - then incIndentation i - else incIndentation fixedForm + where + convPfx (PfxElemental _ _) + | v >= Fortran95 = "elemental" + | otherwise = tooOld v "Elemental function" Fortran95 + convPfx (PfxPure _ _) + | v >= Fortran95 = "pure" + | otherwise = tooOld v "Pure function" Fortran95 + convPfx (PfxRecursive _ _) + | v >= Fortran90 = "recursive" + | otherwise = tooOld v "Recursive function" Fortran90 - pprint v (PUFunction _ _ mRetType fSpec name mArgs mRes body mSubs) i - | (Elemental _ _) <- fSpec, v < Fortran95 = tooOld v "Elemental function" Fortran90 - | (Pure _ _ _) <- fSpec, v < Fortran95 = tooOld v "Pure function" Fortran90 - | functionIsRecursive fSpec, v < Fortran90 = tooOld v "Recursive function" Fortran90 - | isJust mRes, v < Fortran90 = tooOld v "Function result" Fortran90 - | isJust mSubs, v < Fortran90 = tooOld v "Function subprogram" Fortran90 - | otherwise = + prefix = hsep (map convPfx pfxs) + + suffix = pprint' v (listToMaybe sfxs) + + subs + | isJust mSubs, v >= Fortran90 = pprint v mSubs nextI + | isNothing mSubs = empty + | otherwise = tooOld v "Function subprogram" Fortran90 + + curI = if v >= Fortran90 then i else fixedForm + nextI = if v >= Fortran90 then incIndentation i + else incIndentation fixedForm + pfxs = aStrip' mpfxs + sfxs = aStrip' msfxs + + pprint v (PUFunction _ _ mRetType (mpfxs, msfxs) name mArgs mRes body mSubs) i = indent curI - (pprint' v mRetType <+> - (case fSpec of - (Elemental _ _) -> "elemental" - (Pure _ _ _) -> "pure" - otherwise -> empty) <+> - (if functionIsRecursive fSpec then "recursive" else empty) <+> - "function" <+> text name <> - lparen pprint' v mArgs rparen <+> - "result" lparen pprint' v mRes rparen <> newline) <> + (prefix <+> "function" <+> text name <> + parens (pprint' v mArgs) <+> suffix <> newline) <> pprint v body nextI <> newline indent nextI ("contains" <> newline) newline - pprint v mSubs nextI <> + subs <> endGen v "function" name curI - where - curI = if v >= Fortran90 then i else fixedForm - nextI = if v >= Fortran90 - then incIndentation i - else incIndentation fixedForm + where + convPfx (PfxElemental _ _) + | v >= Fortran95 = "elemental" + | otherwise = tooOld v "Elemental function" Fortran95 + convPfx (PfxPure _ _) + | v >= Fortran95 = "pure" + | otherwise = tooOld v "Pure function" Fortran95 + convPfx (PfxRecursive _ _) + | v >= Fortran90 = "recursive" + | otherwise = tooOld v "Recursive function" Fortran90 + prefix = hsep (pprint' v mRetType:map convPfx pfxs) + + result + | isJust mRes, v >= Fortran90 = "result" lparen pprint' v mRes rparen + | isNothing mRes = empty + | otherwise = tooOld v "Function result" Fortran90 + + suffix = result <+> pprint' v (listToMaybe sfxs) + + subs + | isJust mSubs, v >= Fortran90 = pprint v mSubs nextI + | isNothing mSubs = empty + | otherwise = tooOld v "Function subprogram" Fortran90 + + curI = if v >= Fortran90 then i else fixedForm + nextI = if v >= Fortran90 then incIndentation i + else incIndentation fixedForm + pfxs = aStrip' mpfxs + sfxs = aStrip' msfxs + pprint v (PUBlockData _ _ mName body) i | v < Fortran77, isJust mName = tooOld v "Named block data" Fortran77 | otherwise = @@ -191,6 +216,15 @@ pprint v bs i = foldl' (\b a -> b <> pprint v a i) empty bs instance IndentablePretty (Block a) where + pprint v (BlForall _ _ mLabel mName _ body mel) i = + labeledIndent mLabel (pprint' v mName) <> newline <> + pprint v body nextI <> + labeledIndent mel ("end forall" <+> pprint' v mName <> newline) + where + nextI = incIndentation i + labeledIndent label stDoc = + pprint' v label `overlay` indent i stDoc + pprint v (BlStatement _ _ mLabel st) i = if v >= Fortran90 then indent i (pprint' v mLabel <+> pprint' v st <> newline) @@ -234,14 +268,14 @@ indent nextI ("case" <+> case mRanges of { - Just ranges -> parens (pprint' v ranges); + Just ranges' -> parens (pprint' v ranges'); Nothing -> "default" } <> newline) <> pprint v block (incIndentation nextI) nextI = incIndentation i - pprint v (BlInterface _ _ mLabel pus moduleProcs) i + pprint v (BlInterface _ _ mLabel abstractp pus moduleProcs) i | v >= Fortran90 = - indent i (pprint' v mLabel <+> "interface" <> newline) <> + indent i (abstract <> "interface" <+> pprint' v mLabel <> newline) <> pprint v pus nextI <> newline <> pprint v moduleProcs nextI <> @@ -249,6 +283,8 @@ | otherwise = tooOld v "Interface" Fortran90 where nextI = incIndentation i + abstract | v >= Fortran2003 && abstractp = "abstract " + | otherwise = empty pprint v (BlDo _ _ mLabel mn tl doSpec body el) i | v >= Fortran77Extended = @@ -299,7 +335,7 @@ pprint' :: FortranVersion -> t -> Doc instance Pretty a => Pretty (Maybe a) where - pprint' v Nothing = empty + pprint' _ Nothing = empty pprint' v (Just e) = pprint' v e instance Pretty String where @@ -309,15 +345,15 @@ pprint' v es = commaSep (map (pprint' v) (aStrip es)) instance Pretty BaseType where - pprint' v TypeInteger = "integer" - pprint' v TypeReal = "real" - pprint' v TypeDoublePrecision = "double precision" - pprint' v TypeComplex = "complex" + pprint' _ TypeInteger = "integer" + pprint' _ TypeReal = "real" + pprint' _ TypeDoublePrecision = "double precision" + pprint' _ TypeComplex = "complex" pprint' v TypeDoubleComplex | v == Fortran77Extended = "double complex" | otherwise = tooOld v "Double complex" Fortran77Extended - pprint' v TypeLogical = "logical" - pprint' v TypeCharacter + pprint' _ TypeLogical = "logical" + pprint' v (TypeCharacter _ _) | v >= Fortran77 = "character" | otherwise = tooOld v "Character data type" Fortran77 pprint' v (TypeCustom str) @@ -327,10 +363,22 @@ pprint' v TypeByte | v >= Fortran77Extended = "byte" | otherwise = tooOld v "Byte" Fortran77Extended + pprint' v ClassStar + | v >= Fortran2003 = "class(*)" + | otherwise = tooOld v "Class(*)" Fortran2003 + pprint' v (ClassCustom str) + | v >= Fortran2003 = "class" <> parens (text str) + | otherwise = tooOld v "Class(spec)" Fortran2003 +instance Pretty CharacterLen where + pprint' _ CharLenStar = "*" + pprint' _ CharLenColon = ":" + pprint' _ CharLenExp = "*" -- FIXME, possibly, with a more robust const-exp + pprint' _ (CharLenInt i) = text (show i) + instance Pretty (TypeSpec a) where pprint' v (TypeSpec _ _ baseType mSelector) = - pprint' v baseType <+> pprint' v mSelector + pprint' v baseType <> pprint' v mSelector instance Pretty (Selector a) where pprint' v (Selector _ _ mLenSel mKindSel) @@ -352,12 +400,13 @@ (Just lenDev, Nothing) -> parens $ len lenDev _ -> error "No way for both kind and length selectors to be empty in \ \Fortran 90 onwards." + | otherwise = error "unhandled version" where - len e = "len=" <> pprint' Fortran90 e - kind e = "kind=" <> pprint' Fortran90 e + len e = "len=" <> pprint' v e + kind e = "kind=" <> pprint' v e instance Pretty (Statement a) where - pprint' v st@(StDeclaration _ s typeSpec mAttrList declList) + pprint' v (StDeclaration _ _ typeSpec mAttrList declList) | v < Fortran90 = pprint' v typeSpec <+> pprint' v declList | v >= Fortran90 = pprint' v typeSpec <> @@ -365,8 +414,9 @@ pprint' v mAttrList <+> text "::" <+> pprint' v declList + | otherwise = error "unhandled version" - pprint' v st@(StStructure _ _ mName itemList) + pprint' v (StStructure _ _ mName itemList) | v /= Fortran77Extended = tooOld v "Structure" Fortran77Extended | otherwise = "structure" <> (if isJust mName then " /" <> pprint' v mName <> "/" else empty) <> newline <> @@ -390,6 +440,10 @@ | v >= Fortran90 = "private" <> " :: " pprint' v mVars | otherwise = tooOld v "Private statement" Fortran90 + pprint' v (StProtected _ _ mVars) + | v >= Fortran2003 = "protected" <> " :: " pprint' v mVars + | otherwise = tooOld v "Protected statement" Fortran2003 + pprint' v (StSave _ _ mVars) | v >= Fortran90 = "save" <> " :: " pprint' v mVars | otherwise = "save" <+> pprint' v mVars @@ -402,6 +456,10 @@ | v >= Fortran90 = "allocatable ::" <+> pprint' v decls | otherwise = tooOld v "Allocatable statement" Fortran90 + pprint' v (StAsynchronous _ _ decls) + | v >= Fortran2003 = "asynchronous ::" <+> pprint' v decls + | otherwise = tooOld v "Asynchronous statement" Fortran2003 + pprint' v (StPointer _ _ decls) | v >= Fortran90 = "pointer ::" <+> pprint' v decls | otherwise = tooOld v "Pointer statement" Fortran90 @@ -410,13 +468,21 @@ | v >= Fortran90 = "target ::" <+> pprint' v decls | otherwise = tooOld v "Target statement" Fortran90 + pprint' v (StValue _ _ decls) + | v >= Fortran95 = "value ::" <+> pprint' v decls + | otherwise = tooOld v "Value statement" Fortran95 + + pprint' v (StVolatile _ _ decls) + | v >= Fortran95 = "volatile ::" <+> pprint' v decls + | otherwise = tooOld v "Volatile statement" Fortran95 + pprint' v (StData _ _ aDataGroups@(AList _ _ dataGroups)) | v >= Fortran90 = "data" <+> pprint' v aDataGroups | otherwise = "data" <+> hsep (map (pprint' v) dataGroups) pprint' v (StAutomatic _ _ decls) | v == Fortran77Extended = "automatic" <+> pprint' v decls - | otherwise = tooOld v "Target statement" Fortran90 + | otherwise = tooOld v "Automatic statement" Fortran90 pprint' v (StNamelist _ _ namelist) | v >= Fortran90 = "namelist" <+> pprint' v namelist @@ -452,7 +518,7 @@ pprint' v (StInclude _ _ file _) = "include" <+> pprint' v file - pprint' v (StDo _ s mConstructor mLabel mDoSpec) + pprint' v (StDo _ _ mConstructor mLabel mDoSpec) | v < Fortran90 , Just _ <- mConstructor = tooOld v "Named DO block" Fortran90 | v < Fortran77Extended @@ -473,7 +539,7 @@ pprint' v (StEnddo _ _ mConstructor) | v < Fortran77Extended = tooOld v "End do" Fortran77Extended | v < Fortran90 - , name <- mConstructor = tooOld v "Named DO loop" Fortran90 + , _ <- mConstructor = tooOld v "Named DO loop" Fortran90 | otherwise = "end do" <+> pprint' v mConstructor pprint' v (StExpressionAssign _ _ lhs rhs) = @@ -567,7 +633,7 @@ pprint' v (StCall _ _ name args) = pprint' v name <+> parens (pprint' v args) - pprint' v (StContinue _ _) = "continue" + pprint' _ (StContinue _ _) = "continue" pprint' v (StReturn _ _ exp) = "return" <+> pprint' v exp @@ -577,7 +643,7 @@ pprint' v (StRead _ _ cilist mIolist) = "read" <+> parens (pprint' v cilist) <+> pprint' v mIolist - pprint' v (StRead2 _ s formatId mIolist) = + pprint' v (StRead2 _ _ formatId mIolist) = "read" <+> pprint' v formatId <> comma pprint' v mIolist pprint' v (StWrite _ _ cilist mIolist) = @@ -591,6 +657,9 @@ pprint' v (StOpen _ _ cilist) = "open" <+> parens (pprint' v cilist) pprint' v (StClose _ _ cilist) = "close" <+> parens (pprint' v cilist) + pprint' v (StFlush _ _ (AList _ _ fslist)) + | v >= Fortran2003 = "flush" <+> parens (commaSep $ map (pprint' v) fslist) + | otherwise = tooOld v "Flush statement" Fortran2003 pprint' v (StInquire _ _ cilist) = "inquire" <+> parens (pprint' v cilist) pprint' v (StRewind _ _ cilist) = "rewind" <+> parens (pprint' v cilist) @@ -603,14 +672,19 @@ pprint' v (StEndfile _ _ cilist) = "endfile" <+> parens (pprint' v cilist) pprint' v (StEndfile2 _ _ unit) = "endfile" <+> pprint' v unit - pprint' v (StAllocate _ _ vars contPair) + pprint' v (StAllocate _ _ (Just ty) vars opts) + | v >= Fortran2003 = + "allocate" <+> parens (pprint' v ty <+> "::" <+> pprint' v vars <> comma pprint' v opts) + | otherwise = tooOld v "Allocate with type_spec" Fortran2003 + + pprint' v (StAllocate _ _ Nothing vars opts) | v >= Fortran90 = - "allocate" <+> parens (pprint' v vars <> comma pprint' v contPair) + "allocate" <+> parens (pprint' v vars <> comma pprint' v opts) | otherwise = tooOld v "Allocate" Fortran90 - pprint' v (StDeallocate _ _ vars contPair) + pprint' v (StDeallocate _ _ vars opts) | v >= Fortran90 = - "deallocate" <+> parens (pprint' v vars <> comma pprint' v contPair) + "deallocate" <+> parens (pprint' v vars <> comma pprint' v opts) | otherwise = tooOld v "Deallocate" Fortran90 pprint' v (StNullify _ _ vars) = "nullify" <+> pprint' v vars @@ -620,29 +694,56 @@ "where" <+> parens (pprint' v mask) <+> pprint' v assignment | otherwise = tooOld v "Where statement" Fortran90 - pprint' v (StWhereConstruct _ _ mask) + pprint' v (StWhereConstruct _ _ (Just lab) mask) + | v >= Fortran2003 = text lab <> ":" <+> "where" <+> parens (pprint' v mask) + | otherwise = tooOld v "Labelled where construct" Fortran2003 + + pprint' v (StWhereConstruct _ _ Nothing mask) | v >= Fortran90 = "where" <+> parens (pprint' v mask) | otherwise = tooOld v "Where construct" Fortran90 - pprint' v (StElsewhere _ _) - | v >= Fortran90 = "else where" + pprint' v (StElsewhere _ _ (Just lab) mexp) + | v >= Fortran2003 = "else where" <+> "(" pprint' v mexp ")" <+> text lab + | otherwise = tooOld v "Labelled ELSEWHERE" Fortran2003 + + pprint' v (StElsewhere _ _ Nothing mexp) + | v >= Fortran90 = "else where" <+> "(" pprint' v mexp ")" | otherwise = tooOld v "Else where" Fortran90 - pprint' v (StEndWhere _ _) + pprint' v (StEndWhere _ _ (Just lab)) + | v >= Fortran2003 = "end where" <+> text lab + | otherwise = tooOld v "Labelled END WHERE" Fortran2003 + + pprint' v (StEndWhere _ _ Nothing) | v >= Fortran90 = "end where" | otherwise = tooOld v "End where" Fortran90 - pprint' v (StUse _ _ moduleName only mappings) + pprint' v (StUse _ _ moduleName mIntrinsic only mappings) + | v >= Fortran2003 = + "use" <> (comma intrinsic "::") <+> pprint' v moduleName <> + (comma (pprint' v only <+> pprint' v mappings)) | v >= Fortran90 = "use" <+> pprint' v moduleName <> (comma (pprint' v only <+> pprint' v mappings)) | otherwise = tooOld v "Module system" Fortran90 + where + intrinsic = case mIntrinsic of + Just ModIntrinsic -> "intrinsic" + Just ModNonIntrinsic -> "non_intrinsic" + Nothing -> empty pprint' v (StModuleProcedure _ _ procedures) | v >= Fortran90 = "module procedure" <+> pprint' v procedures | otherwise = tooOld v "Module procedure" Fortran90 + pprint' v (StProcedure _ _ mProcInterface mSuffix (AList _ _ procDecls)) + | v >= Fortran2003 = + "procedure" <> parens (pprint' v mProcInterface) <> + comma pprint' v mSuffix <+> "::" + commaSep (map (pprint' v) procDecls) + | otherwise = tooOld v "Procedure" Fortran2003 + pprint' v (StType _ _ attrs name) | v >= Fortran90 = "type" <+> pprint' v attrs <+> pprint' v name | otherwise = tooOld v "Derived type" Fortran90 @@ -651,15 +752,42 @@ | v >= Fortran90 = "end type" <+> pprint' v name | otherwise = tooOld v "Derived type" Fortran90 + pprint' v (StEnum _ _) + | v >= Fortran2003 = "enum, bind(c)" + | otherwise = tooOld v "Enum" Fortran2003 + + pprint' v (StEnumerator _ _ decls) + | v >= Fortran2003 = "enumerator ::" <+> pprint' v decls + | otherwise = tooOld v "Enumator" Fortran2003 + + pprint' v (StEndEnum _ _) + | v >= Fortran2003 = "end enum" + | otherwise = tooOld v "End enum" Fortran2003 + pprint' v (StSequence _ _) | v >= Fortran90 = "sequence" | otherwise = tooOld v "Sequence" Fortran90 + pprint' v (StImport _ _ (AList _ _ vs)) + | v >= Fortran2003 = "import" <+> commaSep (map (pprint' v) vs) + | otherwise = tooOld v "Import" Fortran2003 + pprint' v (StFormatBogus _ _ blob) = "format" <+> pprint' v blob + pprint' _ StForall{} = error "unhandled pprint StForall" + pprint' _ StForallStatement{} = error "unhandled pprint StForallStatement" + pprint' _ StEndForall{} = error "unhandled pprint StEndForall" +instance Pretty (ProcInterface a) where + pprint' v (ProcInterfaceName _ _ e) = pprint' v e + pprint' v (ProcInterfaceType _ _ t) = pprint' v t + +instance Pretty (ProcDecl a) where + pprint' v (ProcDecl _ _ e1 (Just e2)) = pprint' v e1 <+> "=>" <+> pprint' v e2 + pprint' v (ProcDecl _ _ e1 Nothing) = pprint' v e1 + instance Pretty Only where - pprint' v Exclusive = "only" <> colon - pprint' v Permissive = empty + pprint' _ Exclusive = "only" <> colon + pprint' _ Permissive = empty instance Pretty (Use a) where pprint' v use @@ -668,9 +796,10 @@ UseRename _ _ uSrc uDst -> pprint' v uSrc <+> "=>" <+> pprint' v uDst UseID _ _ u -> pprint' v u | v < Fortran90 = tooOld v "Module system" Fortran90 + | otherwise = error "unhandled version" instance Pretty (Argument a) where - pprint' v (Argument _ s key e) = + pprint' v (Argument _ _ key e) = case key of Just keyName -> text keyName <+> char '=' <+> pprint' v e Nothing -> pprint' v e @@ -679,12 +808,28 @@ pprint' v attr | v >= Fortran90 = case attr of + AttrAsynchronous _ _ + | v >= Fortran2003 -> "asynchronous" + | otherwise -> tooOld v "Asynchronous attribute" Fortran2003 + AttrValue _ _ + | v >= Fortran95 -> "value" + | otherwise -> tooOld v "Value attribute" Fortran95 + AttrVolatile _ _ + | v >= Fortran95 -> "volatile" + | otherwise -> tooOld v "Volatile attribute" Fortran95 + AttrSuffix _ _ s + | v >= Fortran2003 -> pprint' v s + | otherwise -> tooOld v "Bind (language-binding-spec) attribute" Fortran2003 + AttrParameter _ _ -> "parameter" AttrPublic _ _ -> "public" AttrPrivate _ _ -> "private" + AttrProtected _ _ + | v >= Fortran2003 -> "protected" + | otherwise -> tooOld v "Protected attribute" Fortran2003 AttrAllocatable _ _ -> "allocatable" AttrDimension _ _ dims -> - "dimesion" <> parens (pprint' v dims) + "dimension" <> parens (pprint' v dims) AttrExternal _ _ -> "external" AttrIntent _ _ intent -> "intent" <> parens (pprint' v intent) @@ -695,6 +840,11 @@ AttrTarget _ _ -> "target" | otherwise = tooOld v "Declaration attribute" Fortran90 +instance Pretty (Suffix a) where + pprint' v (SfxBind _ _ mexp) + | v >= Fortran2003 = "bind" <> parens ("c" <> comma pprint' v mexp) + | otherwise = tooOld v "Bind suffix" Fortran2003 + instance Pretty Intent where pprint' v intent | v >= Fortran90 = @@ -711,6 +861,12 @@ text (show $ length s) <> char 'h' <> text s pprint' _ _ = error "Not yet supported." +instance Pretty (FlushSpec a) where + 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 + instance Pretty (DoSpecification a) where pprint' v (DoSpecification _ _ s@StExpressionAssign{} limit mStride) = pprint' v s <> comma @@ -727,9 +883,18 @@ | v >= Fortran77 , Just str <- mStr = text str <> char '=' <> pprint' v exp | v < Fortran77 - , Just str <- mStr = tooOld v "Named control pair" Fortran77 + , Just _ <- mStr = tooOld v "Named control pair" Fortran77 | otherwise = pprint' v exp +instance Pretty (AllocOpt a) where + pprint' v (AOStat _ _ e) = "stat=" <> pprint' v e + pprint' v (AOErrMsg _ _ e) + | v >= Fortran2003 = "errmsg=" <> pprint' v e + | otherwise = tooOld v "Allocate errmsg" Fortran2003 + pprint' v (AOSource _ _ e) + | v >= Fortran2003 = "source=" <> pprint' v e + | otherwise = tooOld v "Allocate source" Fortran2003 + instance Pretty (ImpList a) where pprint' v (ImpList _ _ bt els) = pprint' v bt <+> parens (pprint' v els) @@ -747,68 +912,69 @@ pprint' v vars <> char '/' <> pprint' v exps <> char '/' instance Pretty (ImpElement a) where - pprint' v (ImpCharacter _ _ c) = text c - pprint' v (ImpRange _ _ beg end) = text beg <> "-" <> text end + pprint' _ (ImpCharacter _ _ c) = text c + pprint' _ (ImpRange _ _ beg end) = text beg <> "-" <> text end instance Pretty (Expression a) where - pprint' v (ExpValue _ s val) = + pprint' v (ExpValue _ _ val) = pprint' v val - pprint' v (ExpBinary _ s op e1 e2) = + pprint' v (ExpBinary _ _ op e1 e2) = parens (pprint' v e1 <+> pprint' v op <+> pprint' v e2) - pprint' v (ExpUnary _ s op e) = + pprint' v (ExpUnary _ _ op e) = pprint' v op <+> pprint' v e - pprint' v (ExpSubscript _ s e ixs) = + pprint' v (ExpSubscript _ _ e ixs) = pprint' v e <> parens (pprint' v ixs) - pprint' v (ExpDataRef _ s e1 e2) = + pprint' v (ExpDataRef _ _ e1 e2) = pprint' v e1 <+> char '%' <+> pprint' v e2 - pprint' v (ExpFunctionCall _ s e mes) = + pprint' v (ExpFunctionCall _ _ e mes) = pprint' v e <> parens (pprint' v mes) - pprint' v (ExpImpliedDo _ s es dospec) = + pprint' v (ExpImpliedDo _ _ es dospec) = pprint' v es <> comma <+> pprint' v dospec - pprint' v (ExpInitialisation _ s es) = + pprint' v (ExpInitialisation _ _ es) = "(/" <> pprint' v es <> "/)" - pprint' v (ExpReturnSpec _ s e) = + pprint' v (ExpReturnSpec _ _ e) = char '*' <> pprint' v e instance Pretty (Index a) where - pprint' v (IxSingle _ s Nothing e) = pprint' v e + pprint' v (IxSingle _ _ Nothing e) = pprint' v e -- This is an intermediate expression form which shouldn't make it -- to the pretty printer - pprint' v (IxSingle _ s (Just _) e) = pprint' v e - pprint' v (IxRange _ s low up stride) = + pprint' v (IxSingle _ _ (Just _) e) = pprint' v e + 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' v ValStar = char '*' + pprint' _ ValStar = char '*' + pprint' _ ValColon = char ':' pprint' v ValAssignment | v >= Fortran90 = "assignment (=)" -- TODO better error message is needed. Assignment is too vague. - | otherwise = tooOld v "Asiggnment" Fortran90 + | otherwise = tooOld v "Assignment" Fortran90 pprint' v (ValOperator op) | 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 (ValString str) = quotes $ text str - pprint' v valLit = text . getFirstParameter $ valLit + pprint' _ (ValString str) = quotes $ text str + pprint' _ valLit = text . getFirstParameter $ valLit instance IndentablePretty (StructureItem a) where - pprint v (StructFields a s spec mAttrs decls) i = pprint' v (StDeclaration a s spec mAttrs decls) + pprint v (StructFields a s spec mAttrs decls) _ = pprint' v (StDeclaration a s spec mAttrs decls) pprint v (StructUnion _ _ maps) i = "union" <> newline <> foldl' (\doc item -> doc <> pprint v item (incIndentation i) <> newline) empty (aStrip maps) <> "end union" - pprint v (StructStructure a s mName items) i = pprint' v (StStructure a s mName items) + pprint v (StructStructure a s mName items) _ = pprint' v (StStructure a s mName items) instance IndentablePretty (UnionMap a) where pprint v (UnionMap _ _ items) i = @@ -881,9 +1047,9 @@ pprint' v GTE = if v <= Fortran77Extended then ".ge." else ">=" pprint' v EQ = if v <= Fortran77Extended then ".eq." else "==" pprint' v NE = if v <= Fortran77Extended then ".ne." else "/=" - pprint' v Or = ".or." - pprint' v XOr = ".xor." - pprint' v And = ".and." + pprint' _ Or = ".or." + pprint' _ XOr = ".xor." + pprint' _ And = ".and." pprint' v Equivalent | v >= Fortran77 = ".eqv." | otherwise = tooOld v ".EQV. operator" Fortran77 @@ -891,7 +1057,7 @@ | v >= Fortran77 = ".neqv." | otherwise = tooOld v ".NEQV. operator" Fortran77 pprint' v (BinCustom custom) - | v >= Fortran90 = "." <> text custom <> "." + | v >= Fortran90 = text custom | otherwise = tooOld v "Custom binary operator" Fortran90 commaSep :: [Doc] -> Doc 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 @@ -20,28 +20,35 @@ disambiguateFunctionStatements :: Data a => Transform a () disambiguateFunctionStatements = modifyProgramFile (trans statement) where - trans = (transformBi :: Data a => TransFunc Statement ProgramFile a) - statement st@(StExpressionAssign a1 s (ExpSubscript _ _ v@(ExpValue a _ (ValVariable _)) indicies) e2) + trans = transformBi :: Data a => TransFunc Statement ProgramFile a + statement (StExpressionAssign a1 s (ExpSubscript _ _ v@(ExpValue a _ (ValVariable _)) indicies) e2) | 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 = st disambiguateFunctionCalls :: Data a => Transform a () disambiguateFunctionCalls = modifyProgramFile (trans expression) where - trans = (transformBi :: Data a => TransFunc Expression ProgramFile a) - expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies) + 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) - expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies) | Just (IDType _ (Just CTExternal)) <- idType a , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies) - expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValIntrinsic _)) indicies) + | Just (IDType _ (Just CTVariable)) <- idType a + , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies) + | Nothing <- idType a + , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ 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) expression e = e -- BEGIN: TODO STRICTLY TO BE REMOVED LATER TODO +indiciesRangeFree :: AList Index a -> Bool indiciesRangeFree aIndicies = cRange $ aStrip aIndicies where cRange [] = True diff --git a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs --- a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +++ b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs @@ -15,8 +15,8 @@ disambiguateIntrinsic :: Data a => Transform a () disambiguateIntrinsic = modifyProgramFile (trans expression) where - trans = (transformBi :: Data a => TransFunc Expression ProgramFile a) - expression e@(ExpValue a s (ValVariable v)) + trans = transformBi :: Data a => TransFunc Expression ProgramFile a + expression (ExpValue a s (ValVariable v)) | Just (IDType _ (Just CTIntrinsic)) <- idType a = ExpValue a s (ValIntrinsic v) expression e = e 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 @@ -11,19 +11,26 @@ import Language.Fortran.Transformation.TransformMonad import Data.Data +import Data.List (intercalate) import Data.Generics.Uniplate.Operations type ABlocks a = [ Block (Analysis a) ] -genericGroup :: Data a => (ABlocks a -> ABlocks a) -> Transform a () -genericGroup groupingFunction = - modifyProgramFile $ transformBi groupingFunction +genericGroup :: Data a => (ABlocks a -> ABlocks a) -> (Statement (Analysis a) -> Bool) -> Transform a () +genericGroup groupingFunction checkingFunction = do + pf <- getProgramFile + let pf' = transformBi groupingFunction pf + bad = filter checkingFunction $ universeBi pf' + if null bad + then putProgramFile pf' + else let spans = [ apparentFilePath p1 ++ " " ++ show ss | b <- bad, let ss@(SrcSpan p1 _) = getSpan b ] in + error $ "Mis-matched grouping statements at these position(s): " ++ intercalate ", " spans -------------------------------------------------------------------------------- -- Grouping FORALL statement blocks into FORALL blocks in entire parse tree -------------------------------------------------------------------------------- groupForall :: Data a => Transform a () -groupForall = genericGroup groupForall' +groupForall = genericGroup groupForall' isForall groupForall' :: ABlocks a -> ABlocks a @@ -40,8 +47,8 @@ | StForallStatement _ _ header st' <- st -> let block = BlStatement a (getSpan st') Nothing st' in ( BlForall a (getTransSpan s st') label Nothing header [block] Nothing, groupedBlocks ) - b | containsGroups b -> - ( applyGroupingToSubblocks groupForall' b, groupedBlocks ) + b'' | containsGroups b'' -> + ( applyGroupingToSubblocks groupForall' b'', groupedBlocks ) _ -> (b, groupedBlocks) groupedBlocks = groupForall' bs @@ -51,7 +58,7 @@ , Maybe (Expression (Analysis a)) ) collectNonForallBlocks blocks mNameTarget = case blocks of - b@(BlStatement _ _ mLabel (StEndForall _ _ mName)):rest + BlStatement _ _ mLabel (StEndForall _ _ mName):rest | mName == mNameTarget -> ([], rest, mLabel) | otherwise -> error "Forall block name does not match that of the end statement." @@ -60,13 +67,17 @@ in (b : bs', rest, mLabel) _ -> error "Premature file ending while parsing structured forall block." +isForall :: Statement a -> Bool +isForall (StForall{}) = True +isForall (StForallStatement{}) = True +isForall _ = False -------------------------------------------------------------------------------- -- Grouping if statement blocks into if blocks in entire parse tree -------------------------------------------------------------------------------- groupIf :: Data a => Transform a () -groupIf = genericGroup groupIf' +groupIf = genericGroup groupIf' isIf -- Actual grouping is done here. -- 1. Case: head is a statement block with an IF statement: @@ -86,12 +97,12 @@ (b', bs') = case b of BlStatement a s label st | StIfThen _ _ mName _ <- st -> -- If statement - let ( conditions, blocks, leftOverBlocks, endLabel ) = + let ( conditions, blocks, leftOverBlocks, endLabel, endStmt ) = decomposeIf (b:groupedBlocks) - in ( BlIf a (getTransSpan s blocks) label mName conditions blocks endLabel + in ( BlIf a (getTransSpan s endStmt) label mName conditions blocks endLabel , leftOverBlocks) - b | containsGroups b -> -- Map to subblocks for groupable blocks - ( applyGroupingToSubblocks groupIf' b, groupedBlocks ) + b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks + ( applyGroupingToSubblocks groupIf' b'', groupedBlocks ) _ -> ( b, groupedBlocks ) groupedBlocks = groupIf' bs -- Assume everything to the right is grouped. @@ -119,8 +130,9 @@ -> ( [ Maybe (Expression (Analysis a)) ], [ ABlocks a ], ABlocks a, - Maybe (Expression (Analysis a)) ) -decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):rest) = + Maybe (Expression (Analysis a)), + Statement (Analysis a) ) +decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):_) = decomposeIf' blocks where decomposeIf' (BlStatement _ _ mLabel st:rest) = @@ -129,17 +141,20 @@ StElsif _ _ _ condition -> go (Just condition) rest StElse{} -> go Nothing rest StEndif _ _ mName - | mName == mTargetName -> ([], [], rest, mLabel) + | mName == mTargetName -> ([], [], rest, mLabel, st) | otherwise -> error $ "If statement name does not match that of " ++ "the corresponding end if statement." _ -> error "Block with non-if related statement. Should never occur." - go maybeCondition blocks = - let (nonConditionBlocks, rest') = collectNonConditionalBlocks blocks - (conditions, listOfBlocks, rest'', endLabel) = decomposeIf' rest' + decomposeIf' _ = error "can't decompose block" + go maybeCondition blocks' = + let (nonConditionBlocks, rest') = collectNonConditionalBlocks blocks' + (conditions, listOfBlocks, rest'', endLabel, endStmt) = decomposeIf' rest' in ( maybeCondition : conditions , nonConditionBlocks : listOfBlocks , rest'' - , endLabel ) + , endLabel + , endStmt ) +decomposeIf _ = error "can't decompose block" -- This compiles the executable blocks under various if conditions. collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a) @@ -151,86 +166,100 @@ -- conditional directives. The reason is that this block can be -- a branch target if it is labeled according to the specification, hence -- it is presence in the parse tree is meaningful. - b@(BlStatement _ _ _ StEndif{}):_ -> ([], blocks) + BlStatement _ _ _ StEndif{}:_ -> ([], blocks) -- Catch all case for all non-if related blocks. b:bs -> let (bs', rest) = collectNonConditionalBlocks bs in (b : bs', rest) -- In this case the structured if block is malformed and the file ends -- prematurely. _ -> error "Premature file ending while parsing structured if block." +isIf :: Statement a -> Bool +isIf s = case s of + StIfThen{} -> True + StElsif{} -> True + StElse{} -> True + StEndif{} -> True + _ -> False + -------------------------------------------------------------------------------- -- Grouping new do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- groupDo :: Data a => Transform a () -groupDo = genericGroup groupDo' +groupDo = genericGroup groupDo' isDo groupDo' :: ABlocks a -> ABlocks a groupDo' [ ] = [ ] -groupDo' blocks@(b:bs) = b' : bs' +groupDo' (b:bs) = b' : bs' where (b', bs') = case b of BlStatement a s label st -- Do While statement | StDoWhile _ _ mTarget Nothing condition <- st -> - let ( blocks, leftOverBlocks, endLabel ) = + let ( blocks, leftOverBlocks, endLabel, stEnd ) = collectNonDoBlocks groupedBlocks mTarget - in ( BlDoWhile a (getTransSpan s blocks) label mTarget Nothing condition blocks endLabel + in ( BlDoWhile a (getTransSpan s stEnd) label mTarget Nothing condition blocks endLabel , leftOverBlocks) -- Vanilla do statement | StDo _ _ mName Nothing doSpec <- st -> - let ( blocks, leftOverBlocks, endLabel ) = + let ( blocks, leftOverBlocks, endLabel, stEnd ) = collectNonDoBlocks groupedBlocks mName - in ( BlDo a (getTransSpan s blocks) label mName Nothing doSpec blocks endLabel + in ( BlDo a (getTransSpan s stEnd) label mName Nothing doSpec blocks endLabel , leftOverBlocks) - b | containsGroups b -> - ( applyGroupingToSubblocks groupDo' b, groupedBlocks ) + b'' | containsGroups b'' -> + ( applyGroupingToSubblocks groupDo' b'', groupedBlocks ) _ -> ( b, groupedBlocks ) groupedBlocks = groupDo' bs -- Assume everything to the right is grouped. collectNonDoBlocks :: ABlocks a -> Maybe String -> ( ABlocks a , ABlocks a - , Maybe (Expression (Analysis a)) ) + , Maybe (Expression (Analysis a)) + , Statement (Analysis a) ) collectNonDoBlocks blocks mNameTarget = case blocks of - b@(BlStatement _ _ mLabel (StEnddo _ _ mName)):rest - | mName == mNameTarget -> ([ ], rest, mLabel) + BlStatement _ _ mLabel st@(StEnddo _ _ mName):rest + | mName == mNameTarget -> ([ ], rest, mLabel, st) | otherwise -> error "Do block name does not match that of the end statement." b:bs -> - let (bs', rest, mLabel) = collectNonDoBlocks bs mNameTarget - in (b : bs', rest, mLabel) + let (bs', rest, mLabel, stEnd) = collectNonDoBlocks bs mNameTarget + in (b : bs', rest, mLabel, stEnd) _ -> error "Premature file ending while parsing structured do block." +isDo :: Statement a -> Bool +isDo s = case s of + StDo _ _ _ Nothing _ -> True + StDoWhile _ _ _ Nothing _ -> True + StEnddo{} -> True + _ -> False + -------------------------------------------------------------------------------- -- Grouping labeled do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- groupLabeledDo :: Data a => Transform a () -groupLabeledDo = genericGroup groupLabeledDo' +groupLabeledDo = genericGroup groupLabeledDo' isLabeledDo groupLabeledDo' :: ABlocks a -> ABlocks a groupLabeledDo' [ ] = [ ] -groupLabeledDo' blos@(b:bs) = b' : bs' +groupLabeledDo' (b:bs) = b' : bs' where (b', bs') = case b of BlStatement a s label (StDo _ _ mn tl@Just{} doSpec) -> - let ( blocks, leftOverBlocks ) = + let ( blocks, leftOverBlocks, lastLabel ) = collectNonLabeledDoBlocks tl groupedBlocks - lastLabel = getLastLabel $ last blocks in ( BlDo a (getTransSpan s blocks) label mn tl doSpec blocks lastLabel , leftOverBlocks ) BlStatement a s label (StDoWhile _ _ mn tl@Just{} cond) -> - let ( blocks, leftOverBlocks ) = + let ( blocks, leftOverBlocks, lastLabel ) = collectNonLabeledDoBlocks tl groupedBlocks - lastLabel = getLastLabel $ last blocks in ( BlDoWhile a (getTransSpan s blocks) label mn tl cond blocks lastLabel , leftOverBlocks ) - b | containsGroups b -> - ( applyGroupingToSubblocks groupLabeledDo' b, groupedBlocks ) + b'' | containsGroups b'' -> + ( applyGroupingToSubblocks groupLabeledDo' b'', groupedBlocks ) _ -> (b, groupedBlocks) -- Assume everything to the right is grouped. @@ -238,18 +267,20 @@ collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> ABlocks a - -> (ABlocks a, ABlocks a) + -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a))) collectNonLabeledDoBlocks targetLabel blocks = case blocks of -- Didn't find a statement with matching label; don't group [] -> error "Malformed labeled DO group." - b:bs - | compLabel (getLastLabel b) targetLabel -> ([ b ], bs) - | otherwise -> - let (bs', rest) = collectNonLabeledDoBlocks targetLabel bs - in (b : bs', rest) + | compLabel (getLastLabel b) targetLabel -> (b1, bs, getLastLabel b) + | otherwise -> (b : bs', rest, ll) + where (bs', rest, ll) = collectNonLabeledDoBlocks targetLabel bs + b1 = case b of BlStatement _ _ _ StEnddo{} -> [] + BlStatement _ _ _ StContinue{} -> [] + _ -> [b] + compLabel :: Maybe (Expression a) -> Maybe (Expression a) -> Bool compLabel (Just (ExpValue _ _ (ValInteger l1))) (Just (ExpValue _ _ (ValInteger l2))) = strip l1 == strip l2 @@ -258,12 +289,18 @@ strip :: String -> String strip = dropWhile (=='0') +isLabeledDo :: Statement a -> Bool +isLabeledDo s = case s of + StDo _ _ _ Just{} _ -> True + StDoWhile _ _ _ Just{} _ -> True + _ -> False + -------------------------------------------------------------------------------- -- Grouping case statements -------------------------------------------------------------------------------- groupCase :: Data a => Transform a () -groupCase = genericGroup groupCase' +groupCase = genericGroup groupCase' isCase groupCase' :: ABlocks a -> ABlocks a groupCase' [] = [] @@ -276,18 +313,18 @@ ( conds, blocks, leftOverBlocks, endLabel ) = decomposeCase blocksToDecomp mName in ( BlCase a (getTransSpan s blocks) label mName scrutinee conds blocks endLabel , leftOverBlocks) - b | containsGroups b -> -- Map to subblocks for groupable blocks - ( applyGroupingToSubblocks groupCase' b, groupedBlocks ) + b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks + ( applyGroupingToSubblocks groupCase' b'', groupedBlocks ) _ -> ( b , groupedBlocks ) groupedBlocks = groupCase' bs -- Assume everything to the right is grouped. - isComment b = case b of { BlComment{} -> True; _ -> False } + isComment b'' = case b'' of { BlComment{} -> True; _ -> False } decomposeCase :: ABlocks a -> Maybe String -> ( [ Maybe (AList Index (Analysis a)) ] , [ ABlocks a ] , ABlocks a , Maybe (Expression (Analysis a)) ) -decomposeCase blocks@(BlStatement _ _ mLabel st:rest) mTargetName = +decomposeCase (BlStatement _ _ mLabel st:rest) mTargetName = case st of StCase _ _ mName mCondition | Nothing <- mName -> go mCondition rest @@ -301,23 +338,31 @@ _ -> error "Block with non-case related statement. Must not occur." where go mCondition blocks = - let (nonCaseBlocks, rest) = collectNonCaseBlocks blocks - (conditions, listOfBlocks, rest', endLabel) = decomposeCase rest mTargetName + let (nonCaseBlocks, rest') = collectNonCaseBlocks blocks + (conditions, listOfBlocks, rest'', endLabel) = decomposeCase rest' mTargetName in ( mCondition : conditions , nonCaseBlocks : listOfBlocks - , rest', endLabel ) + , rest'', endLabel ) +decomposeCase _ _ = error "can't decompose case" -- This compiles the executable blocks under various if conditions. collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a) collectNonCaseBlocks blocks = case blocks of - b@(BlStatement _ _ _ st):_ + BlStatement _ _ _ st:_ | StCase{} <- st -> ( [], blocks ) | StEndcase{} <- st -> ( [], blocks ) -- In this case case block is malformed and the file ends prematurely. b:bs -> let (bs', rest) = collectNonCaseBlocks bs in (b : bs', rest) _ -> error "Premature file ending while parsing select case block." +isCase :: Statement a -> Bool +isCase s = case s of + StCase{} -> True + StEndcase{} -> True + StSelectCase{} -> True + _ -> False + -------------------------------------------------------------------------------- -- Helpers for grouping of structured blocks with more blocks inside. -------------------------------------------------------------------------------- @@ -332,6 +377,7 @@ BlDoWhile{} -> True BlInterface{} -> False BlComment{} -> False + BlForall{} -> True applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a) applyGroupingToSubblocks f b @@ -345,7 +391,9 @@ | BlInterface{} <- b = error "Interface blocks do not have groupable subblocks. Must not occur." | BlComment{} <- b = - error "Comment statements do not have subblocks. Must not occur." + error "Comment statements do not have subblocks. Must not occur." + | BlForall a s ml mn h blocks mel <- b = + BlForall a s ml mn h (f blocks) mel -------------------------------------------------- diff --git a/src/Language/Fortran/Transformation/TransformMonad.hs b/src/Language/Fortran/Transformation/TransformMonad.hs --- a/src/Language/Fortran/Transformation/TransformMonad.hs +++ b/src/Language/Fortran/Transformation/TransformMonad.hs @@ -3,12 +3,12 @@ , putProgramFile , modifyProgramFile , runTransform - , Transform(..) ) + , Transform) where import Prelude hiding (lookup) -import Control.Monad.State.Lazy +import Control.Monad.State.Lazy hiding (state) import Data.Data import Language.Fortran.Analysis 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,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,10 +13,10 @@ setFirstParameter :: e -> a -> a default getFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => a -> e - getFirstParameter a = getFirstParameter' . from $ a + getFirstParameter = getFirstParameter' . from default setFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => e -> a -> a - setFirstParameter e a = to . setFirstParameter' e . from $ a + setFirstParameter e = to . setFirstParameter' e . from class GFirstParameter f e where getFirstParameter' :: f a -> e @@ -25,7 +24,7 @@ instance {-# OVERLAPPING #-} GFirstParameter (K1 i e) e where getFirstParameter' (K1 a) = a - setFirstParameter' e (K1 a) = K1 e + setFirstParameter' e (K1 _) = K1 e instance {-# OVERLAPPABLE #-} GFirstParameter (K1 i a) e where getFirstParameter' _ = undefined @@ -44,7 +43,7 @@ instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :*: b) e where getFirstParameter' (a :*: _) = getFirstParameter' a - setFirstParameter' e (a :*: b) = (setFirstParameter' e a :*: b) + setFirstParameter' e (a :*: b) = setFirstParameter' e a :*: b instance (GFirstParameter U1 String) where getFirstParameter' _ = "" diff --git a/src/Language/Fortran/Util/ModFile.hs b/src/Language/Fortran/Util/ModFile.hs --- a/src/Language/Fortran/Util/ModFile.hs +++ b/src/Language/Fortran/Util/ModFile.hs @@ -30,7 +30,7 @@ > let modFile1 = genModFile programFile > let modFile2 = alterModFileData (const (Just ...)) "mydata" modFile1 -> let bytes = encodeModFile modFile1 +> let bytes = encodeModFile modFile2 > ... > case decodeModFile bytes of > Left error -> print error @@ -46,8 +46,8 @@ ( modFileSuffix, ModFile, ModFiles, emptyModFile, emptyModFiles , lookupModFileData, getLabelsModFileData, alterModFileData -- , alterModFileDataF , genModFile, regenModFile, encodeModFile, decodeModFile - , DeclMap, DeclContext(..), extractModuleMap, extractDeclMap - , moduleFilename, combinedDeclMap, combinedModuleMap, combinedTypeEnv + , StringMap, DeclMap, ParamVarMap, DeclContext(..), extractModuleMap, extractDeclMap + , moduleFilename, combinedStringMap, combinedDeclMap, combinedModuleMap, combinedTypeEnv, combinedParamVarMap , genUniqNameToFilenameMap ) where @@ -55,9 +55,10 @@ import Data.Maybe import Data.Generics.Uniplate.Operations import qualified Data.Map.Strict as M -import Data.Binary +import Data.Binary (Binary, encode, decodeOrFail) +import Control.Monad.State import GHC.Generics (Generic) -import qualified Data.ByteString.Char8 as B +-- import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import qualified Language.Fortran.Util.Position as P @@ -65,6 +66,8 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.Types as FAT +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.Analysis.BBlocks as FAB -------------------------------------------------- @@ -84,13 +87,22 @@ -- unit where it was defined, and the corresponding SrcSpan. type DeclMap = M.Map F.Name (DeclContext, P.SrcSpan) +-- | A map of aliases => strings, in order to save space and share +-- structure for repeated strings. +type StringMap = M.Map String String + +-- | A map of variables => their constant expression if known +type ParamVarMap = FAD.ParameterVarMap + -- | The data stored in the "mod files" -data ModFile = ModFile { mfFilename :: String - , mfModuleMap :: FAR.ModuleMap - , mfDeclMap :: DeclMap - , mfTypeEnv :: FAT.TypeEnv - , mfOtherData :: M.Map String B.ByteString } - deriving (Ord, Eq, Show, Data, Typeable, Generic) +data ModFile = ModFile { mfFilename :: String + , mfStringMap :: StringMap + , mfModuleMap :: FAR.ModuleMap + , mfDeclMap :: DeclMap + , mfTypeEnv :: FAT.TypeEnv + , mfParamVarMap :: ParamVarMap + , mfOtherData :: M.Map String LB.ByteString } + deriving (Eq, Ord, Show, Data, Typeable, Generic) instance Binary ModFile @@ -103,17 +115,17 @@ -- | Starting point. emptyModFile :: ModFile -emptyModFile = ModFile "" M.empty M.empty M.empty M.empty +emptyModFile = ModFile "" M.empty M.empty M.empty M.empty M.empty M.empty -- | Extracts the module map, declaration map and type analysis from -- an analysed and renamed ProgramFile, then inserts it into the -- ModFile. regenModFile :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ModFile -> ModFile -regenModFile pf mf = mf - { mfModuleMap = extractModuleMap pf - , mfDeclMap = extractDeclMap pf - , mfTypeEnv = FAT.extractTypeEnv pf - , mfFilename = F.pfGetFilename pf } +regenModFile pf mf = mf { mfModuleMap = extractModuleMap pf + , mfDeclMap = extractDeclMap pf + , mfTypeEnv = FAT.extractTypeEnv pf + , mfParamVarMap = extractParamVarMap pf + , mfFilename = F.pfGetFilename pf } -- | Generate a fresh ModFile from the module map, declaration map and -- type analysis of a given analysed and renamed ProgramFile. @@ -122,7 +134,7 @@ -- | Looks up the raw "other data" that may be stored in a ModFile by -- applications that make use of fortran-src. -lookupModFileData :: String -> ModFile -> Maybe B.ByteString +lookupModFileData :: String -> ModFile -> Maybe LB.ByteString lookupModFileData k = M.lookup k . mfOtherData -- | Get a list of the labels present in the "other data" of a @@ -134,7 +146,7 @@ -- be stored in a ModFile by applications that make use of -- fortran-src. See 'Data.Map.Strict.alter' for more information about -- the interface of this function. -alterModFileData :: (Maybe B.ByteString -> Maybe B.ByteString) -> String -> ModFile -> ModFile +alterModFileData :: (Maybe LB.ByteString -> Maybe LB.ByteString) -> String -> ModFile -> ModFile alterModFileData f k mf = mf { mfOtherData = M.alter f k . mfOtherData $ mf } -- For when stackage gets containers-0.5.8.1: @@ -142,14 +154,18 @@ -- alterModFileDataF f k mf = (\ od -> mf { mfOtherData = od }) <$> M.alterF f k (mfOtherData mf) -- | Convert ModFile to a strict ByteString for writing to file. -encodeModFile :: ModFile -> B.ByteString -encodeModFile = LB.toStrict . encode +encodeModFile :: ModFile -> LB.ByteString +encodeModFile mf = encode mf' { mfStringMap = sm } + where + (mf', sm) = extractStringMap (mf { mfStringMap = M.empty }) --- | Convert a strict ByteString to a ModFile, if possible -decodeModFile :: Binary a => B.ByteString -> Either String a -decodeModFile bs = case decodeOrFail (LB.fromStrict bs) of - Left (_, _, s) -> Left s - Right (_, _, mf) -> Right mf +-- | Convert a strict ByteString to a ModFile, if possible. Revert the +-- String aliases according to the StringMap. +decodeModFile :: LB.ByteString -> Either String ModFile +decodeModFile bs = case decodeOrFail bs of + Left (_, _, s) -> Left s + Right (_, _, mf) -> Right (revertStringMap sm mf { mfStringMap = M.empty }) { mfStringMap = sm } + where sm = mfStringMap mf -- | Extract the combined module map from a set of ModFiles. Useful -- for parsing a Fortran file in a large context of other modules. @@ -167,6 +183,14 @@ combinedDeclMap :: ModFiles -> DeclMap combinedDeclMap = M.unions . map mfDeclMap +-- | Extract the combined string map of ModFiles. Mainly internal use. +combinedStringMap :: ModFiles -> StringMap +combinedStringMap = M.unions . map mfStringMap + +-- | Extract the combined string map of ModFiles. Mainly internal use. +combinedParamVarMap :: ModFiles -> ParamVarMap +combinedParamVarMap = M.unions . map mfParamVarMap + -- | Get the associated Fortran filename that was used to compile the -- ModFile. moduleFilename :: ModFile -> String @@ -189,10 +213,18 @@ -- | Extract all module maps (name -> environment) by collecting all -- of the stored module maps within the PUModule annotation. extractModuleMap :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> FAR.ModuleMap -extractModuleMap pf = M.fromList [ (n, env) | pu@(F.PUModule {}) <- universeBi pf :: [F.ProgramUnit (FA.Analysis a)] - , let a = F.getAnnotation pu - , let n = F.getName pu - , env <- maybeToList (FA.moduleEnv a) ] +extractModuleMap pf + -- in case there are no modules, store global program unit names under the name 'NamelessMain' + | null mmap = M.singleton F.NamelessMain $ M.unions combinedEnv + | otherwise = M.fromList mmap + where + mmap = [ (n, env) | pu@F.PUModule{} <- childrenBi pf :: [F.ProgramUnit (FA.Analysis a)] + , let a = F.getAnnotation pu + , let n = F.getName pu + , env <- maybeToList (FA.moduleEnv a) ] + combinedEnv = [ env | pu <- childrenBi pf :: [F.ProgramUnit (FA.Analysis a)] + , let a = F.getAnnotation pu + , env <- maybeToList (FA.moduleEnv a) ] -- | Extract map of declared variables with their associated program -- unit and source span. @@ -227,3 +259,41 @@ | otherwise -> error $ "nameAndBlocks: un-named function with no return value! " ++ show (FA.puName pu) ++ " at source-span " ++ show (P.getSpan pu) F.PUBlockData _ _ _ b -> (DCBlockData, Nothing, b) F.PUComment {} -> (DCBlockData, Nothing, []) -- no decls inside of comments, so ignore it + +-- | Extract a string map from the given data, leaving behind aliased +-- values in place of strings in the returned version. +extractStringMap :: Data a => a -> (a, StringMap) +extractStringMap x = fmap (inv . fst) . flip runState (M.empty, 0) $ descendBiM f x + where + inv = M.fromList . map (\ (a,b) -> (b,a)) . M.toList + f :: String -> State (StringMap, Int) String + f s = do + (m, n) <- get + case M.lookup s m of + Just s' -> return s' + Nothing -> do + let s' = '@':show n + put (M.insert s s' m, n + 1) + return s' + +-- | Rewrite the data with the string map aliases replaced by the +-- actual values (implicitly sharing structure). +revertStringMap :: Data a => StringMap -> a -> a +revertStringMap sm = descendBi (\ s -> s `fromMaybe` M.lookup s sm) + +-- | Extract a map of variables assigned to constant values. +extractParamVarMap :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> ParamVarMap +extractParamVarMap pf = M.fromList cvm + where + pf' = FAD.analyseConstExps $ FAB.analyseBBlocks pf + cvm = [ (FA.varName v, con) + | F.PUModule _ _ _ bs _ <- universeBi pf' :: [F.ProgramUnit (FA.Analysis a)] + , st@(F.StDeclaration _ _ (F.TypeSpec _ _ _ _) _ _) <- universeBi bs :: [F.Statement (FA.Analysis a)] + , F.AttrParameter _ _ <- universeBi st :: [F.Attribute (FA.Analysis a)] + , (F.DeclVariable _ _ v _ _) <- universeBi st :: [F.Declarator (FA.Analysis a)] + , Just con <- [FA.constExp (F.getAnnotation v)] ] ++ + [ (FA.varName v, con) + | F.PUModule _ _ _ bs _ <- universeBi pf' :: [F.ProgramUnit (FA.Analysis a)] + , st@F.StParameter {} <- universeBi bs :: [F.Statement (FA.Analysis a)] + , (F.DeclVariable _ _ v _ _) <- universeBi st :: [F.Declarator (FA.Analysis a)] + , Just con <- [FA.constExp (F.getAnnotation v)] ] 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 @@ -16,26 +16,40 @@ getPos :: a -> Position data Position = Position - { posAbsoluteOffset :: {-# UNPACK #-} !Int - , posColumn :: {-# UNPACK #-} !Int - , posLine :: {-# UNPACK #-} !Int + { posAbsoluteOffset :: Int + , posColumn :: Int + , posLine :: Int + , filePath :: String + , posPragmaOffset :: Maybe (Int, String) -- ^ line-offset and filename as given by a pragma. } deriving (Eq, Ord, Data, Typeable, Generic) instance Binary Position instance Show Position where - show (Position _ c l) = show l ++ ':' : show c + show (Position _ c l _ _) = show l ++ ':' : show c initPosition :: Position initPosition = Position { posAbsoluteOffset = 0 , posColumn = 1 , posLine = 1 + , filePath = "" + , posPragmaOffset = Nothing } lineCol :: Position -> (Int, Int) -lineCol p = (fromIntegral $ posLine p, fromIntegral $ posColumn p) +lineCol p = (fromIntegral $ posLine p, fromIntegral $ posColumn p) +-- | (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) + +-- | Path of file taking into account any specified line pragmas. +apparentFilePath :: Position -> String +apparentFilePath p | Just (_, f) <- posPragmaOffset p = f + | otherwise = filePath p + data SrcSpan = SrcSpan Position Position deriving (Eq, Ord, Typeable, Data, Generic) instance Binary SrcSpan @@ -49,12 +63,16 @@ -- Difference between the column of the upper and lower positions in a span columnDistance :: SrcSpan -> Int -columnDistance (SrcSpan (Position _ c1 _) (Position _ c2 _)) = c2 - c1 +columnDistance (SrcSpan (Position _ c1 _ _ _) (Position _ c2 _ _ _)) = c2 - c1 -- Difference between the lines of the upper and lower positions in a span lineDistance :: SrcSpan -> Int -lineDistance (SrcSpan (Position _ _ l1) (Position _ _ l2)) = l2 - l1 +lineDistance (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = l2 - l1 +-- List of lines that are spanned +spannedLines :: SrcSpan -> [Int] +spannedLines (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = [l1..l2] + initSrcSpan :: SrcSpan initSrcSpan = SrcSpan initPosition initPosition @@ -67,7 +85,7 @@ setSpan :: SrcSpan -> a -> a default getSpan :: (SecondParameter a SrcSpan) => a -> SrcSpan - getSpan a = getSecondParameter a + getSpan = getSecondParameter default setSpan :: (SecondParameter a SrcSpan) => SrcSpan -> a -> a - setSpan e a = setSecondParameter e a + setSpan = setSecondParameter 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,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,10 +13,10 @@ setSecondParameter :: e -> a -> a default getSecondParameter :: (Generic a, GSecondParameter (Rep a) e) => a -> e - getSecondParameter a = getSecondParameter' . from $ a + getSecondParameter = getSecondParameter' . from default setSecondParameter :: (Generic a, GSecondParameter (Rep a) e) => e -> a -> a - setSecondParameter e a = to . setSecondParameter' e . from $ a + setSecondParameter e = to . setSecondParameter' e . from class GSecondParameter f e where getSecondParameter' :: f a -> e @@ -63,7 +62,7 @@ instance {-# OVERLAPPING #-} GSecondParameter' (K1 i e) e where getSecondParameter'' (K1 a) = a - setSecondParameter'' e (K1 a) = K1 e + setSecondParameter'' e (K1 _) = K1 e instance {-# OVERLAPPABLE #-} GSecondParameter' (K1 i a) e where getSecondParameter'' _ = undefined diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,35 +1,38 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Main where import Prelude hiding (readFile) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (replace) import Text.PrettyPrint (render) -import Text.Read import System.Console.GetOpt - +import System.IO import System.Environment import System.Directory import System.FilePath import Text.PrettyPrint.GenericPretty (pp, pretty, Out) -import Data.List (isInfixOf, intercalate, (\\)) +import Text.Read (readMaybe) +import Data.List (sortBy, intercalate, (\\), isSuffixOf) +import Data.Ord (comparing) import Data.Char (toLower) -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (listToMaybe, fromMaybe, maybeToList) import Data.Data -import Data.Binary import Data.Generics.Uniplate.Data -import Language.Fortran.ParserMonad (FortranVersion(..), fromRight) +import Language.Fortran.ParserMonad (selectFortranVersion, FortranVersion(..), fromRight) import qualified Language.Fortran.Lexer.FixedForm as FixedForm (collectFixedTokens, Token(..)) import qualified Language.Fortran.Lexer.FreeForm as FreeForm (collectFreeTokens, Token(..)) import Language.Fortran.Parser.Any import Language.Fortran.Util.ModFile +import Language.Fortran.Util.Position import Language.Fortran.PrettyPrint import Language.Fortran.Analysis @@ -38,13 +41,14 @@ import Language.Fortran.Analysis.BBlocks import Language.Fortran.Analysis.DataFlow import Language.Fortran.Analysis.Renaming -import Data.Graph.Inductive hiding (trc) +import Data.Graph.Inductive hiding (trc, mf, version) import qualified Data.IntMap as IM import qualified Data.Map as M import Control.Monad import Text.Printf +programName :: String programName = "fortran-src" main :: IO () @@ -52,38 +56,32 @@ args <- getArgs (opts, parsedArgs) <- compileArgs args case (parsedArgs, action opts) of - ([path], DumpModFile) -> do - let path = head parsedArgs - contents <- B.readFile path - case decodeModFile contents of - Left msg -> putStrLn $ "Error: " ++ msg - Right mf -> putStrLn $ "Filename: " ++ moduleFilename mf ++ - "\n\nModuleMap:\n" ++ showModuleMap (combinedModuleMap [mf]) ++ - "\n\nTypeEnv:\n" ++ showTypes (combinedTypeEnv [mf]) ++ - "\n\nDeclMap:\n" ++ showGenericMap (combinedDeclMap [mf]) ++ - "\n\nOther Data Labels: " ++ show (getLabelsModFileData mf) - ([path], actionOpt) -> do - let path = head parsedArgs contents <- flexReadFile path let version = fromMaybe (deduceVersion path) (fortranVersion opts) let (Just parserF0) = lookup version parserWithModFilesVersions - let parserF = \m b s -> fromRight (parserF0 m b s) + let parserF m b s = fromRight (parserF0 m b s) let outfmt = outputFormat opts mods <- decodeModFiles $ includeDirs opts let mmap = combinedModuleMap mods let tenv = combinedTypeEnv mods + let pvm = combinedParamVarMap mods - let runInfer pf = analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis $ pf + let runTypes = analyseAndCheckTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis let runRenamer = stripAnalysis . rename . analyseRenamesWithModuleMap mmap . initAnalysis let runBBlocks pf = showBBlocks pf' ++ "\n\n" ++ showDataFlow pf' - where pf' = analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf + where pf' = analyseParameterVars pvm . analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf let runSuperGraph pf | outfmt == DOT = superBBGrToDOT sgr | otherwise = superGraphDataFlow pf' sgr - where pf' = analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf + where pf' = analyseParameterVars pvm . analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf bbm = genBBlockMap pf' sgr = genSuperBBGr bbm - + let runCompile = encodeModFile . genModFile . fst . analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis + let findBlockPU pf astBlockId = listToMaybe + [ pu | pu <- universeBi pf :: [ProgramUnit (Analysis A0)] + , bbgr <- maybeToList (bBlocks (getAnnotation pu)) + , b <- concatMap snd $ labNodes (bbgrGr bbgr) + , insLabel (getAnnotation b) == Just astBlockId ] case actionOpt of Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended, Fortran77Legacy ] -> print $ FixedForm.collectFixedTokens version contents @@ -91,57 +89,127 @@ print $ FreeForm.collectFreeTokens version contents Lex -> ioError $ userError $ usageInfo programName options Parse -> pp $ parserF mods contents path - Typecheck -> printTypes . extractTypeEnv . fst . runInfer $ parserF mods contents path + Typecheck -> let (pf, _, errs) = runTypes (parserF mods contents path) in + printTypeErrors errs >> printTypes (extractTypeEnv pf) Rename -> pp . runRenamer $ parserF mods contents path BBlocks -> putStrLn . runBBlocks $ parserF mods contents path SuperGraph -> putStrLn . runSuperGraph $ parserF mods contents path Reprint -> putStrLn . render . flip (pprint version) (Just 0) $ parserF mods contents path - + Compile -> do + let bytes = runCompile $ parserF mods contents path + let fspath = path <.> modFileSuffix + LB.writeFile fspath bytes + DumpModFile -> do + let path' = if modFileSuffix `isSuffixOf` path then path else path <.> modFileSuffix + contents' <- LB.readFile path' + case decodeModFile contents' of + Left msg -> putStrLn $ "Error: " ++ msg + Right mf -> putStrLn $ "Filename: " ++ moduleFilename mf ++ + "\n\nStringMap:\n" ++ showStringMap (combinedStringMap [mf]) ++ + "\n\nModuleMap:\n" ++ showModuleMap (combinedModuleMap [mf]) ++ + "\n\nDeclMap:\n" ++ showGenericMap (combinedDeclMap [mf]) ++ + "\n\nTypeEnv:\n" ++ showTypes (combinedTypeEnv [mf]) ++ + "\n\nParamVarMap:\n" ++ showGenericMap (combinedParamVarMap [mf]) ++ + "\n\nOther Data Labels: " ++ show (getLabelsModFileData mf) + ShowFlows isFrom isSuper astBlockId -> do + let pf = analyseParameterVars pvm . + analyseBBlocks . + analyseRenamesWithModuleMap mmap . + initAnalysis $ parserF mods contents path + let bbm = genBBlockMap pf + case (isSuper, findBlockPU pf astBlockId) of + (False, Nothing) -> fail "Couldn't find given AST block ID number." + (False, Just pu) + | Just bbgr <- M.lookup (puName pu) bbm -> + putStrLn $ showFlowsDOT pf bbgr astBlockId isFrom + | otherwise -> do + print $ M.keys bbm + fail $ "Internal error: Program Unit " ++ show (puName pu) ++ " is lacking a basic block graph." + (True, _) -> do + let sgr = genSuperBBGr bbm + putStrLn $ showFlowsDOT pf (superBBGrGraph sgr) astBlockId isFrom + ShowBlocks mlinenum -> do + let pf = analyseBBlocks . + analyseRenamesWithModuleMap mmap . + initAnalysis $ parserF mods contents path + let f :: ([ASTBlockNode], Int) -> ([ASTBlockNode], Int) -> ([ASTBlockNode], Int) + f (nodes1, len1) (nodes2, len2) + | len1 < len2 = (nodes1, len1) + | len2 < len1 = (nodes2, len2) + | otherwise = (nodes1 ++ nodes2, len1) + let lineMap :: IM.IntMap ([ASTBlockNode], Int) -- ([list of IDs], line-distance of span) + lineMap = IM.fromListWith f [ + (l, ([i], lineDistance ss)) + | b <- universeBi pf :: [Block (Analysis A0)] + , i <- maybeToList . insLabel $ getAnnotation b + , let ss = getSpan b + , l <- spannedLines ss + ] + case mlinenum of + Just l -> putStrLn . unwords . map show $ fromMaybe [] (fst <$> IM.lookup l lineMap) + Nothing -> do + let lineBs = B.lines contents + let maxLen = maximum (0:map B.length lineBs) + forM_ (zip lineBs [1..]) $ \ (line, l) -> do + let nodeIDs = fromMaybe [] (fst <$> IM.lookup l lineMap) + let nodeStr = B.intercalate "," (map (B.pack . ('B':) . show) nodeIDs) + let suffix | null nodeIDs = "" + | otherwise = B.replicate (maxLen - B.length line + 1) ' ' <> "!" <> nodeStr + B.putStrLn $ line <> suffix _ -> fail $ usageInfo programName options --- List files in dir +-- List files in dir recursively rGetDirContents :: String -> IO [String] rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d' where - go seen d = do - ds <- getDirectoryContents d + go seen d'' = do + ds <- getDirectoryContents d'' fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries where f x = do path <- canonicalizePath $ d ++ "/" ++ x g <- doesDirectoryExist path - if g && not (path `elem` seen) then do + if g && notElem path seen then do x' <- go (path : seen) path return $ map (\ y -> x ++ "/" ++ y) x' else return [x] +-- List files in dir +getDirContents :: String -> IO [String] +getDirContents d = do + d' <- canonicalizePath d + map (d' ) `fmap` listDirectory d' + decodeModFiles :: [String] -> IO ModFiles decodeModFiles = foldM (\ modFiles d -> do -- Figure out the camfort mod files and parse them. - modFileNames <- filter isModFile `fmap` rGetDirContents d + modFileNames <- filter isModFile `fmap` getDirContents d addedModFiles <- forM modFileNames $ \ modFileName -> do - eResult <- decodeFileOrFail (d modFileName) - case eResult of - Left (offset, msg) -> do - putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg + contents <- LB.readFile (d modFileName) + case decodeModFile contents of + Left msg -> do + hPutStrLn stderr $ modFileName ++ ": Error: " ++ msg return emptyModFile Right modFile -> do - putStrLn $ modFileName ++ ": successfully parsed precompiled file." + hPutStrLn stderr $ modFileName ++ ": successfully parsed precompiled file." return modFile return $ addedModFiles ++ modFiles ) emptyModFiles +isModFile :: FilePath -> Bool isModFile = (== modFileSuffix) . takeExtension superGraphDataFlow :: forall a. (Out a, Data a) => ProgramFile (Analysis a) -> SuperBBGr (Analysis a) -> String -superGraphDataFlow pf sgr = showBBGr (nmap (map (fmap insLabel)) gr) ++ "\n\n" ++ replicate 50 '-' ++ "\n\n" ++ +superGraphDataFlow pf sgr = showBBGr (bbgrMap (nmap (map (fmap insLabel))) gr') ++ "\n\n" ++ replicate 50 '-' ++ "\n\n" ++ show entries ++ "\n\n" ++ replicate 50 '-' ++ "\n\n" ++ - dfStr gr + dfStr gr' where - gr = superBBGrGraph sgr + gr' = superBBGrGraph sgr entries = superBBGrEntries sgr dfStr gr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [ ("callMap", show cm) + , ("entries", show (bbgrEntries gr)) + , ("exits", show (bbgrExits gr)) , ("postOrder", show (postOrder gr)) , ("revPostOrder", show (revPostOrder gr)) , ("revPreOrder", show (revPreOrder gr)) @@ -151,22 +219,22 @@ , ("lva", show (IM.toList $ lva gr)) , ("rd", show (IM.toList rDefs)) , ("backEdges", show bedges) - , ("topsort", show (topsort gr)) - , ("scc ", show (scc gr)) - , ("loopNodes", show (loopNodes bedges gr)) + , ("topsort", show (topsort $ bbgrGr gr)) + , ("scc ", show (scc $ bbgrGr gr)) + , ("loopNodes", show (loopNodes bedges $ bbgrGr gr)) , ("duMap", show (genDUMap bm dm gr rDefs)) , ("udMap", show (genUDMap bm dm gr rDefs)) , ("flowsTo", show (edges flTo)) , ("varFlowsTo", show (genVarFlowsToMap dm flTo)) , ("ivMap", show (genInductionVarMap bedges gr)) - , ("noPredNodes", show (noPredNodes gr)) , ("blockMap", unlines [ "AST-block " ++ show i ++ ":\n" ++ pretty b | (i, b) <- IM.toList bm ]) , ("derivedInd", unlines [ "Expression " ++ show i ++ " (IE: " ++ show ie ++ "):\n" ++ pretty e | e <- universeBi bm :: [Expression (Analysis a)] , i <- maybeToList (insLabel (getAnnotation e)) , let ie = IM.lookup i diMap ]) + , ("constExpMap", show (genConstExpMap pf)) ] where - bedges = genBackEdgeMap (dominators gr) gr + bedges = genBackEdgeMap (dominators gr) $ bbgrGr gr flTo = genFlowsToGraph bm dm gr rDefs rDefs = rd gr diMap = genDerivedInductionMap bedges gr @@ -178,7 +246,8 @@ showGenericMap :: (Show a, Show b) => M.Map a b -> String showGenericMap = unlines . map (\ (k, v) -> show k ++ " : " ++ show v) . M.toList - +showStringMap :: StringMap -> String +showStringMap = showGenericMap showModuleMap :: ModuleMap -> String showModuleMap = concatMap (\ (n, m) -> show n ++ ":\n" ++ (unlines . map (" "++) . lines . showGenericMap $ m)) . M.toList showTypes :: TypeEnv -> String @@ -186,13 +255,20 @@ printf "%s\t\t%s %s\n" name (drop 4 $ maybe " -" show vt) (drop 2 $ maybe " " show ct) printTypes :: TypeEnv -> IO () printTypes = putStrLn . showTypes +showTypeErrors :: [TypeError] -> String +showTypeErrors errs = unlines [ show ss ++ ": " ++ msg | (msg, ss) <- sortBy (comparing snd) errs ] +printTypeErrors :: [TypeError] -> IO () +printTypeErrors = putStrLn . showTypeErrors -data Action = Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile deriving Eq +data Action + = Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile | Compile + | ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) + deriving Eq instance Read Action where readsPrec _ value = - let options = [ ("lex", Lex) , ("parse", Parse) ] in - tryTypes options + let options' = [ ("lex", Lex) , ("parse", Parse) ] in + tryTypes options' where tryTypes [] = [] tryTypes ((attempt,result):xs) = @@ -206,13 +282,14 @@ , outputFormat :: OutputFormat , includeDirs :: [String] } +initOptions :: Options initOptions = Options Nothing Parse Default [] options :: [OptDescr (Options -> Options)] options = - [ Option ['v'] + [ Option ['v','F'] ["fortranVersion"] - (ReqArg (\v opts -> opts { fortranVersion = readMaybe v }) "VERSION") + (ReqArg (\v opts -> opts { fortranVersion = selectFortranVersion v }) "VERSION") "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]" , Option ['a'] ["action"] @@ -250,6 +327,29 @@ ["include-dir"] (ReqArg (\ d opts -> opts { includeDirs = d:includeDirs opts }) "DIR") "directory to search for precompiled 'mod files'" + , Option ['c'] + ["compile"] + (NoArg $ \ opts -> opts { action = Compile }) + "compile an .fsmod file from the input" + , Option [] + ["show-block-numbers"] + (OptArg (\a opts -> opts { action = ShowBlocks (a >>= readMaybe) } + ) "LINE-NUM") + "Show the corresponding AST-block identifier number next to every line of code." + , Option [] + ["show-flows-to"] + (ReqArg (\a opts -> case a of s:num | toLower s == 's' -> opts { action = ShowFlows False True (read num) } + b:num | toLower b == 'b' -> opts { action = ShowFlows False False (read num) } + num -> opts { action = ShowFlows False False (read num) } + ) "AST-BLOCK-ID") + "dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph" + , Option [] + ["show-flows-from"] + (ReqArg (\a opts -> case a of s:num | toLower s == 's' -> opts { action = ShowFlows True True (read num) } + b:num | toLower b == 'b' -> opts { action = ShowFlows True False (read num) } + num -> opts { action = ShowFlows True False (read num) } + ) "AST-BLOCK-ID") + "dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph" ] compileArgs :: [ String ] -> IO (Options, [ String ]) @@ -258,24 +358,7 @@ (o, n, []) -> return (foldl (flip id) initOptions o, n) (_, _, errors) -> ioError $ userError $ concat errors ++ usageInfo header options where - header = "Usage: forpar [OPTION...] " - -instance Read FortranVersion where - readsPrec _ value = tryTypes options - where - value' = map toLower value - options = [ ("66" , Fortran66) - , ("77e", Fortran77Extended) - , ("77l", Fortran77Legacy) - , ("77" , Fortran77) - , ("90" , Fortran90) - , ("95" , Fortran95) - , ("03" , Fortran2003) - , ("08" , Fortran2008) ] - tryTypes [] = [] - tryTypes ((attempt,result):xs) - | attempt `isInfixOf` value' = [(result, "")] - | otherwise = tryTypes xs + header = "Usage: " ++ programName ++ " [OPTION...] " instance {-# OVERLAPPING #-} Show [ FixedForm.Token ] where show = unlines . lines' diff --git a/test/Language/Fortran/Analysis/BBlocksSpec.hs b/test/Language/Fortran/Analysis/BBlocksSpec.hs --- a/test/Language/Fortran/Analysis/BBlocksSpec.hs +++ b/test/Language/Fortran/Analysis/BBlocksSpec.hs @@ -1,11 +1,9 @@ module Language.Fortran.Analysis.BBlocksSpec where import Test.Hspec -import TestUtil import Language.Fortran.Parser.Fortran77 -import Language.Fortran.Lexer.FixedForm (initParseState) -import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.ParserMonad (fromParseResultUnsafe) import Language.Fortran.AST import Language.Fortran.Analysis import Language.Fortran.Analysis.BBlocks @@ -13,7 +11,6 @@ import qualified Data.Map as M import qualified Data.IntSet as IS import Data.Graph.Inductive -import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Maybe import qualified Data.ByteString.Char8 as B @@ -25,34 +22,27 @@ spec = describe "Basic Blocks" $ do describe "loop4" $ do - it "nodes and edges length" $ do - let pf = pParser programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf - let ns = nodes gr - let es = edges gr + let pf = pParser programLoop4 + gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + ns = nodes $ bbgrGr gr + es = edges $ bbgrGr gr + nodeSet = IS.fromList ns + it "nodes and edges length" $ (length ns, length es) `shouldBe` (11, 12) - it "branching nodes" $ do - let pf = pParser programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + it "branching nodes" $ (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20])) `shouldBe` (2, 2) it "all reachable" $ do - let pf = pParser programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf - let reached = IS.fromList $ dfs [0] gr - let nodeSet = IS.fromList $ nodes gr + let reached = IS.fromList . dfs [0] $ bbgrGr gr reached `shouldBe` nodeSet it "all terminate" $ do - let pf = pParser programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf - let reached = IS.fromList $ rdfs [-1] gr - let nodeSet = IS.fromList $ nodes gr + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr reached `shouldBe` nodeSet describe "if arith" $ do it "nodes and edges length" $ do let pf = pParser programArithIf let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf - let ns = nodes gr - let es = edges gr + let ns = nodes $ bbgrGr gr + let es = edges $ bbgrGr gr (length ns, length es) `shouldBe` (6, 7) it "branching nodes" $ do let pf = pParser programArithIf @@ -61,15 +51,83 @@ it "all reachable" $ do let pf = pParser programArithIf let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf - let reached = IS.fromList $ dfs [0] gr - let nodeSet = IS.fromList $ nodes gr + let reached = IS.fromList . dfs [0] $ bbgrGr gr + let nodeSet = IS.fromList . nodes $ bbgrGr gr reached `shouldBe` nodeSet it "all terminate" $ do let pf = pParser programArithIf let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf - let reached = IS.fromList $ rdfs [-1] gr - let nodeSet = IS.fromList $ nodes gr + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr + let nodeSet = IS.fromList . nodes $ bbgrGr gr reached `shouldBe` nodeSet + describe "gotos" $ do + let pf = pParser programGotos + gr = fromJust . M.lookup (Named "_gotos1") $ genBBlockMap pf + ns = nodes $ bbgrGr gr + es = edges $ bbgrGr gr + nodeSet = IS.fromList ns + it "nodes and edges length" $ do + (length ns, length es) `shouldBe` (10, 12) + it "branching nodes" $ + (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20])) `shouldBe` (3, 1) + it "all reachable" $ do + let reached = IS.fromList . dfs [0] $ bbgrGr gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr + reached `shouldBe` nodeSet + describe "READ" $ do + let pf = pParser programRead + gr = fromJust . M.lookup (Named "reading_time") $ genBBlockMap pf + ns = nodes $ bbgrGr gr + es = edges $ bbgrGr gr + nodeSet = IS.fromList ns + it "nodes and edges length" $ do + (length ns, length es) `shouldBe` (10, 11) + it "branching nodes" $ do + let succs l = IS.size $ findSuccsBB gr [l] + (succs 10, succs 20, succs 40, succs 60) `shouldBe` (3, 1, 1, 1) + it "all reachable" $ do + let reached = IS.fromList . dfs [0] $ bbgrGr gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr + reached `shouldBe` nodeSet + describe "Leading zero labels" $ do + let pf = pParser programZeroLabels + gr = fromJust . M.lookup (Named "zero_labels") $ genBBlockMap pf + ns = nodes $ bbgrGr gr + es = edges $ bbgrGr gr + nodeSet = IS.fromList ns + it "nodes and edges length" $ do + (length ns, length es) `shouldBe` (13, 15) + it "branching nodes" $ do + let succs l = IS.size $ findSuccsBB gr [l] + (succs 10, succs 20, succs 40, succs 60, succs 80) `shouldBe` (4, 1, 1, 1, 1) + it "all reachable" $ do + let reached = IS.fromList . dfs [0] $ bbgrGr gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr + reached `shouldBe` nodeSet + describe "nested calls" $ do + let pf = pParser programNestedCalls + gr = fromJust . M.lookup (Named "nestedcall") $ genBBlockMap pf + ns = nodes $ bbgrGr gr + es = edges $ bbgrGr gr + nodeSet = IS.fromList ns + it "nodes and edges length" $ do + (length ns, length es) `shouldBe` (10, 9) + -- it "branching nodes" $ + -- (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20])) `shouldBe` (3, 1) + it "all reachable" $ do + let reached = IS.fromList . dfs [0] $ bbgrGr gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let reached = IS.fromList . rdfs [-1] $ bbgrGr gr + reached `shouldBe` nodeSet + it "straight-line program" $ do + [ length (suc (bbgrGr gr) n) | n <- ns, n /= -1 ] `shouldSatisfy` all (== 1) -------------------------------------------------- -- Label-finding helper functions to help write tests that are @@ -86,11 +144,12 @@ -- For each label in the list, find the successors of the -- corresponding basic block, return as an IntSet. findSuccsBB :: BBGr a -> [Int] -> IS.IntSet -findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show) +findSuccsBB gr = IS.fromList . concatMap (suc $ bbgrGr gr) . mapMaybe (flip findLabeledBBlock gr . show) -------------------------------------------------- -- Test programs +programLoop4 :: String programLoop4 = unlines [ " program loop4" , " integer r, i, j" @@ -117,6 +176,7 @@ , " end" ] +programArithIf :: String programArithIf = unlines [ " program arithif" , " integer n" @@ -126,6 +186,58 @@ , " 20 write (*,*) 20" , " 30 write (*,*) 30" , " end"] + +programGotos :: String +programGotos = unlines [ + " subroutine gotos(s)" + , " integer s" + , " character a" + , " a = 'H'" + , " 10 goto (30, 40) s" + , " 20 goto 999" + , " 30 continue" + , " if (a .eq. 'G') then" + , " print *, 'almost there'" + , " endif" + , " 40 continue" + , "999 print *, 'all done'" + , " end" ] + +programRead :: String +programRead = unlines [ + " program reading_time" + , " integer i" + , " 10 read(*, *, END=30, ERR=50) i" + , " 20 goto 70" + , " 30 print *, 'end'" + , " 40 goto 70" + , " 50 print *, 'err'" + , " 60 goto 70" + , " 70 print *, 'done'" + , " print *, i" + , " end" ] + +programZeroLabels :: String +programZeroLabels = unlines [ + " program zero_labels" + , " integer i" + , " 10 goto (30, 50, 70) i" + , " 20 goto 999" + , " 30 print *, '30'" + , " 40 goto 900" + , " 050 print *, '050'" + , " 60 goto 900" + , " 070 print *, '070'" + , " 80 goto 0900" + , " 0900 print *, '0900'" + , " 999 continue" + , " end" ] + +programNestedCalls :: String +programNestedCalls = unlines [ + " program nestedcall" + , " call foo(bar(baz(1)))" + , " end" ] -- Local variables: diff --git a/test/Language/Fortran/Analysis/DataFlowSpec.hs b/test/Language/Fortran/Analysis/DataFlowSpec.hs --- a/test/Language/Fortran/Analysis/DataFlowSpec.hs +++ b/test/Language/Fortran/Analysis/DataFlowSpec.hs @@ -6,25 +6,26 @@ import Language.Fortran.Parser.Fortran77 import qualified Language.Fortran.Parser.Fortran90 as F90 -import Language.Fortran.Lexer.FixedForm (initParseState) -import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.ParserMonad (fromParseResultUnsafe) import Language.Fortran.AST import Language.Fortran.Analysis -import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis.Renaming import Language.Fortran.Analysis.BBlocks import Language.Fortran.Analysis.DataFlow import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IntMap as IM import qualified Data.IntSet as IS -import Data.Graph.Inductive -import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Graph.Inductive hiding (version, lab') import Data.Maybe import Data.List import Data.Data import Data.Generics.Uniplate.Operations import qualified Data.ByteString.Char8 as B +import Control.Arrow ((&&&)) +{-# ANN module "HLint: ignore Reduce duplication" #-} + data F77 = F77 data F90 = F90 @@ -42,53 +43,49 @@ withParse :: Data a => Parser t => t -> String -> (ProgramFile (Analysis A0) -> a) -> a withParse version source f = underRenaming (f . analyseBBlocks) (parser version source "") +testGraph :: Parser t => t -> String -> String -> BBGr (Analysis A0) testGraph version f p = fromJust . M.lookup (Named f) . withParse version p $ genBBlockMap +testPfAndGraph :: Parser t => t -> String -> String -> (ProgramFile (Analysis A0), BBGr (Analysis A0)) testPfAndGraph version f p = fmap (fromJust . M.lookup (Named f)) . withParse version p $ \ pf -> (pf, genBBlockMap pf) +testGenDefMap :: Parser t => t -> String -> DefMap testGenDefMap version = flip (withParse version) (genDefMap . genBlockMap . analyseBBlocks . initAnalysis) +testBackEdges :: Parser t => t -> String -> String -> BackEdgeMap testBackEdges version f p = bedges where gr = testGraph version f p domMap = dominators gr - bedges = genBackEdgeMap domMap gr + bedges = genBackEdgeMap domMap $ bbgrGr gr spec :: Spec spec = describe "Dataflow" $ do - ---------------------------------------------- - let pf = pParser F77 programLoop4 describe "loop4" $ do + let pf = pParser F77 programLoop4 + bm = genBlockMap pf + dm = genDefMap bm it "genBackEdgeMap" $ do let gr = testGraph F77 "loop4" programLoop4 testBackEdges F77 "loop4" programLoop4 `shouldBe` IM.fromList [(findLabelBB gr 8, findLabelBB gr 10), (findLabelBB gr 7, findLabelBB gr 20)] + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf it "loopNodes" $ do - let pf = pParser F77 programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - S.fromList (loopNodes bedges gr) `shouldBe` + bedges = genBackEdgeMap domMap $ bbgrGr gr + S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe` S.fromList [findLabelsBB gr [5,6,7,20], IS.unions [findLabelsBB gr [4,5,6,7,8,10,20,30], findSuccsBB gr [20]]] it "genDefMap" $ testGenDefMap F77 programLoop4 `shouldBe` M.fromList [("i",findLabelsBl pf [3,30]),("j",findLabelsBl pf [4,6]),("r",findLabelsBl pf [2,5])] - it "reachingDefinitions" $ do - let pf = pParser F77 programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf - let bm = genBlockMap pf - let dm = genDefMap bm + it "reachingDefinitions" $ IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe` Just (findLabelsBl pf [2,3,4,5,6,30], findLabelsBl pf [3,4,5,6,30]) - it "flowsTo" $ do - let pf = pParser F77 programLoop4 - let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf - let bm = genBlockMap pf - let dm = genDefMap bm + it "flowsTo" $ (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe` -- Find the flows of the assignment statements in the program. findLabelsBlEdges pf [(2,5),(2,40) -- r = 0 @@ -100,33 +97,33 @@ ] ---------------------------------------------- - let pf = pParser F90 programLoop4Alt - let sgr = genSuperBBGr (genBBlockMap pf) - let gr = superBBGrGraph sgr - let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - let bm = genBlockMap pf - let dm = genDefMap bm describe "loop4 alt (module)" $ do + let pf = pParser F90 programLoop4Alt + sgr = genSuperBBGr (genBBlockMap pf) + bm = genBlockMap pf + dm = genDefMap bm + gr = superBBGrGraph sgr + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr it "genBackEdgeMap" $ do - let gr = testGraph F90 "loop4" programLoop4Alt + let gr' = testGraph F90 "loop4" programLoop4Alt testBackEdges F90 "loop4" programLoop4Alt `shouldBe` - IM.fromList [(findLabelBB gr 22, findLabelBB gr 20), (findLabelBB gr 31, findLabelBB gr 10)] + IM.fromList [(findLabelBB gr' 22, findLabelBB gr' 20), (findLabelBB gr' 31, findLabelBB gr' 10)] - it "loopNodes" $ do - S.fromList (loopNodes bedges gr) `shouldBe` + it "loopNodes" $ + S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe` S.fromList [findLabelsBB gr [20,21,22], findLabelsBB gr [10,11,20,21,22,31,40]] it "genDefMap" $ testGenDefMap F90 programLoop4Alt `shouldBe` M.fromList [("i",findLabelsBl pf [2,31]),("j",findLabelsBl pf [11,22]),("r",findLabelsBl pf [1,21])] - it "reachingDefinitions" $ do + it "reachingDefinitions" $ IM.lookup (findLabelBB gr 21) (reachingDefinitions dm gr) `shouldBe` Just (findLabelsBl pf [1,2,11,21,22,31], findLabelsBl pf [2,11,21,22,31]) - it "flowsTo" $ do + it "flowsTo" $ (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe` -- Find the flows of the assignment statements in the program. findLabelsBlEdges pf [(1,21),(1,41) -- r = 0 @@ -140,29 +137,25 @@ ----------------------------------------------- describe "rd3" $ do + let (pf, gr) = testPfAndGraph F77 "f" programRd3 + bm = genBlockMap pf + dm = genDefMap bm it "genBackEdgeMap" $ do - let gr = testGraph F77 "f" programRd3 - testBackEdges F77 "f" programRd3 `shouldBe` IM.singleton (findLabelBB gr 4) (findLabelBB gr 1) + let gr' = testGraph F77 "f" programRd3 + testBackEdges F77 "f" programRd3 `shouldBe` IM.singleton (findLabelBB gr 4) (findLabelBB gr' 1) it "loopNodes" $ do - let (pf, gr) = testPfAndGraph F77 "f" programRd3 let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - S.fromList (loopNodes bedges gr) `shouldBe` + bedges = genBackEdgeMap domMap $ bbgrGr gr + S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe` S.fromList [findLabelsBB gr [1,2,3,4]] - it "reachingDefinitions" $ do - let (pf, gr) = testPfAndGraph F77 "f" programRd3 - let bm = genBlockMap pf - let dm = genDefMap bm + it "reachingDefinitions" $ IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe` Just (IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3]] ,IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3,5]]) - it "flowsTo" $ do - let (pf, gr) = testPfAndGraph F77 "f" programRd3 - let bm = genBlockMap pf - let dm = genDefMap bm + it "flowsTo" $ (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldSatisfy` -- Find the flows of the assignment statements in the program. S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3) -- do 4 i = 2, 10 @@ -170,55 +163,52 @@ ,(3,2),(3,5) -- a(i) = b(i) ]) - describe "rd4" $ do + describe "rd4" $ it "ivMapByASTBlock" $ do - let (pf, gr) = testPfAndGraph F77 "f" programRd4 - let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - let ivMap = genInductionVarMapByASTBlock bedges gr - (sort . map (\ x -> (head x, length x)) . group . sort . map S.size $ IM.elems ivMap) `shouldBe` [(1,3),(2,3)] + let (_, gr) = testPfAndGraph F77 "f" programRd4 + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr + ivMap = genInductionVarMapByASTBlock bedges gr + (sort . map (head &&& length) . group . sort . map S.size $ IM.elems ivMap) `shouldBe` [(1,3),(2,3)] describe "bug36" $ do let pf = pParser F90 programBug36 - let sgr = genSuperBBGr (genBBlockMap pf) - let gr = superBBGrGraph sgr - let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - it "loopNodes" $ do - length (loopNodes bedges gr) `shouldBe` 2 + sgr = genSuperBBGr (genBBlockMap pf) + gr = superBBGrGraph sgr + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr + it "loopNodes" $ + length (loopNodes bedges $ bbgrGr gr) `shouldBe` 2 describe "funcflow1" $ do let pf = pParser F90 programFuncFlow1 - let sgr = genSuperBBGr (genBBlockMap pf) - let gr = superBBGrGraph sgr - let bm = genBlockMap pf - let dm = genDefMap bm - let rDefs = reachingDefinitions dm gr - let flTo = genFlowsToGraph bm dm gr rDefs - let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - let diMap = genDerivedInductionMap bedges gr - it "flowsTo" $ do + sgr = genSuperBBGr (genBBlockMap pf) + gr = superBBGrGraph sgr + bm = genBlockMap pf + dm = genDefMap bm + rDefs = reachingDefinitions dm gr + flTo = genFlowsToGraph bm dm gr rDefs + it "flowsTo" $ (S.fromList . edges . trc $ flTo) `shouldSatisfy` -- Find the flows of the assignment statements in the program. S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)]) describe "funcflow2" $ do let pf = pParser F90 programFuncFlow2 - let sgr = genSuperBBGr (genBBlockMap pf) - let gr = superBBGrGraph sgr - let bm = genBlockMap pf - let dm = genDefMap bm - let rDefs = reachingDefinitions dm gr - let flTo = genFlowsToGraph bm dm gr rDefs - let domMap = dominators gr - let bedges = genBackEdgeMap domMap gr - let diMap = genDerivedInductionMap bedges gr - let (iLabel, iName):_ = [ (fromJust (insLabel a), varName e) + sgr = genSuperBBGr (genBBlockMap pf) + gr = superBBGrGraph sgr + bm = genBlockMap pf + dm = genDefMap bm + rDefs = reachingDefinitions dm gr + flTo = genFlowsToGraph bm dm gr rDefs + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr + diMap = genDerivedInductionMap bedges gr + (iLabel, iName):_ = [ (fromJust (insLabel a), varName e) | e@(ExpValue a _ (ValVariable _)) <- rhsExprs pf, srcName e == "i" ] - let (jLabel, jName):_ = [ (fromJust (insLabel a), varName e) + (jLabel, _):_ = [ (fromJust (insLabel a), varName e) | e@(ExpValue a _ (ValVariable _)) <- lhsExprs pf, srcName e == "j" ] - it "flowsTo" $ do + it "flowsTo" $ (S.fromList . edges . trc $ flTo) `shouldSatisfy` -- Find the flows of the assignment statements in the program. S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)]) @@ -226,10 +216,44 @@ IM.lookup iLabel diMap `shouldBe` Just (IELinear iName 1 0) IM.lookup jLabel diMap `shouldBe` Just (IELinear iName 6 2) - describe "other" $ do - it "dominators on disconnected graph" $ do - dominators (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)] :: Gr () ())) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])] + describe "defUse1" $ do + let pf = pParser F90 programDefUse1 + sgr = genSuperBBGr (genBBlockMap pf) + gr = superBBGrGraph sgr + bm = genBlockMap pf + dm = genDefMap bm + rDefs = reachingDefinitions dm gr + flTo = genFlowsToGraph bm dm gr rDefs + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr + it "backEdges" $ + bedges `shouldBe` IM.fromList [(findLabelBB gr 5, findLabelBB gr 4)] + it "flowsTo" $ + (S.fromList . edges $ flTo) `shouldBe` + -- Find the flows of the assignment statements in the program. + findLabelsBlEdges pf [(1,2),(1,3),(1,5),(2,3),(3,4),(4,5),(5,5)] + describe "defUse2" $ do + let pf = pParser F90 programDefUse2 + sgr = genSuperBBGr (genBBlockMap pf) + gr = superBBGrGraph sgr + bm = genBlockMap pf + dm = genDefMap bm + rDefs = reachingDefinitions dm gr + flTo = genFlowsToGraph bm dm gr rDefs + domMap = dominators gr + bedges = genBackEdgeMap domMap $ bbgrGr gr + it "backEdges" $ + bedges `shouldBe` IM.fromList [(findLabelBB gr 12, findLabelBB gr 11)] + it "flowsTo" $ do + (S.fromList . edges . tc $ flTo) `shouldSatisfy` + -- Find the flows of the assignment statements in the program. + S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(1,12),(2,3),(3,11),(11,12),(12,12)]) + + describe "other" $ + it "dominators on disconnected graph" $ + dominators (BBGr (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)])) [0,5] [3,9]) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])] + -------------------------------------------------- -- Label-finding helper functions to help write tests that are -- insensitive to minor changes to the AST. @@ -245,7 +269,7 @@ -- For each Fortran label in the list, find the successors of the -- corresponding basic block, return as an IntSet. findSuccsBB :: BBGr a -> [Int] -> IS.IntSet -findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show) +findSuccsBB gr = IS.fromList . concatMap (suc $ bbgrGr gr) . mapMaybe (flip findLabeledBBlock gr . show) -- For each Fortran label in the list, find the AST-block label numbers ('insLabel') associated findLabelsBl :: forall a. Data a => ProgramFile (Analysis a) -> [Int] -> IS.IntSet @@ -268,11 +292,12 @@ -- Get the set of AST-block labels found in a given basic block findBBlockBl :: BBGr (Analysis a) -> Int -> IS.IntSet -findBBlockBl gr = IS.fromList . mapMaybe (insLabel . getAnnotation) . concat . maybeToList . lab gr +findBBlockBl gr = IS.fromList . mapMaybe (insLabel . getAnnotation) . concat . maybeToList . lab (bbgrGr gr) -------------------------------------------------- -- Test programs +programLoop4 :: String programLoop4 = unlines [ " program loop4" , " 1 integer r, i, j" @@ -295,6 +320,7 @@ , " end" ] +programLoop4Alt :: String programLoop4Alt = unlines [ " module loopMod" , " implicit none" @@ -325,6 +351,7 @@ , " end module" ] +programRd3 :: String programRd3 = unlines [ " function f(x)" , " integer i, a, b, x, f" @@ -333,7 +360,7 @@ , " 1 do 4 i = 2, 10" , " 2 b(i) = a(i-1) + x" , " 3 a(i) = b(i)" - , " 4 continue" + , " 4 i=i" -- alt. to 'continue' since the latter gets eliminated now , " 5 f = a(10)" , " end" , " program rd3" @@ -345,6 +372,7 @@ , "" ] +programRd4 :: String programRd4 = unlines [ " function f(x)" , " integer i, j, a, b, x, f" @@ -353,9 +381,9 @@ , " do 10 i = 2, 10" , " do 20 j = 2, 10" , " b(i) = a(i-1) + x" - , " 20 continue" + , " 20 j=j" -- alt. to 'continue' since the latter gets eliminated now , " a(i) = b(i)" - , " 10 continue" + , " 10 i=i" -- alt. to 'continue' since the latter gets eliminated now , " f = a(10)" , " end" , " program rd3" @@ -368,6 +396,7 @@ ] -- do not use line numbers +programBug36 :: String programBug36 = unlines [ "program foo" , " implicit none" @@ -381,6 +410,7 @@ , "end program" ] +programFuncFlow1 :: String programFuncFlow1 = unlines [ " program main" , " integer :: i, j" @@ -394,6 +424,7 @@ , " end program main" ] +programFuncFlow2 :: String programFuncFlow2 = unlines [ " program main" , " integer :: i, j" @@ -406,6 +437,35 @@ , " 3 f = k + 1" , " end function f" , " end program main" + ] + +programDefUse1 :: String +programDefUse1 = unlines [ + "program defUse1" + , "1 integer :: x = 1" + , "2 integer :: y = x + 1" + , "3 integer :: z = x * y" + , "4 do y=1,z" + , "5 x = x + y" + , "6 end do" + , "end program defUse1" + ] + +programDefUse2 :: String +programDefUse2 = unlines [ + "program defUse2" + , "1 integer :: x = 1" + , "2 integer :: y = x + 1" + , "3 integer :: z = x * y" + , "4 call s(x)" + , "contains" + , " subroutine s(a)" + , "10 integer :: a" + , "11 do y=1,z" + , "12 a = a + y" + , "13 end do" + , "end subroutine s" + , "end program defUse2" ] -- Local variables: 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 @@ -3,32 +3,33 @@ import Test.Hspec import TestUtil -import Data.Map ((!), elems) +import Data.Map (elems) +--import Data.Data (Data) import qualified Data.Map as M -import Data.List import Language.Fortran.ParserMonad import Language.Fortran.AST -import Language.Fortran.Util.Position import qualified Language.Fortran.Parser.Fortran90 as F90 import Language.Fortran.Analysis -import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis.Renaming import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Data import qualified Data.ByteString.Char8 as B -import Debug.Trace - -testF90 pf = (resetSrcSpan . analyseRenames . initAnalysis) $ pf +--testF90 :: Data a => ProgramFile a -> ProgramFile (Analysis a) +--testF90 pf = (resetSrcSpan . analyseRenames . initAnalysis) $ pf +extractNameMap' :: ProgramFile () -> M.Map String String extractNameMap' = extractNameMap . analyseRenames . initAnalysis +unrename' :: ProgramFile () -> ProgramFile () unrename' = stripAnalysis . unrename . rename . analyseRenames . initAnalysis -renameAndStrip' x = stripAnalysis . rename . analyseRenames . initAnalysis $ x +--renameAndStrip' :: Data a => ProgramFile a -> ProgramFile a +--renameAndStrip' x = stripAnalysis . rename . analyseRenames . initAnalysis $ x -countUnrenamed e = length [ () | ExpValue (Analysis { uniqueName = Nothing }) _ (ValVariable {}) <- uniE_PF e ] +countUnrenamed :: ProgramFile (Analysis ()) -> Int +countUnrenamed e = length [ () | ExpValue Analysis { uniqueName = Nothing } _ ValVariable {} <- uniE_PF e ] where uniE_PF :: ProgramFile (Analysis ()) -> [Expression (Analysis ())] uniE_PF = universeBi +fortran90Parser :: String -> String -> ProgramFile A0 fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file spec :: Spec @@ -43,32 +44,34 @@ ( 1, 2, 2, 2 ) -- Test that every symbol that is supposed to be renamed is renamed. - it "complete ex1" $ do + it "complete ex1" $ countUnrenamed (analyseRenames . initAnalysis $ ex1) `shouldBe` 0 - it "complete ex2" $ do + it "complete ex2" $ countUnrenamed (analyseRenames . initAnalysis $ ex2) `shouldBe` 0 - it "complete ex3" $ do + it "complete ex3" $ countUnrenamed (analyseRenames . initAnalysis $ ex3) `shouldBe` 0 - it "complete ex4" $ do + it "complete ex4" $ countUnrenamed (analyseRenames . initAnalysis $ ex4) `shouldBe` 0 - it "complete ex5" $ do + it "complete ex5" $ countUnrenamed (analyseRenames . initAnalysis $ ex5) `shouldBe` 0 - it "complete ex6" $ do + it "complete ex6" $ countUnrenamed (analyseRenames . initAnalysis $ ex6) `shouldBe` 0 - it "complete ex8" $ do + it "complete ex8" $ countUnrenamed (analyseRenames . initAnalysis $ ex8) `shouldBe` 0 - it "complete ex9" $ do + it "complete ex9" $ countUnrenamed (analyseRenames . initAnalysis $ ex9) `shouldBe` 0 - it "complete ex10" $ do + it "complete ex10" $ countUnrenamed (analyseRenames . initAnalysis $ ex10) `shouldBe` 0 - it "complete ex11" $ do + it "complete ex11" $ countUnrenamed (analyseRenames . initAnalysis $ ex11) `shouldBe` 0 - it "complete ex12" $ do + it "complete ex12" $ countUnrenamed (analyseRenames . initAnalysis $ ex12) `shouldBe` 0 + it "complete ex13" $ + countUnrenamed (analyseRenames . initAnalysis $ ex13Renames) `shouldBe` 0 - it "complete exScope1" $ do + it "complete exScope1" $ countUnrenamed (analyseRenames . initAnalysis $ exScope1) `shouldBe` 0 - it "complete exScope2" $ do + it "complete exScope2" $ countUnrenamed (analyseRenames . initAnalysis $ exScope2) `shouldBe` 0 it "functions 1" $ do @@ -102,7 +105,7 @@ let entry = extractNameMap' exScope2 length (filter (=="x") (elems entry)) `shouldBe` 2 - describe "Ordering" $ do + describe "Ordering" $ it "exScope3 testing out-of-order definitions" $ do let entry = extractNameMap' exScope3 length (filter (=="f1") (elems entry)) `shouldBe` 1 @@ -110,13 +113,25 @@ length (filter (=="s1") (elems entry)) `shouldBe` 1 length (filter (=="s2") (elems entry)) `shouldBe` 1 + describe "Common blocks" $ + it "common1" $ do + let entry = extractNameMap' common1 + length (filter (=="x") (elems entry)) `shouldBe` 2 + M.lookup "c_x_common" entry `shouldBe` Just "x" + M.lookup "c_y_common" entry `shouldBe` Just "y" + -------------------------------------------------- +ex1 :: ProgramFile () ex1 = ProgramFile mi77 [ ex1pu1 ] -ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing +ex1pu1 :: ProgramUnit () +ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" Nothing Nothing [] Nothing +ex2 :: ProgramFile () ex2 = ProgramFile mi77 [ ex2pu1 ] +ex2pu1 :: ProgramUnit () ex2pu1 = PUMain () u (Just "main") ex2pu1bs Nothing +ex2pu1bs :: [Block ()] ex2pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "a") Nothing Nothing @@ -134,8 +149,11 @@ , BlStatement () u Nothing (StExpressionAssign () u (ExpSubscript () u (varGen "d") (AList () u [ ixSinGen 1 ])) (intGen 1)) ] +ex3 :: ProgramFile () ex3 = ProgramFile mi77 [ ex3pu1, ex3pu2 ] +ex3pu1 :: ProgramUnit () ex3pu1 = PUMain () u (Just "main") ex3pu1bs Nothing +ex3pu1bs :: [Block ()] ex3pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "a") Nothing Nothing @@ -154,10 +172,14 @@ (ExpSubscript () u (varGen "c") (AList () u [ ixSinGen 1 ])) (intGen 1)) , BlStatement () u Nothing (StExpressionAssign () u (varGen "d") (ExpBinary () u Addition (varGen "d") (intGen 1))) ] -ex3pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "d", varGen "b"]) Nothing (ex3pu1bs ++ [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "d")) ]) Nothing +ex3pu2 :: ProgramUnit () +ex3pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" (Just $ AList () u [ varGen "d", varGen "b"]) Nothing (ex3pu1bs ++ [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "d")) ]) Nothing +ex4 :: ProgramFile () ex4 = ProgramFile mi77 [ ex4pu1, ex4pu2 ] +ex4pu1 :: ProgramUnit () ex4pu1 = PUMain () u (Just "main") ex4pu1bs Nothing +ex4pu1bs :: [Block ()] ex4pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "f1") Nothing Nothing @@ -166,25 +188,39 @@ (ExpValue () u (ValVariable "r")) (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [ Argument () u Nothing $ intGen 1 ]))) ] -ex4pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing +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 +ex5 :: ProgramFile () ex5 = ProgramFile mi77 [ ex5pu1, ex5pu2 ] +ex5pu1 :: ProgramUnit () ex5pu1 = PUMain () u (Just "main") ex5pu1bs Nothing +ex5pu1bs :: [a] ex5pu1bs = [] +ex5pu2 :: ProgramUnit () ex5pu2 = PUModule () u "ex5mod" ex5pu2bs (Just [ex5pu2pu1]) +ex5pu2bs :: [a] ex5pu2bs = [] -ex5pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing - +ex5pu2pu1 :: ProgramUnit () +ex5pu2pu1 = 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 +ex6 :: ProgramFile () ex6 = ProgramFile mi77 [ ex6pu1, ex6pu2 ] +ex6pu1 :: ProgramUnit () ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing +ex6pu1bs :: [a] ex6pu1bs = [] +ex6pu2 :: ProgramUnit () ex6pu2 = PUModule () u "ex6mod" ex6pu2bs (Just [ex6pu2pu1]) +ex6pu2bs :: [a] ex6pu2bs = [] -ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [Argument () u Nothing (varGen "x")]))) ] (Just [ex5pu2pu1]) +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 (varGen "x")]))) ] (Just [ex5pu2pu1]) -parseF90 = resetSrcSpan . flip fortran90Parser "" . unlines +--parseF90 :: [String] -> ProgramFile A0 +--parseF90 = resetSrcSpan . flip fortran90Parser "" . unlines +ex8 :: ProgramFile A0 ex8 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module m1" , " implicit none" @@ -219,6 +255,7 @@ , "end program main" ] +ex9 :: ProgramFile A0 ex9 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module m1" , " implicit none" @@ -234,20 +271,27 @@ , "end module m1" ] +ex10 :: ProgramFile () ex10 = ProgramFile mi77 [ ex10pu1 ] -ex10pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex10pu1bs Nothing +ex10pu1 :: ProgramUnit () +ex10pu1 = PUSubroutine () u emptyPrefixSuffix "s1" Nothing ex10pu1bs Nothing +ex10pu1bs :: [Block ()] ex10pu1bs = [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ] +ex11 :: ProgramFile () ex11 = ProgramFile mi77 [ ex11pu1 ] -ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1 :: ProgramUnit () +ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) emptyPrefixSuffix "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1bs :: [Block ()] ex11pu1bs = [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ] +ex12 :: ProgramFile A0 ex12 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module m1" , " implicit none" @@ -284,7 +328,45 @@ , "end program main" ] +ex13Renames :: ProgramFile A0 +ex13Renames = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module m1" + , " implicit none" + , " integer :: z" + , "contains" + , " integer function foo ()" + , " foo = 0" + , " end function foo" + , "end module m1" + , "" + , "module m2" + , " implicit none" + , "contains" + , " integer function foo2 (x)" + , " use m1, only: frob => foo" + , " integer :: x" + , " foo2 = frob () + x" + , " end function foo2" + , "end module m2" + , "" + , "module m3" + , " implicit none" + , "contains" + , " integer function foo () result (r)" + , " r = 1" + , " end function foo" + , "end module m3" + , "" + , "program main" + , " use m1, only: z, baz => foo" + , " use m3, only: bar => foo" + , " integer :: x" + , " x = bar () + baz () + z" + , "end program main" + ] + +exScope1 :: ProgramFile A0 exScope1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "program scope1" -- local variables cannot take on the name of subprogram, therefore @@ -300,6 +382,7 @@ , "" ] +exScope2 :: ProgramFile A0 exScope2 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module scope2" , " integer :: x" @@ -329,6 +412,7 @@ , "end program main" ] +exScope3 :: ProgramFile A0 exScope3 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module m1" , " implicit none" @@ -363,6 +447,23 @@ , " integer :: x, f2" , " f2 = x + 1" , "end function f2" + ] + +common1 :: ProgramFile A0 +common1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "program p1" + , " implicit none" + , " integer :: x, y" + , " common /c/ x, y(10)" + , "contains" + , " subroutine s1 ()" + , " call s2 (f1(x))" + , " end subroutine s1" + , " integer function f1(x)" + , " integer :: x, f2" + , " f1 = f2(x)" + , " end function f1" + , "end program p1" ] -- Local variables: diff --git a/test/Language/Fortran/Analysis/TypesSpec.hs b/test/Language/Fortran/Analysis/TypesSpec.hs --- a/test/Language/Fortran/Analysis/TypesSpec.hs +++ b/test/Language/Fortran/Analysis/TypesSpec.hs @@ -6,21 +6,27 @@ import Data.Map ((!)) import Data.Data +import Data.Generics.Uniplate.Data import Language.Fortran.AST import Language.Fortran.Analysis.Types -import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis.Renaming import Language.Fortran.Analysis import qualified Language.Fortran.Parser.Fortran90 as F90 import Language.Fortran.ParserMonad import qualified Data.ByteString.Char8 as B -import Debug.Trace - inferTable :: Data a => ProgramFile a -> TypeEnv inferTable = underRenaming (snd . analyseTypes) +typedProgramFile :: Data a => ProgramFile a -> ProgramFile (Analysis a) +typedProgramFile = fst . analyseTypes . analyseRenames . initAnalysis + +fortran90Parser :: String -> String -> ProgramFile A0 fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file +uniExpr :: ProgramFile (Analysis A0) -> [Expression (Analysis A0)] +uniExpr = universeBi + spec :: Spec spec = do describe "Global type inference" $ do @@ -42,58 +48,141 @@ describe "Local type inference" $ do it "infers from type declarations" $ do let mapping = inferTable ex4 + let pf = typedProgramFile ex4 mapping ! "x" `shouldBe` IDType (Just TypeInteger) (Just CTVariable) - mapping ! "y" `shouldBe` IDType (Just TypeInteger) (Just CTArray) - mapping ! "c" `shouldBe` IDType (Just TypeCharacter) (Just CTVariable) + mapping ! "y" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 10)]) + mapping ! "c" `shouldBe` IDType (Just $ TypeCharacter Nothing Nothing) (Just CTVariable) mapping ! "log" `shouldBe` IDType (Just TypeLogical) (Just CTVariable) + [ () | ExpValue a _ (ValVariable "x") <- uniExpr pf + , idType a == Just (IDType (Just TypeInteger) (Just CTVariable)) ] + `shouldNotSatisfy` null + [ () | ExpValue a _ (ValVariable "y") <- uniExpr pf + , idType a == Just (IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 10)])) ] + `shouldNotSatisfy` null it "infers from dimension declarations" $ do let mapping = inferTable ex5 - mapping ! "x" `shouldBe` IDType Nothing (Just CTArray) - mapping ! "y" `shouldBe` IDType Nothing (Just CTArray) + mapping ! "x" `shouldBe` IDType Nothing (Just $ CTArray [(Nothing, Just 1)]) + mapping ! "y" `shouldBe` IDType Nothing (Just $ CTArray [(Nothing, Just 1)]) it "infers from function statements" $ do let mapping = inferTable ex6 - mapping ! "a" `shouldBe` IDType (Just TypeInteger) (Just CTArray) - mapping ! "b" `shouldBe` IDType (Just TypeInteger) (Just CTArray) + mapping ! "a" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 1)]) + mapping ! "b" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 1)]) mapping ! "c" `shouldBe` IDType (Just TypeInteger) (Just CTFunction) mapping ! "d" `shouldBe` IDType Nothing (Just CTFunction) describe "Intrinsics type analysis" $ do it "disambiguates intrinsics from functions and variables" $ do let mapping = inferTable intrinsics1 - idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic + let pf = typedProgramFile intrinsics1 + [ () | ExpValue a _ (ValVariable "x") <- uniExpr pf + , idType a == Just (IDType (Just TypeReal) (Just CTVariable)) ] + `shouldSatisfy` ((== 5) . length) + + -- the following are true because dabs and cabs are defined as function and array in this program. idCType (mapping ! "dabs") `shouldBe` Just CTFunction - idCType (mapping ! "cabs") `shouldBe` Just CTArray + [ a | ExpValue a _ (ValIntrinsic "dabs") <- uniExpr pf + ] -- , idType a == Just (IDType (Just TypeReal) (Just CTVariable)) ] + `shouldSatisfy` null + idCType (mapping ! "cabs") `shouldBe` Just (CTArray [(Nothing, Just 3)]) + [ a | ExpValue a _ (ValIntrinsic "cabs") <- uniExpr pf + ] -- , idType a == Just (IDType (Just TypeReal) (Just CTVariable)) ] + `shouldSatisfy` null + + -- abs is an actual intrinsic + idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic + [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeInteger) Nothing) ] + `shouldNotSatisfy` null + + it "intrinsics and numeric types" $ do + let mapping = inferTable intrinsics2 + let pf = typedProgramFile intrinsics2 + idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic + idCType (mapping ! "cabs") `shouldBe` Just CTIntrinsic + idCType (mapping ! "dabs") `shouldBe` Just CTIntrinsic + [ ty | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf + , Just (IDType (Just ty) Nothing) <- [idType a] ] + `shouldBe` [TypeDoublePrecision, TypeComplex] + [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "cabs")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeComplex) Nothing) ] + `shouldNotSatisfy` null + [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "dabs")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeDoublePrecision) Nothing) ] + `shouldNotSatisfy` null + + describe "Numeric types" $ do + it "Widening / upgrading" $ do + let pf = typedProgramFile numerics1 + [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeReal) Nothing) ] + `shouldNotSatisfy` null + [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "1")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeComplex) Nothing) ] + `shouldNotSatisfy` null + [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "2")) _ <- uniExpr pf + , idType a == Just (IDType (Just TypeDoublePrecision) Nothing) ] + `shouldNotSatisfy` null + + describe "Character string types" $ + it "examples of various character variables" $ do + let mapping = inferTable teststrings1 + idVType (mapping ! "a") `shouldBe` Just (TypeCharacter (Just (CharLenInt 5)) (Just "1")) + idVType (mapping ! "b") `shouldBe` Just (TypeCharacter (Just (CharLenInt 10)) Nothing) + idVType (mapping ! "c") `shouldBe` Just (TypeCharacter (Just (CharLenInt 3)) (Just "1")) + idVType (mapping ! "d") `shouldBe` Just (TypeCharacter (Just CharLenExp) Nothing) + idCType (mapping ! "d") `shouldBe` Just (CTArray [(Nothing, Just 10)]) + idVType (mapping ! "e") `shouldBe` Just (TypeCharacter (Just (CharLenInt 10)) Nothing) + idCType (mapping ! "e") `shouldBe` Just (CTArray [(Nothing, Just 20)]) + let pf = typedProgramFile teststrings1 + [ () | ExpValue a _ (ValVariable "e") <- uniExpr pf + , idType a == Just (IDType (Just (TypeCharacter (Just (CharLenInt 10)) Nothing)) + (Just (CTArray [(Nothing, Just 20)]))) ] + `shouldNotSatisfy` null + +ex1 :: ProgramFile () ex1 = ProgramFile mi77 [ ex1pu1 ] -ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing +ex1pu1 :: ProgramUnit () +ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" Nothing Nothing [] Nothing +ex2 :: ProgramFile () ex2 = ProgramFile mi77 [ ex2pu1, ex1pu1 ] -ex2pu1 = PUSubroutine () u (None () u False) "s1" Nothing [] Nothing +ex2pu1 :: ProgramUnit () +ex2pu1 = PUSubroutine () u emptyPrefixSuffix "s1" Nothing [] Nothing +ex3 :: ProgramFile () ex3 = ProgramFile mi77 [ ex3pu1 ] -ex3pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex3pu1bs Nothing +ex3pu1 :: ProgramUnit () +ex3pu1 = PUSubroutine () u emptyPrefixSuffix "s1" Nothing ex3pu1bs Nothing +ex3pu1bs :: [Block ()] ex3pu1bs = [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ] +ex4 :: ProgramFile () ex4 = ProgramFile mi77 [ ex4pu1 ] +ex4pu1 :: ProgramUnit () ex4pu1 = PUMain () u Nothing ex4pu1bs Nothing +ex4pu1bs :: [Block ()] ex4pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing , DeclArray () u (varGen "y") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10) ]) Nothing Nothing ])) - , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing + , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing (AList () u [ DeclVariable () u (varGen "c") Nothing Nothing ])) , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeLogical Nothing) Nothing (AList () u [ DeclVariable () u (varGen "log") Nothing Nothing ])) ] +ex5 :: ProgramFile () ex5 = ProgramFile mi77 [ ex5pu1 ] +ex5pu1 :: ProgramUnit () ex5pu1 = PUBlockData () u (Just "bd") ex5pu1bs +ex5pu1bs :: [Block ()] ex5pu1bs = [ BlStatement () u Nothing (StDimension () u (AList () u [ DeclArray () u (varGen "x") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing @@ -109,8 +198,11 @@ - d(x) = 1 - end -} +ex6 :: ProgramFile () ex6 = ProgramFile mi77 [ ex6pu1 ] +ex6pu1 :: ProgramUnit () ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing +ex6pu1bs :: [Block ()] ex6pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "a") Nothing Nothing @@ -127,14 +219,17 @@ , BlStatement () u Nothing (StExpressionAssign () u (ExpSubscript () u (varGen "d") (fromList () [ ixSinGen 1 ])) (intGen 1)) ] +ex11 :: ProgramFile () ex11 = ProgramFile mi77 [ ex11pu1 ] -ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1 :: ProgramUnit () +ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) emptyPrefixSuffix "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1bs :: [Block ()] ex11pu1bs = [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ] - +intrinsics1 :: ProgramFile A0 intrinsics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ "module intrinsics" , "contains" @@ -152,6 +247,56 @@ , " dabs = a" , " end function dabs" , "end module intrinsics" + ] + +intrinsics2 :: ProgramFile A0 +intrinsics2 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module intrinsics" + , "contains" + , " subroutine main()" + , " double precision :: u" + , " complex :: c" + , " real :: x" + , " integer :: y = 1" + , " u = dabs(y + x)" + , " c = cabs(y + x)" + , " u = abs(y + x * u)" + , " c = abs(y + x * c)" + , " print *, x" + , " end subroutine main" + , "end module intrinsics" + ] + +numerics1 :: ProgramFile A0 +numerics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module numerics1" + , "contains" + , " subroutine main()" + , " double precision :: u" + , " complex :: c" + , " real :: x" + , " integer :: y = 1" + , " print *, 1 + (-u * c + abs(y + x))" + , " print *, 2 + f(y)" + , " end subroutine main" + , " double precision function f(a)" + , " integer :: a" + , " f = a" + , " end function f" + , "end module numerics1" + ] + + +teststrings1 :: ProgramFile A0 +teststrings1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "program teststrings" + , " character(5,1) :: a" + , " character :: b*10" + , " character(kind=1,len=3) :: c" + , " integer, parameter :: k = 8" + , " character(k), dimension(10) :: d" + , " character :: e(20)*10" + , "end program teststrings" ] -- Local variables: diff --git a/test/Language/Fortran/AnalysisSpec.hs b/test/Language/Fortran/AnalysisSpec.hs --- a/test/Language/Fortran/AnalysisSpec.hs +++ b/test/Language/Fortran/AnalysisSpec.hs @@ -4,14 +4,9 @@ import TestUtil import Language.Fortran.Parser.Fortran77 -import Language.Fortran.Lexer.FixedForm (initParseState) -import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.ParserMonad (fromParseResultUnsafe) import Language.Fortran.AST import Language.Fortran.Analysis -import Data.Graph.Inductive -import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.List -import Data.Maybe import qualified Data.ByteString.Char8 as B pParser :: String -> ProgramFile (Analysis ()) @@ -21,12 +16,13 @@ spec :: Spec spec = - describe "Analysis" $ do - describe "anal1" $ do + describe "Analysis" $ + describe "anal1" $ it "lhsExprs" $ do let pf = stripAnalysis $ pParser programAnal1 lhsExprs pf `shouldMatchList'` programAnal1LhsExprs +programAnal1LhsExprs :: [Expression ()] programAnal1LhsExprs = [ ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 1 ]) , ExpSubscript () u (ExpValue () u (ValVariable "a")) @@ -38,6 +34,7 @@ , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 6 ]) , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 5 ]) ] +programAnal1 :: String programAnal1 = unlines $ map (replicate 6 ' '++) [ "program anal1" , "integer a, f" diff --git a/test/Language/Fortran/Lexer/FixedFormSpec.hs b/test/Language/Fortran/Lexer/FixedFormSpec.hs --- a/test/Language/Fortran/Lexer/FixedFormSpec.hs +++ b/test/Language/Fortran/Lexer/FixedFormSpec.hs @@ -7,9 +7,6 @@ import Test.Hspec.QuickCheck import TestUtil -import Control.Monad.State.Lazy -import Control.Exception - import Data.List (isPrefixOf) import qualified Data.ByteString.Char8 as B @@ -28,15 +25,16 @@ dropUntil2 [] = Nothing dropUntil2 [_] = Nothing dropUntil2 [a,_] = Just a - dropUntil2 (x:xs) = dropUntil2 xs + dropUntil2 (_:xs) = dropUntil2 xs collectToLexSafe :: FortranVersion -> String -> Maybe Token collectToLexSafe version srcInput = dropUntil2 $ collectFixedTokensSafe version (B.pack srcInput) where dropUntil2 (Just [a,_]) = Just a - dropUntil2 (Just (x:xs)) = dropUntil2 $ Just xs + dropUntil2 (Just (_:xs)) = dropUntil2 $ Just xs dropUntil2 _ = Nothing +collectFixedTokens' :: FortranVersion -> String -> [Token] collectFixedTokens' v = collectFixedTokens v . B.pack spec :: Spec @@ -150,7 +148,7 @@ `shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u] describe "Fortran 77 Legacy" $ do - it "lexes inline comments" $ do + it "lexes inline comments" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer foo ! bar") `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u] @@ -159,27 +157,27 @@ , "C hello" , " + bar" ] - resetSrcSpan (collectFixedTokens' Fortran77Legacy src) - `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + in resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] let src = unlines [ " integer foo, ! hello" , " + bar" ] - resetSrcSpan (collectFixedTokens' Fortran77Legacy src) - `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + in resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] let src = unlines [ " integer foo," , "" , " + bar" ] - resetSrcSpan (collectFixedTokens' Fortran77Legacy src) - `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + in resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] let src = unlines [ " integer foo," , " " -- the space is intentional , " + bar" ] - resetSrcSpan (collectFixedTokens' Fortran77Legacy src) - `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + in resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] - it "lexes the older TYPE statement" $ do + it "lexes the older TYPE statement" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " type *, 'hello'") `shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u] @@ -199,11 +197,11 @@ resetSrcSpan (collectFixedTokens' Fortran77Legacy " character s*(*)") `shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u] - it "lexes strings case-sensitively" $ do + it "lexes strings case-sensitively" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = 'Hello'") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u] - it "lexes strings delimited by '\"'" $ do + it "lexes strings delimited by '\"'" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = \"hello\"") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u] @@ -214,25 +212,25 @@ resetSrcSpan (collectFixedTokens' Fortran77Legacy " x = 7hshort\n") `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short ", TNewline u, TEOF u] - it "lexes BOZ constants" $ do + it "lexes BOZ constants" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i, j, k / b'0101', o'0755', z'ab01' /") `shouldBe` resetSrcSpan [ TType u "integer", TId u "i", TComma u, TId u "j", TComma u, TId u"k" , TSlash u, TBozInt u "b'0101'", TComma u, TBozInt u "o'0755'", TComma u, TBozInt u "z'ab01'", TSlash u , TEOF u ] - it "lexes non-standard identifiers" $ do + it "lexes non-standard identifiers" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer _this_is_a_long_identifier$") `shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u] - it "lexes ';' as a line-terminator" $ do + it "lexes ';' as a line-terminator" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i; integer j") `shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u] - it "lexes subscripts in assignments" $ do + it "lexes subscripts in assignments" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " x(0,0) = 0") `shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u] - it "lexes labeled DO WHILE blocks" $ do + it "lexes labeled DO WHILE blocks" $ resetSrcSpan (collectFixedTokens' Fortran77Legacy " do 10 while (.true.)") `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u ".true.", TRightPar u, TEOF u] @@ -257,6 +255,7 @@ , TEndStructure u, TNewline u , TEOF u ] +example1 :: String example1 = unlines [ " intEGerix", "1 iX= 42", @@ -264,6 +263,7 @@ " 10 wrITe (*,*), ix", " EnD" ] +continuationExample :: String continuationExample = unlines [ " inte", " .ger i", @@ -272,6 +272,7 @@ " .2", " end"] +example1Expectation :: [Token] example1Expectation = [ TType u "integer", TId u "ix", TNewline u, TLabel u "1", TId u "ix", TOpAssign u, TInt u "42", TNewline u, diff --git a/test/Language/Fortran/Lexer/FreeFormSpec.hs b/test/Language/Fortran/Lexer/FreeFormSpec.hs --- a/test/Language/Fortran/Lexer/FreeFormSpec.hs +++ b/test/Language/Fortran/Lexer/FreeFormSpec.hs @@ -3,17 +3,19 @@ import Test.Hspec import TestUtil -import Data.Maybe (fromJust) - import Language.Fortran.ParserMonad (FortranVersion(..)) import Language.Fortran.Lexer.FreeForm (collectFreeTokens, Token(..)) +import Language.Fortran.Util.Position (SrcSpan) import qualified Data.ByteString.Char8 as B -import Debug.Trace - collectF90 :: String -> [ Token ] collectF90 = collectFreeTokens Fortran90 . B.pack +collectF03 :: String -> [ Token ] +collectF03 = collectFreeTokens Fortran2003 . B.pack + + +pseudoAssign :: (SrcSpan -> Token) -> [Token] pseudoAssign token = fmap ($u) [ flip TId "i", TOpAssign, token, TEOF ] spec :: Spec @@ -136,6 +138,25 @@ , TDimension, TLeftPar, flip TIntegerLiteral "2" , TRightPar, TComma, TAllocatable, TDoubleColon , flip TId "y", TEOF ] + + it "try to trick lexer into parsing variables as attributes (1)" $ + shouldBe' (collectF90 "integer save, dimension(10), target") $ + fmap ($u) [ TInteger, flip TId "save", TComma + , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma + , flip TId "target", TEOF ] + + it "try to trick lexer into parsing variables as attributes (2)" $ + shouldBe' (collectF90 "type(foo) save, dimension(10), target") $ + fmap ($u) [ TType, TLeftPar, flip TId "foo", TRightPar, flip TId "save", TComma + , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma + , flip TId "target", TEOF ] + + it "try to trick lexer into parsing variables as attributes (3)" $ + shouldBe' (collectF90 "allocate(type(foo) :: errmsg(stat, source), source=x)") $ + fmap ($u) [ TAllocate, TLeftPar, TType, TLeftPar, flip TId "foo", TRightPar, TDoubleColon + , flip TId "errmsg", TLeftPar, flip TId "stat", TComma, flip TId "source", TRightPar + , TComma, TSource, TOpAssign, flip TId "x", TRightPar, TEOF ] + describe "Character" $ do it "lexes single quote literal" $ shouldBe' (collectF90 "character c = 'heL\"Lo ''daRLing'") $ @@ -261,3 +282,87 @@ it "Empty comment" $ shouldBe' (collectF90 "!\n") $ ($u) <$> [ flip TComment "", TNewline , TEOF ] + + describe "Subscripting" $ do + it "Strings nested in arrays" $ + shouldBe' (collectF90 "a(1)(2:3) = 'we'") $ + ($u) <$> [ flip TId "a", TLeftPar, flip TIntegerLiteral "1", TRightPar + , TLeftPar, flip TIntegerLiteral "2", TColon, flip TIntegerLiteral "3", TRightPar + , TOpAssign, flip TString "we", TEOF ] + + describe "Fortran95" $ do + it "lexes value attribute" $ do + shouldBe' (collectF03 "value :: a, b") $ + fmap ($u) [ TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + shouldBe' (collectF03 "integer, value :: a, b") $ + fmap ($u) [ TInteger, TComma, TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + + it "lexes volatile attribute" $ do + shouldBe' (collectF03 "volatile :: a, b") $ + fmap ($u) [ TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + shouldBe' (collectF03 "integer, volatile :: a, b") $ + fmap ($u) [ TInteger, TComma, TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + + describe "Fortran2003" $ do + it "lexes procedures" $ + shouldBe' (collectF03 "PROCEDURE(a), SAVE :: b => c()") $ + ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar + , TComma, TSave, TDoubleColon + , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ] + + it "lexes procedures with bind" $ + shouldBe' (collectF03 "PROCEDURE(a), BIND(C, NAME=\"d\") :: b => c()") $ + ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar + , TComma, TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TDoubleColon + , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ] + + it "lexes functions with bind" $ + shouldBe' (collectF03 "FUNCTION f(a) RESULT(x) BIND(C, NAME=\"d\")") $ + ($u) <$> [ TFunction, flip TId "f", TLeftPar, flip TId "a", TRightPar + , TResult, TLeftPar, flip TId "x", TRightPar + , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ] + + it "lexes subroutines with bind" $ + shouldBe' (collectF03 "SUBROUTINE s(a) BIND(C, NAME=\"d\")") $ + ($u) <$> [ TSubroutine, flip TId "s", TLeftPar, flip TId "a", TRightPar + , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ] + + it "lexes class decl (name)" $ + shouldBe' (collectF03 "procedure (class(c))") $ + fmap ($u) [ TProcedure, TLeftPar + , TClass, TLeftPar, flip TId "c", TRightPar, TRightPar, TEOF ] + + it "lexes class decl (*)" $ + shouldBe' (collectF03 "procedure (class(*))") $ + fmap ($u) [ TProcedure, TLeftPar + , TClass, TLeftPar, TStar, TRightPar, TRightPar, TEOF ] + + it "lexes import statements" $ + shouldBe' (collectF03 "import :: a, b") $ + fmap ($u) [ TImport, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + + it "lexes asynchronous attribute" $ do + shouldBe' (collectF03 "asynchronous :: a, b") $ + fmap ($u) [ TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + shouldBe' (collectF03 "integer, asynchronous :: a, b") $ + fmap ($u) [ TInteger, TComma, TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ] + + it "lexes enums" $ do + shouldBe' (collectF03 "enum, bind(c)") $ fmap ($u) [ TEnum, TComma, TBind, TLeftPar, TC, TRightPar, TEOF ] + shouldBe' (collectF03 "enumerator :: a = 1, b") $ + fmap ($u) [ TEnumerator, TDoubleColon, flip TId "a", TOpAssign, flip TIntegerLiteral "1" + , TComma, flip TId "b", TEOF ] + shouldBe' (collectF03 "end enum") $ fmap ($u) [ TEndEnum, TEOF ] + + it "lexes flush" $ do + shouldBe' (collectF03 "flush(unit=1)") $ + fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TRightPar, TEOF ] + shouldBe' (collectF03 "flush(unit=1,iomsg=x,iostat=y,err=z)") $ + fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TComma + , TIOMsg, TOpAssign, flip TId "x", TComma + , TIOStat, TOpAssign, flip TId "y", TComma + , TErr, TOpAssign, flip TId "z", TRightPar, TEOF ] + + it "lexes protected" $ do + shouldBe' (collectF03 "real, protected, public :: x") $ + fmap ($u) [ TReal, TComma, TProtected, TComma, TPublic, TDoubleColon, flip TId "x", TEOF ] diff --git a/test/Language/Fortran/Parser/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Fortran2003Spec.hs --- a/test/Language/Fortran/Parser/Fortran2003Spec.hs +++ b/test/Language/Fortran/Parser/Fortran2003Spec.hs @@ -1,9 +1,156 @@ module Language.Fortran.Parser.Fortran2003Spec where + +import Prelude hiding (GT, EQ, exp, pred) + +import TestUtil import Test.Hspec +import Language.Fortran.AST +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FreeForm +import Language.Fortran.Parser.Fortran2003 +import qualified Data.ByteString.Char8 as B + +eParser :: String -> Expression () +eParser sourceCode = + case evalParse statementParser parseState of + (StExpressionAssign _ _ _ e) -> e + _ -> error "unhandled evalParse" + where + paddedSourceCode = B.pack $ " a = " ++ sourceCode + parseState = initParseState paddedSourceCode Fortran2003 "" + +sParser :: String -> Statement () +sParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran2003 "" + +fParser :: String -> ProgramUnit () +fParser sourceCode = + evalParse functionParser $ initParseState (B.pack sourceCode) Fortran2003 "" + spec :: Spec -spec = +spec = describe "Fortran 2003 Parser" $ do - it "TODO" $ do - pending + describe "Modules" $ do + it "parses use statement, intrinsic module" $ do + let renames = fromList () + [ UseRename () u (varGen "sprod") (varGen "prod") + , UseRename () u (varGen "a") (varGen "b") ] + let st = StUse () u (varGen "mod") (Just ModIntrinsic) Permissive (Just renames) + sParser "use, intrinsic :: mod, sprod => prod, a => b" `shouldBe'` st + + it "parses use statement, non_intrinsic module" $ do + let renames = fromList () + [ UseRename () u (varGen "sprod") (varGen "prod") + , UseRename () u (varGen "a") (varGen "b") ] + let st = StUse () u (varGen "mod") (Just ModNonIntrinsic) Exclusive (Just renames) + sParser "use, non_intrinsic :: mod, only: sprod => prod, a => b" `shouldBe'` st + + it "parses use statement, unspecified nature of module" $ do + let renames = fromList () + [ UseRename () u (varGen "sprod") (varGen "prod") + , UseRename () u (varGen "a") (varGen "b") ] + let st = StUse () u (varGen "mod") Nothing Permissive (Just renames) + 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 st = StProcedure () u (Just (ProcInterfaceName () u (varGen "a"))) + (Just (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 clas = TypeSpec () u ClassStar Nothing + let st = StProcedure () u (Just (ProcInterfaceType () u clas)) + (Just (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 clas = TypeSpec () u (ClassCustom "e") Nothing + let st = StProcedure () u (Just (ProcInterfaceType () u clas)) + (Just (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 + + it "import statements" $ do + let st = StImport () u (AList () u [varGen "a", varGen "b"]) + sParser "import a, b" `shouldBe'` st + sParser "import :: a, b" `shouldBe'` st + + it "parses function with bind" $ do + let puFunction = PUFunction () u + fType = Nothing + fPre = emptyPrefixes + fSuf = fromList' () [SfxBind () u (Just $ ExpValue () u (ValString "f"))] + fName = "f" + fArgs = Nothing + fRes = Nothing + fBody = [] + fSub = Nothing + fStr = init $ unlines ["function f() bind(c,name=\"f\")" + , "end function f" ] + let expected = puFunction fType (fPre, fSuf) fName fArgs fRes fBody fSub + fParser fStr `shouldBe'` expected + + it "parses asynchronous decl" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let st = StAsynchronous () u (AList () u decls) + sParser "asynchronous a, b" `shouldBe'` st + sParser "asynchronous :: a, b" `shouldBe'` st + + it "parses asynchronous attribute" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let ty = TypeSpec () u TypeInteger Nothing + let attrs = [AttrAsynchronous () u] + let st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls) + sParser "integer, asynchronous :: a, b" `shouldBe'` st + + it "parses enumerators" $ do + let decls = [ DeclVariable () u (varGen "a") Nothing (Just (intGen 1)) + , DeclVariable () u (varGen "b") Nothing Nothing ] + let st = StEnumerator () u (AList () u decls) + sParser "enum, bind(c)" `shouldBe'` StEnum () u + sParser "enumerator :: a = 1, b" `shouldBe'` st + sParser "end enum" `shouldBe'` StEndEnum () u + + it "parses allocate with type_spec" $ do + let sel = Selector () u (Just (ExpValue () u ValColon)) (Just (varGen "foo")) + let ty = TypeSpec () u (TypeCharacter (Just $ CharLenColon) (Just "foo")) (Just sel) + let decls = [DeclVariable () u (varGen "s") Nothing Nothing] + let st = StDeclaration () u ty (Just (AList () u [AttrAllocatable () u])) (AList () u decls) + sParser "character(len=:,kind=foo), allocatable :: s" `shouldBe'` st + + it "parses allocate with type_spec" $ do + let sel = Selector () u (Just (intGen 3)) (Just (varGen "foo")) + let ty = TypeSpec () u (TypeCharacter (Just $ CharLenInt 3) (Just "foo")) (Just sel) + let st = StAllocate () u (Just ty) (AList () u [varGen "s"]) Nothing + sParser "allocate(character(len=3,kind=foo) :: s)" `shouldBe'` st + + it "parses protected" $ do + let ty = TypeSpec () u TypeReal Nothing + let decls = AList () u [DeclVariable () u (varGen "x") Nothing Nothing] + let st1 = StDeclaration () u ty (Just (AList () u [AttrProtected () u, AttrPublic () u])) decls + let st2 = StProtected () u (Just (AList () u [varGen "x"])) + sParser "real, protected, public :: x" `shouldBe'` st1 + sParser "protected x" `shouldBe'` st2 + + describe "labelled where" $ do + it "parses where construct statement" $ + sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue + + it "parses elsewhere statement" $ + sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing + + it "parses elsewhere statement" $ do + let exp = ExpBinary () u GT (varGen "a") (varGen "b") + sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp) + + it "parses endwhere statement" $ + sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1") diff --git a/test/Language/Fortran/Parser/Fortran2008Spec.hs b/test/Language/Fortran/Parser/Fortran2008Spec.hs --- a/test/Language/Fortran/Parser/Fortran2008Spec.hs +++ b/test/Language/Fortran/Parser/Fortran2008Spec.hs @@ -3,7 +3,6 @@ import Test.Hspec spec :: Spec -spec = - describe "Fortran 2008 Parser" $ do - it "TODO" $ do - pending +spec = + describe "Fortran 2008 Parser" $ + it "TODO" pending diff --git a/test/Language/Fortran/Parser/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fortran66Spec.hs --- a/test/Language/Fortran/Parser/Fortran66Spec.hs +++ b/test/Language/Fortran/Parser/Fortran66Spec.hs @@ -3,7 +3,6 @@ import Test.Hspec import TestUtil -import Control.Monad.State.Lazy import Prelude hiding (LT) import Language.Fortran.Parser.Fortran66 @@ -12,12 +11,11 @@ import Language.Fortran.AST import qualified Data.ByteString.Char8 as B -import Data.Typeable - eParser :: String -> Expression () eParser sourceCode = case evalParse statementParser parseState of (StExpressionAssign _ _ _ e) -> e + _ -> error "unhandled evalParse" where paddedSourceCode = B.pack $ " a = " ++ sourceCode parseState = initParseState paddedSourceCode Fortran66 "" diff --git a/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs @@ -0,0 +1,53 @@ +module Language.Fortran.Parser.Fortran77.IncludeSpec where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Parser.Fortran77 +import qualified Data.ByteString.Char8 as B +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FixedForm +import Language.Fortran.AST +import Language.Fortran.Util.Position + +iParser :: [String] -> String -> IO (ParseResult AlexInput Token (ProgramFile A0)) +iParser incs src = legacy77ParserWithIncludes incs (B.pack src) "" + +makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan +makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing) + +spec :: SpecWith () +spec = + describe "Include Test" $ do + let source = unlines [" program bar", + " include 'foo.f'", + " end" + ] + incs = ["./test/Language/Fortran/Parser"] + 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 + st2Span = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f") + declSpan = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f") + typeSpan = makeSrcR (6,7,1,"foo.f") (12,13,1,"foo.f") + blockSpan = makeSrcR (14,15,1,"foo.f") (14,15,1,"foo.f") + varGen' str = ExpValue () blockSpan $ ValVariable str + + pu = PUMain () puSpan (Just name) blocks Nothing + blocks = [bl1] + decl = DeclVariable () blockSpan (varGen' "a") 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 + ps <- iParser incs source + let pr = fromParseResultUnsafe ps + pr `shouldBe` pf diff --git a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs @@ -0,0 +1,312 @@ +module Language.Fortran.Parser.Fortran77.ParserSpec where + +import Test.Hspec +import TestUtil + +import Prelude hiding (exp) +import Language.Fortran.Parser.Fortran77 +import Language.Fortran.Lexer.FixedForm (initParseState) +import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.AST +import qualified Data.ByteString.Char8 as B + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +eParser :: String -> Expression () +eParser sourceCode = + case evalParse statementParser parseState of + (StExpressionAssign _ _ _ e) -> e + _ -> error "unhandled evalParse" + where + paddedSourceCode = B.pack $ " a = " ++ sourceCode + parseState = initParseState paddedSourceCode Fortran77 "" + +sParser :: String -> Statement () +sParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77 "" + +slParser :: String -> Statement () +slParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "" + +iParser :: String -> [Block ()] +iParser sourceCode = + fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "" + +pParser :: String -> ProgramFile () +pParser source = fromParseResultUnsafe $ fortran77Parser (B.pack source) "" + +spec :: Spec +spec = + describe "Fortran 77 Parser" $ do + describe "IO" $ do + it "parses 'print *, 9000" $ do + let expectedSt = StPrint () u starVal $ Just (AList () u [ intGen 9000 ]) + sParser " print *, 9000" `shouldBe'` expectedSt + + it "parses 'write (UNIT=6, FORMAT=*)" $ do + let cp1 = ControlPair () u (Just "unit") (intGen 6) + cp2 = ControlPair () u (Just "format") starVal + expectedSt = StWrite () u (AList () u [cp1, cp2]) Nothing + sParser " write (UNIT=6, FORMAT=*)" `shouldBe'` expectedSt + + it "parses 'endfile i" $ + sParser " endfile i" `shouldBe'` StEndfile2 () u (varGen "i") + + it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do + let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) + doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) + impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] + impliedDo = ExpImpliedDo () u impliedDoVars doSpec + iolist = AList () u [ impliedDo ] + expectedSt = StRead2 () u starVal (Just iolist) + sParser " read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt + + it "parses '(x, y(i), i = 1, 10, 2)'" $ do + let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) + doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) + impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] + impliedDo = ExpImpliedDo () u impliedDoVars doSpec + eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo + + it "parses main program unit" $ do + let decl = DeclVariable () u (varGen "x") Nothing Nothing + st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) + bl = BlStatement () u Nothing st + pu = ProgramFile mi77 [ PUMain () u (Just "hello") [ bl ] Nothing ] + pParser exampleProgram1 `shouldBe'` pu + + it "parses block data unit" $ do + let decl = DeclVariable () u (varGen "x") Nothing Nothing + st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) + bl = BlStatement () u Nothing st + pu = ProgramFile mi77 [ PUBlockData () u (Just "hello") [ bl ] ] + pParser exampleProgram2 `shouldBe'` pu + + it "parses 'intrinsic cosh, sin'" $ do + let fun1 = ExpValue () u (ValVariable "cosh") + fun2 = ExpValue () u (ValVariable "sin") + st = StIntrinsic () u (AList () u [ fun1, fun2 ]) + sParser " intrinsic cosh, sin" `shouldBe'` st + + it "parses 'intrinsic real" $ do + let fun = ExpValue () u (ValVariable "real") + st = StIntrinsic () u (AList () u [ fun ]) + sParser " intrinsic real" `shouldBe'` st + + describe "CHARACTER" $ do + it "parses character literal assignment" $ do + let rhs = ExpValue () u (ValString "hello 'baby") + st = StExpressionAssign () u (varGen "xyz") rhs + sParser " xyz = 'hello ''baby'" `shouldBe'` st + + it "string concatenation" $ do + let str1 = ExpValue () u (ValString "hello ") + str2 = ExpValue () u (ValString "world") + exp = ExpBinary () u Concatenation str1 str2 + eParser "'hello ' // 'world'" `shouldBe'` exp + + describe "Subscript like" $ do + it "parses vanilla subscript" $ do + let exp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing $ varGen "x", IxSingle () u Nothing $ intGen 2, IxSingle () u Nothing $ intGen 3 ]) + eParser "a(x, 2, 3)" `shouldBe'` exp + + it "parses array declarator" $ do + let dimDecls = [ DimensionDeclarator () u (Just $ intGen 1) (Just $ intGen 2) + , DimensionDeclarator () u Nothing (Just $ intGen 15) + , DimensionDeclarator () u (Just $ varGen "x") (Just starVal) ] + decl = DeclArray () u (varGen "a") (AList () u dimDecls) Nothing Nothing + st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) + sParser " integer a(1:2, 15, x:*)" `shouldBe'` st + + it "parses character substring" $ do + let indicies = [ ixSinGen 1, ixSinGen 2, ixSinGen 3 ] + subExp = ExpSubscript () u (varGen "a") (AList () u indicies) + range = IxRange () u Nothing (Just $ intGen 10) Nothing + exp = ExpSubscript () u subExp (AList () u [ range ]) + eParser "a(1, 2, 3)(:10)" `shouldBe'` exp + + it "parses simpler substring" $ do + let exp = ExpSubscript () u (varGen "a") (AList () u [ ixRanGen 5 10 ]) + eParser "a(5:10)" `shouldBe'` exp + + it "parses simpler substring" $ do + let range = IxRange () u (Just $ intGen 5) Nothing Nothing + exp = ExpSubscript () u (varGen "a") (AList () u [ range ]) + eParser "a(5:)" `shouldBe'` exp + + describe "GOTO" $ do + it "parses computed GOTO with integer expression" $ do + let exp = ExpBinary () u Multiplication (intGen 42) (intGen 24) + st = StGotoComputed () u (AList () u [labelGen 10, labelGen 20, labelGen 30]) exp + sParser " GOTO (10, 20, 30), 42 * 24" `shouldBe'` st + + let gotoSt = StGotoAssigned () u (varGen "v") (Just (AList () u [labelGen 10, labelGen 20, labelGen 30])) + it "parses assigned GOTO with comma" $ + sParser " GOTO v, (10, 20, 30)" `shouldBe'` gotoSt + + it "parses assigned GOTO without comma" $ + sParser " GOTO v (10, 20, 30)" `shouldBe'` gotoSt + + describe "IMPLICIT" $ do + it "parses 'implicit none'" $ do + let st = resetSrcSpan $ StImplicit () u Nothing + sParser " implicit none" `shouldBe'` st + + it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do + let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"] + sel = Selector () u (Just (intGen 30)) Nothing + imp1 = ImpList () u (TypeSpec () u (TypeCharacter (Just $ CharLenInt 30) Nothing) (Just sel)) $ AList () u impEls + imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"] + st = StImplicit () u $ Just $ AList () u [imp1, imp2] + sParser " implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st + + it "parses 'parameter (pi = 3.14, b = 'X' // 'O', d = k) '" $ do + let sts = [ DeclVariable () u (varGen "pi") Nothing (Just $ realGen (3.14::Double)) + , let e = ExpBinary () u Concatenation (strGen "X") (strGen "O") + in DeclVariable () u (varGen "b") Nothing (Just e) + , DeclVariable () u (varGen "d") Nothing (Just $ varGen "k") ] + st = StParameter () u (AList () u sts) + sParser " parameter (pi = 3.14, b = 'X' // 'O', d = k)" `shouldBe'` st + + it "parses 'pause 'hello world''" $ do + let st = StPause () u $ Just $ strGen "hello world" + sParser " pause 'hello world'" `shouldBe'` st + + describe "SAVE" $ do + it "parses 'save /cb/, var, /key/'" $ do + let saveArgs = [ varGen "cb", varGen "var", varGen "key" ] + st = StSave () u (Just $ AList () u saveArgs) + sParser " save /cb/, var, /key/" `shouldBe'` st + + it "parses 'save'" $ + sParser " save" `shouldBe'` StSave () u Nothing + + it "parses '.true. .eqv. f(42) .neqv. x'" $ do + let arg2 = ExpSubscript () u (varGen "f") $ AList () u [ ixSinGen 42 ] + arg3 = varGen "x" + subexp = ExpBinary () u Equivalent valTrue arg2 + exp = ExpBinary () u NotEquivalent subexp arg3 + eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp + + it "parses 'entry me (a,b,*)'" $ do + let func = ExpValue () u (ValVariable "me") + args = [ varGen "a", varGen "b", starVal ] + st = StEntry () u func (Just $ AList () u args) Nothing + sParser " entry me (a,b,*)" `shouldBe'` st + + it "parses 'character a*8'" $ do + let decl = DeclVariable () u (varGen "a") (Just $ intGen 8) Nothing + typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing + st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) + sParser " character a*8" `shouldBe'` st + + it "parses included files" $ do + let decl = DeclVariable () u (varGen "a") Nothing Nothing + typeSpec = TypeSpec () u TypeInteger Nothing + st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) + bl = BlStatement () u Nothing st + iParser " integer a" `shouldBe'` [bl] + + describe "Legacy Extensions" $ do + it "parses structure/union/map blocks" $ do + let src = init + $ unlines [ " structure /foo/" + , " union" + , " map" + , " integer i" + , " end map" + , " map" + , " real r" + , " end map" + , " end union" + , " end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [DeclVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [DeclVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses character declarations with unspecfied lengths" $ do + let src = " character s*(*)" + st = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $ + AList () u [DeclVariable () u + (ExpValue () u (ValVariable "s")) + (Just (ExpValue () u ValStar)) + Nothing] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses array initializers" $ do + let src = " integer xs(3) / 1, 2, 3 /" + inits = [ExpValue () u (ValInteger "1"), ExpValue () u (ValInteger "2"), ExpValue () u (ValInteger "3")] + st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [DeclArray () u + (ExpValue () u (ValVariable "xs")) + (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "3")))]) + Nothing + (Just (ExpInitialisation () u $ AList () u inits))] + resetSrcSpan (slParser src) `shouldBe` st + + let src1 = " character xs(2)*5 / 'hello', 'world' /" + inits1 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")] + st1 = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $ + AList () u [DeclArray () u + (ExpValue () u (ValVariable "xs")) + (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))]) + (Just (ExpValue () u (ValInteger "5"))) + (Just (ExpInitialisation () u $ AList () u inits1))] + resetSrcSpan (slParser src1) `shouldBe` st1 + + let src2 = " character xs*5(2) / 'hello', 'world' /" + inits2 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")] + st2 = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $ + AList () u [DeclArray () u + (ExpValue () u (ValVariable "xs")) + (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))]) + (Just (ExpValue () u (ValInteger "5"))) + (Just (ExpInitialisation () u $ AList () u inits2))] + resetSrcSpan (slParser src2) `shouldBe` st2 + + it "parses subscripts in assignments" $ do + let mkIdx i = IxSingle () u Nothing (ExpValue () u (ValInteger i)) + + src = " x(0,1) = 0" + tgt = ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0", mkIdx "1"]) + st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0")) + resetSrcSpan (slParser src) `shouldBe` st + + let src1 = " x(0).foo = 0" + tgt1 = ExpDataRef () u (ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0"])) (ExpValue () u (ValVariable "foo")) + st1 = StExpressionAssign () u tgt1 (ExpValue () u (ValInteger "0")) + resetSrcSpan (slParser src1) `shouldBe` st1 + + let src2 = " x.foo = 0" + tgt2 = ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo")) + st2 = StExpressionAssign () u tgt2 (ExpValue () u (ValInteger "0")) + resetSrcSpan (slParser src2) `shouldBe` st2 + + let src3 = " x.foo(0) = 0" + tgt3 = ExpSubscript () u (ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))) (AList () u [mkIdx "0"]) + st3 = StExpressionAssign () u tgt3 (ExpValue () u (ValInteger "0")) + resetSrcSpan (slParser src3) `shouldBe` st3 + +exampleProgram1 :: String +exampleProgram1 = unlines + [ " program hello" + , " integer x" + , " end" ] + +exampleProgram2 :: String +exampleProgram2 = unlines + [ " block data hello" + , " integer x" + , " end" ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Parser/Fortran77Spec.hs b/test/Language/Fortran/Parser/Fortran77Spec.hs deleted file mode 100644 --- a/test/Language/Fortran/Parser/Fortran77Spec.hs +++ /dev/null @@ -1,306 +0,0 @@ -module Language.Fortran.Parser.Fortran77Spec where - -import Test.Hspec -import TestUtil - -import Language.Fortran.Parser.Fortran77 -import Language.Fortran.Lexer.FixedForm (initParseState) -import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) -import Language.Fortran.AST -import qualified Data.ByteString.Char8 as B - -eParser :: String -> Expression () -eParser sourceCode = - case evalParse statementParser parseState of - (StExpressionAssign _ _ _ e) -> e - where - paddedSourceCode = B.pack $ " a = " ++ sourceCode - parseState = initParseState paddedSourceCode Fortran77 "" - -sParser :: String -> Statement () -sParser sourceCode = - evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77 "" - -slParser :: String -> Statement () -slParser sourceCode = - evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "" - -iParser :: String -> [Block ()] -iParser sourceCode = - fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "" - -pParser :: String -> ProgramFile () -pParser source = fromParseResultUnsafe $ fortran77Parser (B.pack source) "" - -spec :: Spec -spec = - describe "Fortran 77 Parser" $ do - describe "IO" $ do - it "parses 'print *, 9000" $ do - let expectedSt = StPrint () u starVal $ Just (AList () u [ intGen 9000 ]) - sParser " print *, 9000" `shouldBe'` expectedSt - - it "parses 'write (UNIT=6, FORMAT=*)" $ do - let cp1 = ControlPair () u (Just "unit") (intGen 6) - let cp2 = ControlPair () u (Just "format") starVal - let expectedSt = StWrite () u (AList () u [cp1, cp2]) Nothing - sParser " write (UNIT=6, FORMAT=*)" `shouldBe'` expectedSt - - it "parses 'endfile i" $ - sParser " endfile i" `shouldBe'` StEndfile2 () u (varGen "i") - - it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do - let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) - let doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) - let impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] - let impliedDo = ExpImpliedDo () u impliedDoVars doSpec - let iolist = AList () u [ impliedDo ] - let expectedSt = StRead2 () u starVal (Just iolist) - sParser " read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt - - it "parses '(x, y(i), i = 1, 10, 2)'" $ do - let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) - let doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) - let impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] - let impliedDo = ExpImpliedDo () u impliedDoVars doSpec - eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo - - it "parses main program unit" $ do - let decl = DeclVariable () u (varGen "x") Nothing Nothing - let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) - let bl = BlStatement () u Nothing st - let pu = ProgramFile mi77 [ PUMain () u (Just "hello") [ bl ] Nothing ] - pParser exampleProgram1 `shouldBe'` pu - - it "parses block data unit" $ do - let decl = DeclVariable () u (varGen "x") Nothing Nothing - let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) - let bl = BlStatement () u Nothing st - let pu = ProgramFile mi77 [ PUBlockData () u (Just "hello") [ bl ] ] - pParser exampleProgram2 `shouldBe'` pu - - it "parses 'intrinsic cosh, sin'" $ do - let fun1 = ExpValue () u (ValVariable "cosh") - let fun2 = ExpValue () u (ValVariable "sin") - let st = StIntrinsic () u (AList () u [ fun1, fun2 ]) - sParser " intrinsic cosh, sin" `shouldBe'` st - - it "parses 'intrinsic real" $ do - let fun = ExpValue () u (ValVariable "real") - let st = StIntrinsic () u (AList () u [ fun ]) - sParser " intrinsic real" `shouldBe'` st - - describe "CHARACTER" $ do - it "parses character literal assignment" $ do - let rhs = ExpValue () u (ValString "hello 'baby") - let st = StExpressionAssign () u (varGen "xyz") rhs - sParser " xyz = 'hello ''baby'" `shouldBe'` st - - it "string concatenation" $ do - let str1 = ExpValue () u (ValString "hello ") - let str2 = ExpValue () u (ValString "world") - let exp = ExpBinary () u Concatenation str1 str2 - eParser "'hello ' // 'world'" `shouldBe'` exp - - describe "Subscript like" $ do - it "parses vanilla subscript" $ do - let exp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing $ varGen "x", IxSingle () u Nothing $ intGen 2, IxSingle () u Nothing $ intGen 3 ]) - eParser "a(x, 2, 3)" `shouldBe'` exp - - it "parses array declarator" $ do - let dimDecls = [ DimensionDeclarator () u (Just $ intGen 1) (Just $ intGen 2) - , DimensionDeclarator () u Nothing (Just $ intGen 15) - , DimensionDeclarator () u (Just $ varGen "x") (Just $ starVal) ] - let decl = DeclArray () u (varGen "a") (AList () u dimDecls) Nothing Nothing - let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ]) - sParser " integer a(1:2, 15, x:*)" `shouldBe'` st - - it "parses character substring" $ do - let indicies = [ ixSinGen 1, ixSinGen 2, ixSinGen 3 ] - let subExp = ExpSubscript () u (varGen "a") (AList () u indicies) - let range = IxRange () u Nothing (Just $ intGen 10) Nothing - let exp = ExpSubscript () u subExp (AList () u [ range ]) - eParser "a(1, 2, 3)(:10)" `shouldBe'` exp - - it "parses simpler substring" $ do - let exp = ExpSubscript () u (varGen "a") (AList () u [ ixRanGen 5 10 ]) - eParser "a(5:10)" `shouldBe'` exp - - it "parses simpler substring" $ do - let range = IxRange () u (Just $ intGen 5) Nothing Nothing - let exp = ExpSubscript () u (varGen "a") (AList () u [ range ]) - eParser "a(5:)" `shouldBe'` exp - - describe "GOTO" $ do - it "parses computed GOTO with integer expression" $ do - let exp = ExpBinary () u Multiplication (intGen 42) (intGen 24) - let st = StGotoComputed () u (AList () u [labelGen 10, labelGen 20, labelGen 30]) exp - sParser " GOTO (10, 20, 30), 42 * 24" `shouldBe'` st - - let gotoSt = StGotoAssigned () u (varGen "v") (Just (AList () u [labelGen 10, labelGen 20, labelGen 30])) - it "parses assigned GOTO with comma" $ - sParser " GOTO v, (10, 20, 30)" `shouldBe'` gotoSt - - it "parses assigned GOTO without comma" $ - sParser " GOTO v (10, 20, 30)" `shouldBe'` gotoSt - - describe "IMPLICIT" $ do - it "parses 'implicit none'" $ do - let st = resetSrcSpan $ StImplicit () u Nothing - sParser " implicit none" `shouldBe'` st - - it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do - let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"] - let selector = Selector () u (Just $ intGen 30) Nothing - let imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just selector)) $ AList () u impEls - let imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"] - let st = StImplicit () u $ Just $ AList () u [imp1, imp2] - sParser " implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st - - it "parses 'parameter (pi = 3.14, b = 'X' // 'O', d = k) '" $ do - let sts = [ DeclVariable () u (varGen "pi") Nothing (Just $ realGen 3.14) - , let e = ExpBinary () u Concatenation (strGen "X") (strGen "O") - in DeclVariable () u (varGen "b") Nothing (Just e) - , DeclVariable () u (varGen "d") Nothing (Just $ varGen "k") ] - let st = StParameter () u (AList () u sts) - sParser " parameter (pi = 3.14, b = 'X' // 'O', d = k)" `shouldBe'` st - - it "parses 'pause 'hello world''" $ do - let st = StPause () u $ Just $ strGen "hello world" - sParser " pause 'hello world'" `shouldBe'` st - - describe "SAVE" $ do - it "parses 'save /cb/, var, /key/'" $ do - let saveArgs = [ varGen "cb", varGen "var", varGen "key" ] - let st = StSave () u (Just $ AList () u saveArgs) - sParser " save /cb/, var, /key/" `shouldBe'` st - - it "parses 'save'" $ - sParser " save" `shouldBe'` StSave () u Nothing - - it "parses '.true. .eqv. f(42) .neqv. x'" $ do - let arg2 = ExpSubscript () u (varGen "f") $ AList () u [ ixSinGen 42 ] - let arg3 = varGen "x" - let subexp = ExpBinary () u Equivalent valTrue arg2 - let exp = ExpBinary () u NotEquivalent subexp arg3 - eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp - - it "parses 'entry me (a,b,*)'" $ do - let func = ExpValue () u (ValVariable "me") - let args = [ varGen "a", varGen "b", starVal ] - let st = StEntry () u func (Just $ AList () u args) Nothing - sParser " entry me (a,b,*)" `shouldBe'` st - - it "parses 'character a*8'" $ do - let decl = DeclVariable () u (varGen "a") (Just $ intGen 8) Nothing - let typeSpec = TypeSpec () u TypeCharacter Nothing - let st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) - sParser " character a*8" `shouldBe'` st - - it "parses included files" $ do - let decl = DeclVariable () u (varGen "a") Nothing Nothing - let typeSpec = TypeSpec () u TypeInteger Nothing - let st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) - let bl = BlStatement () u Nothing st - iParser " integer a" `shouldBe'` [bl] - - describe "Legacy Extensions" $ do - it "parses structure/union/map blocks" $ do - let src = init - $ unlines [ " structure /foo/" - , " union" - , " map" - , " integer i" - , " end map" - , " map" - , " real r" - , " end map" - , " end union" - , " end structure"] - let ds = [ UnionMap () u $ AList () u - [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ - AList () u [DeclVariable () u (varGen "i") Nothing Nothing]] - , UnionMap () u $ AList () u - [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ - AList () u [DeclVariable () u (varGen "r") Nothing Nothing]] - ] - let st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] - resetSrcSpan (slParser src) `shouldBe` st - - it "parses character declarations with unspecfied lengths" $ do - let src = " character s*(*)" - let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $ - AList () u [DeclVariable () u - (ExpValue () u (ValVariable "s")) - (Just (ExpValue () u ValStar)) - Nothing] - resetSrcSpan (slParser src) `shouldBe` st - - it "parses array initializers" $ do - let src = " integer xs(3) / 1, 2, 3 /" - let inits = [ExpValue () u (ValInteger "1"), ExpValue () u (ValInteger "2"), ExpValue () u (ValInteger "3")] - let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ - AList () u [DeclArray () u - (ExpValue () u (ValVariable "xs")) - (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "3")))]) - Nothing - (Just (ExpInitialisation () u $ AList () u inits))] - resetSrcSpan (slParser src) `shouldBe` st - - let src = " character xs(2)*5 / 'hello', 'world' /" - let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")] - let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $ - AList () u [DeclArray () u - (ExpValue () u (ValVariable "xs")) - (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))]) - (Just (ExpValue () u (ValInteger "5"))) - (Just (ExpInitialisation () u $ AList () u inits))] - resetSrcSpan (slParser src) `shouldBe` st - - let src = " character xs*5(2) / 'hello', 'world' /" - let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")] - let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $ - AList () u [DeclArray () u - (ExpValue () u (ValVariable "xs")) - (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))]) - (Just (ExpValue () u (ValInteger "5"))) - (Just (ExpInitialisation () u $ AList () u inits))] - resetSrcSpan (slParser src) `shouldBe` st - - it "parses subscripts in assignments" $ do - let mkIdx i = IxSingle () u Nothing (ExpValue () u (ValInteger i)) - - let src = " x(0,1) = 0" - let tgt = ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0", mkIdx "1"]) - let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0")) - resetSrcSpan (slParser src) `shouldBe` st - - let src = " x(0).foo = 0" - let tgt = ExpDataRef () u (ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0"])) (ExpValue () u (ValVariable "foo")) - let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0")) - resetSrcSpan (slParser src) `shouldBe` st - - let src = " x.foo = 0" - let tgt = ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo")) - let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0")) - resetSrcSpan (slParser src) `shouldBe` st - - let src = " x.foo(0) = 0" - let tgt = ExpSubscript () u (ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))) (AList () u [mkIdx "0"]) - let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0")) - resetSrcSpan (slParser src) `shouldBe` st - -exampleProgram1 = unlines - [ " program hello" - , " integer x" - , " end" ] - -exampleProgram2 = unlines - [ " block data hello" - , " integer x" - , " end" ] - --- Local variables: --- mode: haskell --- haskell-program-name: "cabal repl test-suite:spec" --- End: diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs --- a/test/Language/Fortran/Parser/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Fortran90Spec.hs @@ -1,6 +1,6 @@ module Language.Fortran.Parser.Fortran90Spec (spec) where -import Prelude hiding (GT) +import Prelude hiding (GT, exp, pred) import TestUtil import Test.Hspec @@ -9,13 +9,16 @@ import Language.Fortran.ParserMonad import Language.Fortran.Lexer.FreeForm import Language.Fortran.Parser.Fortran90 -import qualified Data.List as List +--import qualified Data.List as List import qualified Data.ByteString.Char8 as B +{-# ANN module "HLint: ignore Reduce duplication" #-} + eParser :: String -> Expression () eParser sourceCode = case evalParse statementParser parseState of (StExpressionAssign _ _ _ e) -> e + _ -> error "unhandled evalParse" where paddedSourceCode = B.pack $ " a = " ++ sourceCode parseState = initParseState paddedSourceCode Fortran90 "" @@ -37,8 +40,8 @@ - Given a list of values, find every combination of those values: - combination [1,2] = [[], [1], [2], [1,2], [2,1]] -} -combination :: [a] -> [[a]] -combination = foldr ((++) . List.permutations) [] . List.subsequences +--combination :: [a] -> [[a]] +--combination = foldr ((++) . List.permutations) [] . List.subsequences spec :: Spec spec = @@ -46,87 +49,89 @@ describe "Function" $ do let puFunction = PUFunction () u let fType = Nothing - let fOpt = None () u False - let fName = "f" - let fArgs = Nothing - let fRes = Nothing - let fBody = [] - let fSub = Nothing + fPre = emptyPrefixes + fPreR = Just $ AList () u [PfxRecursive () u] + fSuf = emptySuffixes + fPreSuf = (fPre, fSuf) + fName = "f" + fArgs = Nothing + fRes = Nothing + fBody = [] + fSub = Nothing describe "End" $ do it "parses simple functions ending with \"end function [function name]\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub let fStr = init $ unlines ["function f()" , "end function f" ] fParser fStr `shouldBe'` expected it "parses simple functions ending with \"end\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub let fStr = init $ unlines ["function f()" , "end" ] fParser fStr `shouldBe'` expected it "parses simple functions ending with \"end function\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub let fStr = init $ unlines ["function f()" , "end function" ] fParser fStr `shouldBe'` expected it "parses functions with return type specs" $ do - let fType = Just $ TypeSpec () u TypeInteger Nothing - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fType' = Just $ TypeSpec () u TypeInteger Nothing + let expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub let fStr = init $ unlines ["integer function f()" , "end function f" ] fParser fStr `shouldBe'` expected - it "parses recursive functions" $ do - let fOpt = None () u True - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["recursive function f()", "end"] - fParser fStr `shouldBe'` expected + it "parses recursive functions" $ + let expected = puFunction fType (fPreR, fSuf) fName fArgs fRes fBody fSub + fStr = init $ unlines ["recursive function f()", "end"] + in fParser fStr `shouldBe'` expected - it "parses functions with a list of arguments" $ do - let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f(x, y, z)" + it "parses functions with a list of arguments" $ + let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub + fStr = init $ unlines ["function f(x, y, z)" , "end function f" ] - fParser fStr `shouldBe'` expected + in fParser fStr `shouldBe'` expected - it "parses functions with a result variable" $ do - let fRes = Just $ varGen "i" - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f() result(i)" + it "parses functions with a result variable" $ + let fRes' = Just $ varGen "i" + expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub + fStr = init $ unlines ["function f() result(i)" , "end function f" ] - fParser fStr `shouldBe'` expected + in fParser fStr `shouldBe'` expected - it "parses functions with function bodies" $ do + it "parses functions with function bodies" $ let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) - let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) - let f2 = StExpressionAssign () u (varGen "i") decrementRHS - let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f()" - , " print *, i" - , " i = (i - 1)" + f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + f2 = StExpressionAssign () u (varGen "i") decrementRHS + fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub + fStr = init $ unlines ["function f()" + , " print *, i" + , " i = (i - 1)" , "end function f" ] - fParser fStr `shouldBe'` expected + in fParser fStr `shouldBe'` expected - it "parses complex functions" $ do - let fType = Just $ TypeSpec () u TypeInteger Nothing - let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] - let fRes = Just $ varGen "i" - let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) - let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) - let f2 = StExpressionAssign () u (varGen "i") decrementRHS - let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines [ "integer function f(x, y, z) result(i)" - , " print *, i" - , " i = (i - 1)" - , "end function f" ] - fParser fStr `shouldBe'` expected + it "parses complex functions" $ + let fType' = Just $ TypeSpec () u TypeInteger Nothing + fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + fRes' = Just $ varGen "i" + decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + f2 = StExpressionAssign () u (varGen "i") decrementRHS + fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub + fStr = init $ unlines [ "integer function f(x, y, z) result(i)" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] + in fParser fStr `shouldBe'` expected describe "Expression" $ do it "parses logial literals with kind" $ do @@ -179,7 +184,7 @@ let stPause = StPause () u Nothing let stStr = "PAUSE" sParser stStr `shouldBe'` stPause - + it "parses pause statements with expression" $ do let stPause = StPause () u (Just (strGen "MESSAGE")) let stStr = "PAUSE \"MESSAGE\"" @@ -210,14 +215,14 @@ let stStr = "logical x, y" sParser stStr `shouldBe'` expected - it "parses declaration with initialisation" $ do + it "parses declaration with initialisation" $ let typeSpec = TypeSpec () u TypeComplex Nothing - let init = ExpValue () u (ValComplex (intGen 24) (realGen 42.0)) - let declarators = AList () u - [ DeclVariable () u (varGen "x") Nothing (Just init) ] - let expected = StDeclaration () u typeSpec Nothing declarators - let stStr = "complex :: x = (24, 42.0)" - sParser stStr `shouldBe'` expected + init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double))) + declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing (Just init') ] + expected = StDeclaration () u typeSpec Nothing declarators + stStr = "complex :: x = (24, 42.0)" + in sParser stStr `shouldBe'` expected it "parses declaration of custom type" $ do let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing @@ -280,7 +285,7 @@ sParser "implicit none" `shouldBe'` st it "parses implicit with single" $ do - let typeSpec = TypeSpec () u TypeCharacter Nothing + let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing let impEls = [ ImpCharacter () u "k" ] let impLists = [ ImpList () u typeSpec (fromList () impEls) ] let st = StImplicit () u (Just $ fromList () impLists) @@ -294,7 +299,7 @@ sParser "implicit logical (x-z)" `shouldBe'` st it "parses implicit statement" $ do - let typeSpec1 = TypeSpec () u TypeCharacter Nothing + let typeSpec1 = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing let typeSpec2 = TypeSpec () u TypeInteger Nothing let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ] let impEls2 = [ ImpRange () u "x" "z" ] @@ -379,21 +384,24 @@ describe "Dynamic allocation" $ do it "parses allocate statement" $ do - let controlPair = ControlPair () u (Just "stat") (varGen "a") + let opt = AOStat () u (varGen "a") let allocs = fromList () [ varGen "x" , ExpDataRef () u (varGen "st") (varGen "part") ] - let s = StAllocate () u allocs (Just controlPair) + let s = StAllocate () u Nothing allocs (Just (AList () u [opt])) sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s it "parses deallocate statement" $ do + let opt = AOStat () u (varGen "a") let allocs = fromList () [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ] in ExpSubscript () u (varGen "smt") indicies ] let s = StDeallocate () u allocs Nothing + let s' = StDeallocate () u allocs (Just (AList () u [opt])) sParser "deallocate (smt ( 20 ))" `shouldBe'` s + sParser "deallocate (smt ( 20 ), stat=a)" `shouldBe'` s' it "parses nullify statement" $ do let s = StNullify () u (fromList () [ varGen "x" ]) @@ -414,13 +422,17 @@ describe "Where block" $ do it "parses where construct statement" $ - sParser "where (.true.)" `shouldBe'` StWhereConstruct () u valTrue + sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue it "parses elsewhere statement" $ - sParser "elsewhere" `shouldBe'` StElsewhere () u + sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing + it "parses elsewhere statement" $ do + let exp = ExpBinary () u GT (varGen "a") (varGen "b") + sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp) + it "parses endwhere statement" $ - sParser "endwhere" `shouldBe'` StEndWhere () u + sParser "endwhere" `shouldBe'` StEndWhere () u Nothing describe "If" $ do it "parses if-then statement" $ @@ -530,9 +542,18 @@ let st = StWrite () u ciList (Just outList) sParser "write (10, FORMAT = x) (i, j, i = 1, 42, 2)" `shouldBe'` st - it "parses use statement" $ do + it "parses use statement with renames" $ do let renames = fromList () [ UseRename () u (varGen "sprod") (varGen "prod") , UseRename () u (varGen "a") (varGen "b") ] - let st = StUse () u (varGen "stats_lib") Permissive (Just renames) + let st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames) sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st + + it "parses use statement with only list" $ do + let onlys = fromList () + [ UseID () u (varGen "a") + , UseRename () u (varGen "b") (varGen "c") + , UseID () u (ExpValue () u (ValOperator "+")) + , UseID () u (ExpValue () u ValAssignment) ] + let st = StUse () u (varGen "stats_lib") Nothing Exclusive (Just onlys) + sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs --- a/test/Language/Fortran/Parser/Fortran95Spec.hs +++ b/test/Language/Fortran/Parser/Fortran95Spec.hs @@ -1,6 +1,6 @@ module Language.Fortran.Parser.Fortran95Spec (spec) where -import Prelude hiding (GT, EQ, NE) +import Prelude hiding (GT, EQ, exp, pred) import TestUtil import Test.Hspec @@ -14,10 +14,13 @@ import Data.Foldable(forM_) import qualified Data.ByteString.Char8 as B +{-# ANN module "HLint: ignore Reduce duplication" #-} + eParser :: String -> Expression () eParser sourceCode = case evalParse statementParser parseState of (StExpressionAssign _ _ _ e) -> e + _ -> error "unhandled evalParse" where paddedSourceCode = B.pack $ " a = " ++ sourceCode parseState = initParseState paddedSourceCode Fortran95 "" @@ -47,99 +50,104 @@ describe "Fortran 95 Parser" $ do describe "Function" $ do let puFunction = PUFunction () u - let fType = Nothing - let fOpt = None () u False - let fName = "f" - let fArgs = Nothing - let fRes = Nothing - let fBody = [] - let fSub = Nothing + fType = Nothing + fSuf = emptySuffixes + fPreSuf = emptyPrefixSuffix + fName = "f" + fArgs = Nothing + fRes = Nothing + fBody = [] + fSub = Nothing describe "End" $ do it "parses simple functions ending with \"end function [function name]\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f()" + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub + fStr = init $ unlines ["function f()" , "end function f" ] fParser fStr `shouldBe'` expected it "parses simple functions ending with \"end\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f()" + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub + fStr = init $ unlines ["function f()" , "end" ] fParser fStr `shouldBe'` expected it "parses simple functions ending with \"end function\"" $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f()" + let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub + fStr = init $ unlines ["function f()" , "end function" ] fParser fStr `shouldBe'` expected it "parses functions with return type specs" $ do - let fType = Just $ TypeSpec () u TypeInteger Nothing - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["integer function f()" + let fType' = Just $ TypeSpec () u TypeInteger Nothing + expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub + fStr = init $ unlines ["integer function f()" , "end function f" ] fParser fStr `shouldBe'` expected describe "parses function options (recursive, pure, elemental)" $ do let options_list = map unzip $ combination - [ ("recursive ", None () u True) - , ("pure ", Pure () u False) - , ("elemental ", Elemental () u) ] + [ ("recursive ", PfxRecursive () u) + , ("pure ", PfxPure () u) + , ("elemental ", PfxElemental () u) ] forM_ options_list (\(strs, opts) -> do - let str = foldr (++) "" strs - let fStr = str ++ (init $ unlines ["function f()", "end"]) - let opt = buildPUFunctionOpts opts - let expected = puFunction fType - case opt of - Left _ -> it ("Shouldn't parse: " ++ show fStr ++ ": " ++ show opt) $ evaluate (fParser fStr) `shouldThrow` anyIOException - Right fOpt -> - it ("Should parse: " ++ show fStr ++ ": " ++ show opt) $ do - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - fParser fStr `shouldBe'` expected + let isElem (PfxElemental {}) = True; isElem _ = False + isRec (PfxRecursive {}) = True; isRec _ = False + str = concat strs + fStr = str ++ init (unlines ["function f()", "end"]) + pfx = fromList' () opts + --let expected = puFunction fType + if any isElem opts && any isRec opts + then + it ("Shouldn't parse: " ++ show fStr ++ ": " ++ show opts) $ + evaluate (fParser fStr) `shouldThrow` anyIOException + else + it ("Should parse: " ++ show fStr ++ ": " ++ show opts) $ do + let expected' = puFunction fType (pfx, fSuf) fName fArgs fRes fBody fSub + fParser fStr `shouldBe'` expected' ) it "parses functions with a list of arguments" $ do - let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f(x, y, z)" + let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub + fStr = init $ unlines ["function f(x, y, z)" , "end function f" ] fParser fStr `shouldBe'` expected it "parses functions with a result variable" $ do - let fRes = Just $ varGen "i" - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f() result(i)" + let fRes' = Just $ varGen "i" + expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub + fStr = init $ unlines ["function f() result(i)" , "end function f" ] fParser fStr `shouldBe'` expected it "parses functions with function bodies" $ do let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) - let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) - let f2 = StExpressionAssign () u (varGen "i") decrementRHS - let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines ["function f()" - , " print *, i" - , " i = (i - 1)" + f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + f2 = StExpressionAssign () u (varGen "i") decrementRHS + fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub + fStr = init $ unlines ["function f()" + , " print *, i" + , " i = (i - 1)" , "end function f" ] fParser fStr `shouldBe'` expected it "parses complex functions" $ do - let fType = Just $ TypeSpec () u TypeInteger Nothing - let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] - let fRes = Just $ varGen "i" - let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) - let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) - let f2 = StExpressionAssign () u (varGen "i") decrementRHS - let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] - let expected = puFunction fType fOpt fName fArgs fRes fBody fSub - let fStr = init $ unlines [ "integer function f(x, y, z) result(i)" - , " print *, i" - , " i = (i - 1)" - , "end function f" ] + let fType' = Just $ TypeSpec () u TypeInteger Nothing + fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + fRes' = Just $ varGen "i" + decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + f2 = StExpressionAssign () u (varGen "i") decrementRHS + fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub + fStr = init $ unlines [ "integer function f(x, y, z) result(i)" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] fParser fStr `shouldBe'` expected describe "Expression" $ do @@ -153,7 +161,7 @@ describe "Custom operator" $ do let unOp = UnCustom ".inverse." - let unExp = ExpUnary () u unOp $ intGen 42 + unExp = ExpUnary () u unOp $ intGen 42 it "parses unary custom operator" $ eParser ".inverse. 42" `shouldBe'` unExp @@ -169,24 +177,24 @@ it "parses data ref" $ do let range = fromList () [ IxSingle () u Nothing $ intGen 10 ] - let sub = ExpSubscript () u (varGen "y") range - let innerRefExp = ExpDataRef () u (varGen "x") sub - let exp = ExpDataRef () u innerRefExp (varGen "z") + sub = ExpSubscript () u (varGen "y") range + innerRefExp = ExpDataRef () u (varGen "x") sub + exp = ExpDataRef () u innerRefExp (varGen "z") eParser "x % y(10) % z" `shouldBe'` exp it "parses section subscript" $ do let range = [ IxSingle () u Nothing $ intGen 10 , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2) , IxSingle () u Nothing $ varGen "y" ] - let exp = ExpSubscript () u (varGen "x") (fromList () range) + exp = ExpSubscript () u (varGen "x") (fromList () range) eParser "x (10, : 1 : 2, y)" `shouldBe'` exp describe "Statement" $ do it "data ref assignment" $ do let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ] - let subs = ExpSubscript () u (varGen "x") indicies - let lhs = ExpDataRef () u subs (varGen "y") - let st = StExpressionAssign () u lhs (intGen 1) + subs = ExpSubscript () u (varGen "x") indicies + lhs = ExpDataRef () u subs (varGen "y") + st = StExpressionAssign () u lhs (intGen 1) sParser "x(1) % y = 1" `shouldBe'` st it "doesn't parse assign statements" $ do @@ -196,75 +204,75 @@ it "doesn't parse pause statements" $ do let stStr = "PAUSE" evaluate (sParser stStr) `shouldThrow` anyIOException - + it "doesn't parse pause statements with expression" $ do let stStr = "PAUSE \"MESSAGE\"" evaluate (sParser stStr) `shouldThrow` anyIOException it "parses declaration with attributes" $ do let typeSpec = TypeSpec () u TypeReal Nothing - let attrs = AList () u [ AttrExternal () u + attrs = AList () u [ AttrExternal () u , AttrIntent () u Out , AttrDimension () u $ AList () u [ DimensionDeclarator () u (Just $ intGen 3) (Just $ intGen 10) ] ] - let declarators = AList () u + declarators = AList () u [ DeclVariable () u (varGen "x") Nothing Nothing , DeclVariable () u (varGen "y") Nothing Nothing ] - let expected = StDeclaration () u typeSpec (Just attrs) declarators - let stStr = "real, external, intent (out), dimension (3:10) :: x, y" + expected = StDeclaration () u typeSpec (Just attrs) declarators + stStr = "real, external, intent (out), dimension (3:10) :: x, y" sParser stStr `shouldBe'` expected it "parses declaration with old syntax" $ do let typeSpec = TypeSpec () u TypeLogical Nothing - let declarators = AList () u + declarators = AList () u [ DeclVariable () u (varGen "x") Nothing Nothing , DeclVariable () u (varGen "y") Nothing Nothing ] - let expected = StDeclaration () u typeSpec Nothing declarators - let stStr = "logical x, y" + expected = StDeclaration () u typeSpec Nothing declarators + stStr = "logical x, y" sParser stStr `shouldBe'` expected it "parses declaration with initialisation" $ do let typeSpec = TypeSpec () u TypeComplex Nothing - let init = ExpValue () u (ValComplex (intGen 24) (realGen 42.0)) - let declarators = AList () u - [ DeclVariable () u (varGen "x") Nothing (Just init) ] - let expected = StDeclaration () u typeSpec Nothing declarators - let stStr = "complex :: x = (24, 42.0)" + init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double))) + declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing (Just init') ] + expected = StDeclaration () u typeSpec Nothing declarators + stStr = "complex :: x = (24, 42.0)" sParser stStr `shouldBe'` expected it "parses declaration of custom type" $ do let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing - let declarators = AList () u + declarators = AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ] - let expected = StDeclaration () u typeSpec Nothing declarators - let stStr = "type (MeineType) :: x" + expected = StDeclaration () u typeSpec Nothing declarators + stStr = "type (MeineType) :: x" sParser stStr `shouldBe'` expected it "parses declaration type with kind selector" $ do let selector = Selector () u Nothing (Just $ varGen "hello") - let typeSpec = TypeSpec () u TypeInteger (Just selector) - let declarators = AList () u + typeSpec = TypeSpec () u TypeInteger (Just selector) + declarators = AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ] - let expected = StDeclaration () u typeSpec Nothing declarators - let stStr = "integer (hello) :: x" + expected = StDeclaration () u typeSpec Nothing declarators + stStr = "integer (hello) :: x" sParser stStr `shouldBe'` expected it "parses intent statement" $ do let stStr = "intent (inout) :: a" - let expected = StIntent () u InOut (fromList () [ varGen "a" ]) + expected = StIntent () u InOut (fromList () [ varGen "a" ]) sParser stStr `shouldBe'` expected it "parses optional statement" $ do let stStr = "optional x" - let expected = StOptional () u (fromList () [ varGen "x" ]) + expected = StOptional () u (fromList () [ varGen "x" ]) sParser stStr `shouldBe'` expected it "parses public statement" $ do let stStr = "public :: x" - let expected = StPublic () u (Just $ fromList () [ varGen "x" ]) + expected = StPublic () u (Just $ fromList () [ varGen "x" ]) sParser stStr `shouldBe'` expected it "parses public assignment" $ do @@ -280,47 +288,47 @@ it "parses save statement" $ do let list = [ varGen "hello", varGen "bye" ] - let expected = StSave () u (Just $ fromList () list) - let stStr = "save /hello/, bye" + expected = StSave () u (Just $ fromList () list) + stStr = "save /hello/, bye" sParser stStr `shouldBe'` expected it "parses parameter statement" $ do let ass1 = DeclVariable () u (varGen "x") Nothing (Just $ intGen 10) - let ass2 = DeclVariable () u (varGen "y") Nothing (Just $ intGen 20) - let expected = StParameter () u (fromList () [ ass1, ass2 ]) + ass2 = DeclVariable () u (varGen "y") Nothing (Just $ intGen 20) + expected = StParameter () u (fromList () [ ass1, ass2 ]) sParser "parameter (x = 10, y = 20)" `shouldBe'` expected describe "FORALL blocks" $ do let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2) - let tripletSpecList = [("i", intGen 1, varGen "n", stride)] + tripletSpecList = [("i", intGen 1, varGen "n", stride)] it "parses basic FORALL blocks" $ do let stStr = "FORALL (I=1:N, I /= 2)" - let expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing) + expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing) sParser stStr `shouldBe'` expected describe "FORALL statements" $ do let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2) - let tripletSpecList = [("i", intGen 1, varGen "n", 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]) - let eAssign = StExpressionAssign () u expSub1 expSub2 + tripletSpecList = [("i", intGen 1, varGen "n", 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]) + --let eAssign = StExpressionAssign () u expSub1 expSub2 it "parses basic FORALL statements" $ do let stStr = "FORALL (I=1:N, I /= 2)" -- A(I,I) = X(I)" - let expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)-- eAssign + expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)-- eAssign sParser stStr `shouldBe'` expected describe "ENDFORALL statements" $ do it "parses FORALL end statements" $ do let stStr = "ENDFORALL" - let expected = StEndForall () u Nothing + expected = StEndForall () u Nothing sParser stStr `shouldBe'` expected it "parses FORALL end statements with label" $ do let stStr = "ENDFORALL A" - let expected = StEndForall () u $ Just "a" + expected = StEndForall () u $ Just "a" sParser stStr `shouldBe'` expected describe "Implicit" $ do @@ -329,46 +337,46 @@ sParser "implicit none" `shouldBe'` st it "parses implicit with single" $ do - let typeSpec = TypeSpec () u TypeCharacter Nothing - let impEls = [ ImpCharacter () u "k" ] - let impLists = [ ImpList () u typeSpec (fromList () impEls) ] - let st = StImplicit () u (Just $ fromList () impLists) + let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) 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 - let impEls = [ ImpRange () u "x" "z" ] - let impLists = [ ImpList () u typeSpec (fromList () impEls) ] - let st = StImplicit () u (Just $ fromList () impLists) + 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 - let typeSpec2 = TypeSpec () u TypeInteger Nothing - let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ] - let impEls2 = [ ImpRange () u "x" "z" ] - let impLists = [ ImpList () u typeSpec1 (fromList () impEls1) + let typeSpec1 = TypeSpec () u (TypeCharacter Nothing Nothing) 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) ] - let st = StImplicit () u (Just $ fromList () impLists) + st = StImplicit () u (Just $ fromList () impLists) sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st describe "Data" $ do it "parses vanilla" $ do let nlist = fromList () [ varGen "x", varGen "y" ] - let vlist = fromList () [ intGen 1, intGen 2 ] - let list = [ DataGroup () u nlist vlist ] - let expected = StData () u (fromList () list) - let stStr = "data x,y/1,2/" + vlist = fromList () [ intGen 1, intGen 2 ] + list = [ DataGroup () u nlist vlist ] + expected = StData () u (fromList () list) + stStr = "data x,y/1,2/" sParser stStr `shouldBe'` expected describe "Delimeter" $ do let [ nlist1, vlist1 ] = map (fromList () . return) [ varGen "x", intGen 1 ] - let [ nlist2, vlist2 ] = + [ nlist2, vlist2 ] = map (fromList () . return) [ varGen "y", intGen 2 ] - let list = [ DataGroup () u nlist1 vlist1 + list = [ DataGroup () u nlist1 vlist1 , DataGroup () u nlist2 vlist2 ] - let expected = StData () u (fromList () list) + expected = StData () u (fromList () list) it "parses comma delimited init groups" $ sParser "data x/1/, y/2/" `shouldBe'` expected @@ -379,9 +387,9 @@ describe "Namelist" $ do let groupNames = [ ExpValue () u (ValVariable "something") , ExpValue () u (ValVariable "other") ] - let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] , fromList () [ varGen "y" ] ] - let st = StNamelist () u $ + st = StNamelist () u $ fromList () [ Namelist () u (head groupNames) (head itemss) , Namelist () u (last groupNames) (last itemss) ] @@ -394,9 +402,9 @@ describe "Common" $ do let commonNames = [ ExpValue () u (ValVariable "something") , ExpValue () u (ValVariable "other") ] - let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] , fromList () [ varGen "y" ] ] - let st = StCommon () u $ fromList () + st = StCommon () u $ fromList () [ CommonGroup () u Nothing (fromList () [ varGen "q" ]) , CommonGroup () u (Just $ head commonNames) (head itemss) , CommonGroup () u (Just $ last commonNames) (last itemss) ] @@ -423,17 +431,17 @@ in ExpSubscript () u (varGen "d") indicies ] ] - let st = StEquivalence () u eqALists + st = StEquivalence () u eqALists sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st describe "Dynamic allocation" $ do it "parses allocate statement" $ do - let controlPair = ControlPair () u (Just "stat") (varGen "a") - let allocs = fromList () + let opt = AOStat () u (varGen "a") + allocs = fromList () [ varGen "x" , ExpDataRef () u (varGen "st") (varGen "part") ] - let s = StAllocate () u allocs (Just controlPair) + s = StAllocate () u Nothing allocs (Just (AList () u [opt])) sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s it "parses deallocate statement" $ do @@ -441,7 +449,7 @@ [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ] in ExpSubscript () u (varGen "smt") indicies ] - let s = StDeallocate () u allocs Nothing + s = StDeallocate () u allocs Nothing sParser "deallocate (smt ( 20 ))" `shouldBe'` s it "parses nullify statement" $ do @@ -450,26 +458,30 @@ it "parses pointer assignment" $ do let src = ExpDataRef () u (varGen "x") (varGen "y") - let st = StPointerAssign () u src (varGen "exp") + st = StPointerAssign () u src (varGen "exp") sParser "x % y => exp" `shouldBe'` st describe "Where" $ do it "parses where statement" $ do let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp") - let pred = ExpBinary () u GT (varGen "temp") (intGen 100) - let assignment = StExpressionAssign () u (varGen "temp") exp - let st = StWhere () u pred assignment + pred = ExpBinary () u GT (varGen "temp") (intGen 100) + assignment = StExpressionAssign () u (varGen "temp") exp + st = StWhere () u pred assignment sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st describe "Where block" $ do it "parses where construct statement" $ - sParser "where (.true.)" `shouldBe'` StWhereConstruct () u valTrue + sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue it "parses elsewhere statement" $ - sParser "elsewhere" `shouldBe'` StElsewhere () u + sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing + it "parses elsewhere statement" $ do + let exp = ExpBinary () u GT (varGen "a") (varGen "b") + sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp) + it "parses endwhere statement" $ - sParser "endwhere" `shouldBe'` StEndWhere () u + sParser "endwhere" `shouldBe'` StEndWhere () u Nothing describe "If" $ do it "parses if-then statement" $ @@ -490,7 +502,7 @@ it "parses logical if statement" $ do let assignment = StExpressionAssign () u (varGen "a") (varGen "b") - let stIf = StIfLogical () u valTrue assignment + stIf = StIfLogical () u valTrue assignment sParser "if (.true.) a = b" `shouldBe'` stIf it "parses arithmetic if statement" $ do @@ -522,14 +534,14 @@ describe "Do" $ do it "parses do statement with label" $ do let assign = StExpressionAssign () u (varGen "i") (intGen 0) - let doSpec = DoSpecification () u assign (intGen 42) Nothing - let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) + doSpec = DoSpecification () u assign (intGen 42) Nothing + st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) sParser "do 24, i = 0, 42" `shouldBe'` st it "parses do statement without label" $ do let assign = StExpressionAssign () u (varGen "i") (intGen 0) - let doSpec = DoSpecification () u assign (intGen 42) Nothing - let st = StDo () u Nothing Nothing (Just doSpec) + doSpec = DoSpecification () u assign (intGen 42) Nothing + st = StDo () u Nothing Nothing (Just doSpec) sParser "do i = 0, 42" `shouldBe'` st it "parses infinite do" $ do @@ -551,13 +563,13 @@ it "parses computed goto" $ do let list = fromList () [ intGen 10, intGen 20, intGen 30 ] - let st = StGotoComputed () u list (intGen 20) + st = StGotoComputed () u list (intGen 20) sParser "goto (10, 20, 30) 20" `shouldBe'` st - it "doesn't parse assigned goto" $ do + it "doesn't parse assigned goto" $ evaluate (sParser "goto i, (10, 20, 30)") `shouldThrow` anyIOException - it "doesn't parse label assignment" $ do + it "doesn't parse label assignment" $ evaluate (sParser "assign 20 to l") `shouldThrow` anyIOException describe "IO" $ do @@ -567,18 +579,44 @@ it "parses write with implied do" $ do let cp1 = ControlPair () u Nothing (intGen 10) - let cp2 = ControlPair () u (Just "format") (varGen "x") - let ciList = fromList () [ cp1, cp2 ] - let assign = StExpressionAssign () u (varGen "i") (intGen 1) - let doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) - let alist = fromList () [ varGen "i", varGen "j" ] - let outList = fromList () [ ExpImpliedDo () u alist doSpec ] - let st = StWrite () u ciList (Just outList) + cp2 = ControlPair () u (Just "format") (varGen "x") + ciList = fromList () [ cp1, cp2 ] + assign = StExpressionAssign () u (varGen "i") (intGen 1) + doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) + alist = fromList () [ varGen "i", varGen "j" ] + outList = fromList () [ ExpImpliedDo () u alist doSpec ] + st = StWrite () u ciList (Just outList) sParser "write (10, FORMAT = x) (i, j, i = 1, 42, 2)" `shouldBe'` st it "parses use statement" $ do let renames = fromList () [ UseRename () u (varGen "sprod") (varGen "prod") , UseRename () u (varGen "a") (varGen "b") ] - let st = StUse () u (varGen "stats_lib") Permissive (Just renames) + let st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames) sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st + + it "parses value decl" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let st = StValue () u (AList () u decls) + sParser "value a, b" `shouldBe'` st + sParser "value :: a, b" `shouldBe'` st + + it "parses value attribute" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let ty = TypeSpec () u TypeInteger Nothing + let attrs = [AttrValue () u] + let st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls) + sParser "integer, value :: a, b" `shouldBe'` st + + it "parses volatile decl" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let st = StVolatile () u (AList () u decls) + sParser "volatile a, b" `shouldBe'` st + sParser "volatile :: a, b" `shouldBe'` st + + it "parses volatile attribute" $ do + let decls = [DeclVariable () u (varGen "a") Nothing Nothing, DeclVariable () u (varGen "b") Nothing Nothing] + let ty = TypeSpec () u TypeInteger Nothing + let attrs = [AttrVolatile () u] + let st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls) + sParser "integer, volatile :: a, b" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/UtilsSpec.hs b/test/Language/Fortran/Parser/UtilsSpec.hs --- a/test/Language/Fortran/Parser/UtilsSpec.hs +++ b/test/Language/Fortran/Parser/UtilsSpec.hs @@ -1,24 +1,23 @@ module Language.Fortran.Parser.UtilsSpec where import Test.Hspec -import TestUtil import Language.Fortran.Parser.Utils spec :: Spec spec = describe "Fortran Parser Utils" $ do - describe "readReal" $ do + describe "readReal" $ it "tests" $ do - readReal "+12" `shouldBe` Just (12) + readReal "+12" `shouldBe` Just 12 readReal "-1.2" `shouldBe` Just (-1.2) - readReal "1.2d3" `shouldBe` Just (1200) - readReal "1.e2" `shouldBe` Just (100) - readReal "1.e-2" `shouldBe` Just (0.01) - readReal ".12" `shouldBe` Just (0.12) + readReal "1.2d3" `shouldBe` Just 1200 + readReal "1.e2" `shouldBe` Just 100 + readReal "1.e-2" `shouldBe` Just 0.01 + readReal ".12" `shouldBe` Just 0.12 readReal "-.12" `shouldBe` Just (-0.12) - readReal "1_f" `shouldBe` Just (1) - describe "readInteger" $ do + readReal "1_f" `shouldBe` Just 1 + describe "readInteger" $ it "tests" $ do readInteger "b'101'" `shouldBe` Just 5 readInteger "o'22'" `shouldBe` Just 18 diff --git a/test/Language/Fortran/ParserMonadSpec.hs b/test/Language/Fortran/ParserMonadSpec.hs --- a/test/Language/Fortran/ParserMonadSpec.hs +++ b/test/Language/Fortran/ParserMonadSpec.hs @@ -1,13 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Language.Fortran.ParserMonadSpec where import Test.Hspec import Language.Fortran.ParserMonad -import Control.Monad.State.Lazy - import Language.Fortran.Util.Position vanillaParseState :: ParseState String @@ -28,7 +27,7 @@ data SomeInput = SomeInput { p :: Position } initPos :: Position -initPos = Position 5 1 2 +initPos = Position 5 1 2 "" Nothing initSomeInput :: SomeInput initSomeInput = SomeInput { p = initPos } @@ -52,16 +51,16 @@ spec = describe "ParserMonad" $ do describe "Parse" $ do - it "should give out correct version" $ do + it "should give out correct version" $ evalParse getVersion vanillaParseState `shouldBe` Fortran66 - it "satisfies read after write equals to what is written" $ do + it "satisfies read after write equals to what is written" $ let ai = evalParse (putAlex "l'enfer" >> getAlex) vanillaParseState in ai `shouldBe` "l'enfer" describe "Obtaining locations" $ do - it "getPosition returns correct location" $ do - let _expPosition = Position 6 2 3 + it "getPosition returns correct location" $ + let _expPosition = Position 6 2 3 "some.f" Nothing _exampleM = do _ai <- getAlex putAlex $ _ai { p = _expPosition } @@ -69,8 +68,8 @@ _loc = evalParse _exampleM vanillaSomeInput in _loc `shouldBe` _expPosition - it "getSrcSpan return correct location span" $ do - let _loc2 = Position 6 2 3 + it "getSrcSpan return correct location span" $ + let _loc2 = Position 6 2 3 "some.f" Nothing _exampleM = do _ai <- getAlex _loc1 <- getPosition @@ -81,13 +80,13 @@ _span `shouldBe` _expectation describe "Lex" $ do - it "reads the state correctly" $ do + it "reads the state correctly" $ evalParse getAlex vanillaParseState `shouldBe` "" - it "overrides the state correctly" $ do + it "overrides the state correctly" $ let ai = evalParse (putAlex "c'est" >> getAlex) vanillaParseState in ai `shouldBe` "c'est" - it "mixes operations correctly" $ do - let ai = evalParse (putAlex "hello" >> getAlex >>= \s -> (putAlex $ take 4 s) >> getAlex) vanillaParseState in + it "mixes operations correctly" $ + let ai = evalParse (putAlex "hello" >> getAlex >>= \s -> putAlex (take 4 s) >> getAlex) vanillaParseState in ai `shouldBe` "hell" 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 @@ -4,27 +4,20 @@ module Language.Fortran.PrettyPrintSpec where +import Prelude hiding (mod) import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (replace) import Data.Data -import Data.Foldable import Data.Generics.Uniplate.Operations import Data.Maybe (catMaybes) ---import Data.DeriveTH -import Control.Monad (void) - import Language.Fortran.AST as LFA import Language.Fortran.ParserMonad import Language.Fortran.PrettyPrint -import Language.Fortran.Parser.Any -import Language.Fortran.Util.Position -import Language.Fortran.Util.SecondParameter import System.FilePath -import System.Directory import Text.PrettyPrint import Text.PrettyPrint.GenericPretty @@ -102,11 +95,17 @@ let ed = FIHollerith () u (ValHollerith "hello darling") pprint Fortran77 ed Nothing `shouldBe` "13hhello darling" + describe "Flush statement" $ + it "prints flush statement" $ do + let f = StFlush () u (AList () u [ FSUnit () u (intGen 1), FSIOStat () u (varGen "x") + , FSIOMsg () u (varGen "y"), FSErr () u (varGen "z") ]) + pprint Fortran2003 f Nothing `shouldBe` "flush (unit=1, iostat=x, iomsg=y, err=z)" + describe "Statement" $ do describe "Declaration" $ do it "prints 90 style with attributes" $ do let sel = Selector () u (Just $ intGen 3) Nothing - let typeSpec = TypeSpec () u TypeCharacter (Just sel) + let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) (Just sel) let attrs = [ AttrIntent () u In , AttrPointer () u ] let declList = [ DeclVariable () u (varGen "x") Nothing (Just $ intGen 42) @@ -114,7 +113,7 @@ let st = StDeclaration () u typeSpec (Just $ AList () u attrs) (AList () u declList) - let expect = "character (len=3), intent(in), pointer :: x = 42, y*3" + let expect = "character(len=3), intent(in), pointer :: x = 42, y*3" pprint Fortran90 st Nothing `shouldBe` expect it "prints 77 style" $ do @@ -244,11 +243,17 @@ pprint Fortran90 st Nothing `shouldBe` "print *, 42" describe "Allocation" $ - describe "Allocate" $ + describe "Allocate" $ do it "prints allocate statement" $ do - let pair = ControlPair () u (Just "stat") (varGen "s") - let st = StAllocate () u (AList () u [ varGen "x" ]) (Just pair) + let stat = AOStat () u (varGen "s") + let st = StAllocate () u Nothing (AList () u [ varGen "x" ]) (Just (AList () u [stat])) pprint Fortran90 st Nothing `shouldBe` "allocate (x, stat=s)" + it "prints allocate statement with type spec" $ do + let stat = AOStat () u (varGen "s") + let sel = Selector () u (Just (intGen 30)) Nothing + let ty = TypeSpec () u (TypeCharacter (Just $ CharLenInt 30) Nothing) (Just sel) + let st = StAllocate () u (Just ty) (AList () u [ varGen "x" ]) (Just (AList () u [stat])) + pprint Fortran2003 st Nothing `shouldBe` "allocate (character(len=30) :: x, stat=s)" describe "Where" $ it "prints statement" $ do @@ -256,12 +261,22 @@ let stWhere = StWhere () u valTrue stAssign pprint Fortran90 stWhere Nothing `shouldBe` "where (.true.) x = 42" - describe "Use" $ - it "prints exlusive use statement" $ do + describe "Use" $ do + it "prints exclusive use statement" $ do let aRenames = AList () u [ UseRename () u (varGen "x") (varGen "y") ] - let st = StUse () u (varGen "my_mod") Exclusive (Just aRenames) + let st = StUse () u (varGen "my_mod") Nothing Exclusive (Just aRenames) pprint Fortran90 st Nothing `shouldBe` "use my_mod, only: x => y" + it "prints intrinsic use statement" $ do + let aRenames = AList () u [ UseRename () u (varGen "x") (varGen "y") ] + let st = StUse () u (varGen "my_mod") (Just ModIntrinsic) Exclusive (Just aRenames) + pprint Fortran2003 st Nothing `shouldBe` "use, intrinsic :: my_mod, only: x => y" + + it "prints non_intrinsic use statement" $ do + let aRenames = AList () u [ UseRename () u (varGen "x") (varGen "y") ] + let st = StUse () u (varGen "my_mod") (Just ModNonIntrinsic) Exclusive (Just aRenames) + pprint Fortran2003 st Nothing `shouldBe` "use, non_intrinsic :: my_mod, only: x => y" + let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) let st1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) let st2 = StExpressionAssign () u (varGen "i") decrementRHS @@ -417,7 +432,7 @@ pprint Fortran90 mod (Just 0) `shouldBe` text expect it "prints module with sub programs" $ do - let sub = PUSubroutine () u (None () u False) "sub" Nothing body Nothing + let sub = PUSubroutine () u emptyPrefixSuffix "sub" Nothing body Nothing let mod = PUModule () u "my_mod" body (Just [ sub ]) let expect = unlines [ " module my_mod" , " print *, i" @@ -435,7 +450,7 @@ describe "Subroutine" $ do it "prints recursive subroutine with args without sub programs" $ do let args = AList () u [ varGen "x", varGen "y", varGen "z" ] - let sub = PUSubroutine () u (None () u True) "sub" (Just args) body Nothing + let sub = PUSubroutine () u (Just (AList () u [PfxRecursive () u]), emptySuffixes) "sub" (Just args) body Nothing let expect = unlines [ "recursive subroutine sub(x, y, z)" , "print *, i" , "i = (i - 1)" @@ -443,7 +458,7 @@ pprint Fortran90 sub Nothing `shouldBe` text expect it "prints 66 style subroutine without args" $ do - let mod = PUSubroutine () u (None () u False) "sub" Nothing body Nothing + let mod = PUSubroutine () u emptyPrefixSuffix "sub" Nothing body Nothing let expect = unlines [ " subroutine sub" , " print *, i" , " i = (i - 1)" @@ -456,7 +471,7 @@ it "prints function with args with result without sub programs" $ do let args = AList () u [ varGen "x", varGen "y", varGen "z" ] let res = Just $ varGen "i" - let fun = PUFunction () u tSpec (None () u False) "f" (Just args) res body Nothing + let fun = PUFunction () u tSpec emptyPrefixSuffix "f" (Just args) res body Nothing let expect = unlines [ " integer function f(x, y, z) result(i)" , " print *, i" , " i = (i - 1)" @@ -465,8 +480,8 @@ describe "Program file" $ it "prints simple program file" $ do - let body = [ BlStatement () u Nothing (StContinue () u) ] - let pu = PUModule () u "my_mod" body Nothing + let body' = [ BlStatement () u Nothing (StContinue () u) ] + let pu = PUModule () u "my_mod" body' Nothing let com = PUComment () u (Comment "hello!") let pf = ProgramFile mi77 [com, pu, com, pu, com, com] let expect = unlines [ "!hello!" 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 @@ -4,11 +4,8 @@ import TestUtil import Language.Fortran.Analysis -import Language.Fortran.Analysis.Renaming -import Language.Fortran.Analysis.Types import Language.Fortran.AST import Language.Fortran.Transformer -import Language.Fortran.Transformation.TransformMonad disambiguateFunction :: ProgramFile () -> ProgramFile () disambiguateFunction = transform [ DisambiguateIntrinsic, DisambiguateFunction ] @@ -30,18 +27,37 @@ let pf = disambiguateFunction $ resetSrcSpan ex3 pf `shouldBe'` expectedEx3 + describe "Function call / Variable disambiguation" $ + it "disambiguates function calls in example 4" $ do + let pf = disambiguateFunction $ resetSrcSpan ex4 + pf `shouldBe'` expectedEx4 + + describe "Implicit Function call / Variable disambiguation" $ + it "disambiguates function calls in example 5" $ do + let pf = disambiguateFunction $ resetSrcSpan ex5 + pf `shouldBe'` expectedEx5 + + describe "Implicit array declaration with dimension disambiguation" $ + it "Should not disambiguation to a function call in example 6" $ do + let pf = disambiguateFunction $ resetSrcSpan ex6 + pf `shouldBe'` expectedEx6 + {- - program Main -- integer a, b(1), c +- integer a, b(1), c, e - dimension a(1) - a(1) = 1 - b(1) = 1 - c(x) = 1 - d(x) = 1 +- e() = 1 - end -} +ex1 :: ProgramFile () ex1 = ProgramFile mi77 [ ex1pu1 ] +ex1pu1 :: ProgramUnit () ex1pu1 = PUMain () u (Just "main") ex1pu1bs Nothing +ex1pu1bs :: [Block ()] ex1pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "a") Nothing Nothing @@ -56,10 +72,15 @@ , BlStatement () u Nothing (StExpressionAssign () u (ExpSubscript () u (varGen "c") (AList () u [ IxSingle () u Nothing $ varGen "x" ])) (intGen 1)) , BlStatement () u Nothing (StExpressionAssign () u - (ExpSubscript () u (varGen "d") (AList () u [ IxSingle () u Nothing $ varGen "x" ])) (intGen 1)) ] + (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)) ] +expectedEx1 :: ProgramFile () expectedEx1 = ProgramFile mi77 [ expectedEx1pu1 ] +expectedEx1pu1 :: ProgramUnit () expectedEx1pu1 = PUMain () u (Just "main") expectedEx1pu1bs Nothing +expectedEx1pu1bs :: [Block ()] expectedEx1pu1bs = [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "a") Nothing Nothing @@ -74,7 +95,9 @@ , BlStatement () u Nothing (StFunction () u (ExpValue () u $ ValVariable "c") (AList () u [ varGen "x" ]) (intGen 1)) , BlStatement () u Nothing (StFunction () u - (ExpValue () u $ ValVariable "d") (AList () u [ varGen "x" ]) (intGen 1)) ] + (ExpValue () u $ ValVariable "d") (AList () u [ varGen "x" ]) (intGen 1)) + , BlStatement () u Nothing (StFunction () u + (ExpValue () u $ ValVariable "e") (AList () u []) (intGen 1)) ] {- - program @@ -88,9 +111,13 @@ - function y(i,j) - end -} +ex2 :: ProgramFile () ex2 = ProgramFile mi77 [ ex2pu1, ex2pu2 ] +ex2pu1 :: ProgramUnit () ex2pu1 = PUMain () u Nothing ex2pu1bs Nothing -ex2pu2 = PUFunction () u Nothing (None () u False) "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex2pu2 :: ProgramUnit () +ex2pu2 = PUFunction () u Nothing emptyPrefixSuffix "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex2pu1bs :: [Block ()] ex2pu1bs = [ BlStatement () u Nothing (StFunction () u @@ -105,8 +132,11 @@ (varGen "f") (AList () u [ ixSinGen 1 ])))) ] +expectedEx2 :: ProgramFile () expectedEx2 = ProgramFile mi77 [ expectedEx2pu1, ex2pu2 ] +expectedEx2pu1 :: ProgramUnit () expectedEx2pu1 = PUMain () u Nothing expectedEx2pu1bs Nothing +expectedEx2pu1bs :: [Block ()] expectedEx2pu1bs = [ BlStatement () u Nothing (StFunction () u @@ -122,9 +152,13 @@ (Just $ AList () u [ Argument () u Nothing (intGen 1) ])))) ] +ex3 :: ProgramFile () ex3 = ProgramFile mi77 [ ex3pu1, ex3pu2 ] +ex3pu1 :: ProgramUnit () ex3pu1 = PUMain () u Nothing ex3pu1bs Nothing -ex3pu2 = PUFunction () u Nothing (None () u False) "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex3pu2 :: ProgramUnit () +ex3pu2 = PUFunction () u Nothing emptyPrefixSuffix "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex3pu1bs :: [Block ()] ex3pu1bs = [ BlStatement () u Nothing (StFunction () u @@ -135,10 +169,13 @@ (StExpressionAssign () u (varGen "i") (ExpSubscript () u (varGen "abs") (AList () u [ - (IxSingle () u Nothing (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ])))]))) ] + IxSingle () u Nothing (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ]))]))) ] +expectedEx3 :: ProgramFile () expectedEx3 = ProgramFile mi77 [ expectedEx3pu1, ex3pu2 ] +expectedEx3pu1 :: ProgramUnit () expectedEx3pu1 = PUMain () u Nothing expectedEx3pu1bs Nothing +expectedEx3pu1bs :: [Block ()] expectedEx3pu1bs = [ BlStatement () u Nothing (StFunction () u @@ -151,6 +188,110 @@ (Just $ AList () u [ Argument () u Nothing (ExpFunctionCall () u (ExpValue () u $ ValVariable "f") (Just $ AList () u [ Argument () u Nothing (intGen 1) ])) ]))) ] + + +{- +- program Main +- integer a, f +- a = f(1) +- end +-} + +ex4 :: ProgramFile () +ex4 = ProgramFile mi77 [ ex4pu1 ] +ex4pu1 :: ProgramUnit () +ex4pu1 = PUMain () u (Just "main") ex4pu1bs Nothing +ex4pu1bs :: [Block ()] +ex4pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclVariable () u (varGen "f") Nothing Nothing ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ]))) ] + +expectedEx4 :: ProgramFile () +expectedEx4 = ProgramFile mi77 [ expectedEx4pu1 ] +expectedEx4pu1 :: ProgramUnit () +expectedEx4pu1 = PUMain () u (Just "main") expectedEx4pu1bs Nothing + +expectedEx4pu1bs :: [Block ()] +expectedEx4pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclVariable () u (varGen "f") Nothing Nothing ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") + (ExpFunctionCall () u (ExpValue () u $ ValVariable "f") + (Just $ AList () u [ Argument () u Nothing (intGen 1) ] ))) ] + +{- +- program Main +- integer a +- a = f(1) +- end +-} + +ex5 :: ProgramFile () +ex5 = ProgramFile mi77 [ ex5pu1 ] +ex5pu1 :: ProgramUnit () +ex5pu1 = PUMain () u (Just "main") ex5pu1bs Nothing +ex5pu1bs :: [Block ()] +ex5pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ]))) ] + +expectedEx5 :: ProgramFile () +expectedEx5 = ProgramFile mi77 [ expectedEx5pu1 ] +expectedEx5pu1 :: ProgramUnit () +expectedEx5pu1 = PUMain () u (Just "main") expectedEx5pu1bs Nothing + +expectedEx5pu1bs :: [Block ()] +expectedEx5pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") + (ExpFunctionCall () u (ExpValue () u $ ValVariable "f") + (Just $ AList () u [ Argument () u Nothing (intGen 1) ] ))) ] + +{- +- program Main +- integer a +- dimension f(10) +- a = f(1) +- end +-} + +ex6 :: ProgramFile () +ex6 = ProgramFile mi77 [ ex6pu1 ] +ex6pu1 :: ProgramUnit () +ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing +ex6pu1bs :: [Block ()] +ex6pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "f") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ]))) ] + +expectedEx6 :: ProgramFile () +expectedEx6 = ProgramFile mi77 [ expectedEx6pu1 ] +expectedEx6pu1 :: ProgramUnit () +expectedEx6pu1 = PUMain () u (Just "main") expectedEx6pu1bs Nothing + +expectedEx6pu1bs :: [Block ()] +expectedEx6pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "f") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "a") (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ]))) ] -- Local variables: -- mode: haskell 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 @@ -1,27 +1,36 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module Language.Fortran.Transformation.GroupingSpec where import Test.Hspec hiding (Selector) import TestUtil import Control.Exception (evaluate) -import Control.DeepSeq (force, ($!!), NFData) +import Control.DeepSeq (force, NFData) +import Data.ByteString.Char8 (ByteString, pack) import Language.Fortran.Transformer import Language.Fortran.AST import Language.Fortran.Util.Position import Language.Fortran.ParserMonad +import Language.Fortran.Parser.Fortran95 +import Language.Fortran.Parser.Fortran77 +groupIf :: ProgramFile () -> ProgramFile () groupIf = transform [ GroupIf ] +groupDo :: ProgramFile () -> ProgramFile () groupDo = transform [ GroupLabeledDo ] +groupForall :: ProgramFile () -> ProgramFile () groupForall = transform [ GroupForall ] instance NFData MetaInfo instance NFData FortranVersion instance NFData SrcSpan instance NFData Position +instance NFData CharacterLen instance NFData BaseType instance NFData UnaryOp instance NFData BinaryOp instance NFData Only +instance NFData ModuleNature instance NFData Intent instance (NFData a, NFData (t a)) => NFData (AList t a) instance NFData a => NFData (ProgramFile a) @@ -33,6 +42,8 @@ instance NFData a => NFData (Value a) instance NFData a => NFData (Comment a) instance NFData a => NFData (Statement a) +instance NFData a => NFData (ProcDecl a) +instance NFData a => NFData (ProcInterface a) instance NFData a => NFData (DoSpecification a) instance NFData a => NFData (Selector a) instance NFData a => NFData (ForallHeader a) @@ -41,14 +52,17 @@ instance NFData a => NFData (Attribute a) instance NFData a => NFData (CommonGroup a) instance NFData a => NFData (ControlPair a) +instance NFData a => NFData (AllocOpt a) instance NFData a => NFData (DataGroup a) instance NFData a => NFData (DimensionDeclarator a) instance NFData a => NFData (Declarator a) instance NFData a => NFData (FormatItem a) +instance NFData a => NFData (FlushSpec a) instance NFData a => NFData (ImpElement a) instance NFData a => NFData (ImpList a) instance NFData a => NFData (Namelist a) -instance NFData a => NFData (PUFunctionOpt a) +instance NFData a => NFData (Prefix a) +instance NFData a => NFData (Suffix a) instance NFData a => NFData (StructureItem a) instance NFData a => NFData (UnionMap a) @@ -57,9 +71,9 @@ let name = Just "name" let endName = Just "endName" describe "Block FORALL statements" $ do - it "groups unlabelled FORALL blocks" $ do + it "groups unlabelled FORALL blocks" $ groupForall (exampleForall Nothing Nothing) `shouldBe'` expectedForall Nothing - it "groups unlabelled FORALL blocks" $ do + it "groups unlabelled FORALL blocks" $ groupForall (exampleForall name name) `shouldBe'` expectedForall name it "groups unlabelled FORALL blocks" $ do let lhs = (evaluate . force) (groupForall $ exampleForall name endName) @@ -78,28 +92,51 @@ it "do group example2 with common end-point" $ groupDo example2do `shouldBe` expectedExample2do + describe "Block SrcSpan's" $ do + it "Spans all a BlIf" $ + ifSpan `shouldBe` expectedIfSpan + it "spans all a BlDo" $ + doSpan `shouldBe` expectedDoSpan + it "spans all a BlDoWhile" $ + doWhileSpan `shouldBe` expectedDoWhileSpan + + describe "Inner block SrcSpan's" $ do + it "Spans the inner blocks of an if including comments - 77" $ + ifInnerBlockSpan getSingleParsedBlock77 `shouldBe` expectedIfInnerBlockSpan + it "Spans the inner blocks of an if including comments - 77 legacy" $ + ifInnerBlockSpan getSingleParsedBlock77Legacy `shouldBe` expectedIfInnerBlockSpan + +buildExampleProgram :: Name -> [Block ()] -> ProgramFile () buildExampleProgram name blocks = ProgramFile mi77 [ PUMain () u (Just name) blocks Nothing ] +exampleComment :: Block () exampleComment = BlComment () u $ Comment "comment" +exampleHeader :: ForallHeader a exampleHeader = ForallHeader [] Nothing -exampleForall name nameEnd = buildExampleProgram "forall" $ +exampleForall :: Maybe String -> Maybe String -> ProgramFile () +exampleForall name nameEnd = buildExampleProgram "forall" [ BlStatement () u Nothing $ StForall () u name exampleHeader , exampleComment , BlStatement () u Nothing $ StEndForall () u nameEnd ] -expectedForall name = buildExampleProgram "forall" $ +expectedForall :: Maybe String -> ProgramFile () +expectedForall name = buildExampleProgram "forall" [BlForall () u Nothing name exampleHeader [exampleComment] Nothing] -- if (.true.) then -- end if +example1 :: ProgramFile () example1 = ProgramFile mi77 [ PUMain () u (Just "example1") example1Blocks Nothing ] +example1Blocks :: [Block ()] example1Blocks = [ BlStatement () u Nothing (StIfThen () u Nothing valTrue) , BlStatement () u Nothing (StEndif () u Nothing) ] +expectedExample1 :: ProgramFile () expectedExample1 = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1Blocks Nothing ] +expectedExample1Blocks :: [Block ()] expectedExample1Blocks = [ BlIf () u Nothing Nothing [ Just valTrue ] [ [ ] ] Nothing ] -- if (.true.) then @@ -111,7 +148,9 @@ -- if (.false.) then -- endif -- end if +example2 :: ProgramFile () example2 = ProgramFile mi77 [ PUMain () u (Just "example2") example2Blocks Nothing ] +example2Blocks :: [Block ()] example2Blocks = [ BlStatement () u Nothing (StIfThen () u Nothing valTrue) , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ])) @@ -123,40 +162,53 @@ , BlStatement () u Nothing (StEndif () u Nothing) , BlStatement () u Nothing (StEndif () u Nothing) ] +expectedExample2 :: ProgramFile () expectedExample2 = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2Blocks Nothing ] +expectedExample2Blocks :: [Block ()] expectedExample2Blocks = [ BlIf () u Nothing Nothing [ Just valTrue, Just valTrue, Nothing ] blockGroups Nothing ] +blockGroups :: [[Block ()]] blockGroups = [ [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ])) , innerIf ] , [ ] , [ innerIf ] ] +innerIf :: Block () innerIf = BlIf () u Nothing Nothing [ Just valFalse ] [ [ ] ] Nothing -- do 10 i = 0, 10 -- 10 continue +label10 :: Maybe (Expression ()) label10 = Just (ExpValue () u (ValInteger "10")) +example1do :: ProgramFile () example1do = ProgramFile mi77 [ PUMain () u (Just "example1") example1doblocks Nothing ] +example1doblocks :: [Block ()] example1doblocks = [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) , BlStatement () u label10 (StContinue () u) ] +dospec :: Maybe (DoSpecification ()) dospec = Just (DoSpecification () u (StExpressionAssign () u (ExpValue () u (ValVariable "i")) (ExpValue () u (ValInteger "0"))) (ExpValue () u (ValInteger "10")) Nothing) +expectedExample1do :: ProgramFile () expectedExample1do = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1doBlocks Nothing ] +expectedExample1doBlocks :: [Block ()] expectedExample1doBlocks = [ BlDo () u Nothing Nothing label10 dospec - [BlStatement () u label10 (StContinue () u)] label10 ] + [ ] label10 ] +label20 :: Maybe (Expression ()) label20 = Just (ExpValue () u (ValInteger "20")) -- do 10 i = 0, 10 -- do 10 i = 0, 10 -- 10 continue -- do 20 i = 0, 10 -- 20 continue +example2do :: ProgramFile () example2do = ProgramFile mi77 [ PUMain () u (Just "example2") example2doblocks Nothing ] +example2doblocks :: [Block ()] example2doblocks = [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) , BlStatement () u Nothing (StDo () u Nothing label10 dospec) @@ -165,12 +217,93 @@ , BlStatement () u label20 (StContinue () u) ] +expectedExample2do :: ProgramFile () expectedExample2do = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2doBlocks Nothing ] +expectedExample2doBlocks :: [Block ()] expectedExample2doBlocks = [ BlDo () u Nothing Nothing label10 dospec [ BlDo () u Nothing Nothing label10 dospec - [ BlStatement () u label10 (StContinue () u) ] label10 + [ ] label10 ] label10 , BlDo () u Nothing Nothing label20 dospec - [ BlStatement () u label20 (StContinue () u) ] label20 + [ ] label20 ] + +getSingleParsedBlock :: Show b => (ByteString -> String -> ParseResult a b (ProgramFile A0)) -> String -> Block A0 +getSingleParsedBlock p c = + let pf = fromRight . fromParseResult $ p (pack c) "foobar.f" + ProgramFile _ ((PUSubroutine _ _ _ _ _ (b:_) _):_) = pf + in b + +getSingleParsedBlock95 :: String -> Block A0 +getSingleParsedBlock95 = getSingleParsedBlock fortran95Parser + +getSingleParsedBlock77 :: String -> Block A0 +getSingleParsedBlock77 = getSingleParsedBlock fortran77Parser + +getSingleParsedBlock77Legacy :: String -> Block A0 +getSingleParsedBlock77Legacy = getSingleParsedBlock legacy77Parser + +type SimpleSpan = (Int, Int, Int, Int) + +simplifySpan :: SrcSpan -> SimpleSpan +simplifySpan (SrcSpan b e) = (posLine b, posColumn b, posLine e, posColumn e) + +ifSpanRaw :: String +ifSpanRaw = unlines [ + " subroutine foobar" + , " if (.TRUE.) then" + , " print *, 'w00t'" + , " endif" + , " end" ] +ifSpan :: SimpleSpan +ifSpan = + let BlIf _ s _ _ _ _ _ = getSingleParsedBlock95 ifSpanRaw + in simplifySpan s +expectedIfSpan :: SimpleSpan +expectedIfSpan = (2, 8, 4, 12) + +doSpanRaw :: String +doSpanRaw = unlines [ + " subroutine foobar2" + , " do ii = 2, 5" + , " if(ii .eq. 2) print *, ii" + , " if(ii .eq. 4) print *, ii" + , " end do" + , " end" ] +doSpan :: SimpleSpan +doSpan = + let BlDo _ s _ _ _ _ _ _ = getSingleParsedBlock95 doSpanRaw + in simplifySpan s +expectedDoSpan :: SimpleSpan +expectedDoSpan = (2, 8, 5, 13) + +doWhileSpanRaw :: String +doWhileSpanRaw = unlines [ + " subroutine barfoo" + , " do while (.true.)" + , " print *, 'foooo'" + , " enddo" + , " end" ] +doWhileSpan :: SimpleSpan +doWhileSpan = + let BlDoWhile _ s _ _ _ _ _ _ = getSingleParsedBlock95 doWhileSpanRaw + in simplifySpan s +expectedDoWhileSpan :: SimpleSpan +expectedDoWhileSpan = (2, 8, 4, 12) + +ifInnerBlockSpanRaw :: String +ifInnerBlockSpanRaw = unlines [ + " subroutine yeet" + , " if (.true.) then" + , "c very important comment" + , " print *, 'yeet'" + , "c even more important comment" + , " endif" + , " end" ] +ifInnerBlockSpan :: (String -> Block A0) -> SimpleSpan +ifInnerBlockSpan p = + let BlIf _ _ _ _ _ bs _ = p ifInnerBlockSpanRaw + in simplifySpan $ getSpan bs +expectedIfInnerBlockSpan :: SimpleSpan +expectedIfInnerBlockSpan = (3, 1, 5, 35) diff --git a/test/Language/Fortran/Util/FirstParameterSpec.hs b/test/Language/Fortran/Util/FirstParameterSpec.hs --- a/test/Language/Fortran/Util/FirstParameterSpec.hs +++ b/test/Language/Fortran/Util/FirstParameterSpec.hs @@ -12,47 +12,47 @@ data A = A Int deriving (Generic, Eq, Show) data B = B Char Char Int Char deriving (Generic, Eq, Show) -data C = CA ([Int]) Char | CB ([Int]) Int deriving (Generic, Eq, Show) +data C = CA [Int] Char | CB [Int] Int deriving (Generic, Eq, Show) data D = DA () | DB () | DC () | DD () | DE () deriving (Generic, Eq, Show) instance FirstParameter A Int instance FirstParameter B Char -instance FirstParameter C ([Int]) +instance FirstParameter C [Int] instance FirstParameter D () spec :: Spec -spec = +spec = describe "First parameter accessor type class" $ do describe "data A" $ do - it "retrieves first parameter from 'A 42'" $ do + it "retrieves first parameter from 'A 42'" $ getFirstParameter (A 42) `shouldBe` 42 - it "sets first parameter in 'A 42' to 24" $ do + it "sets first parameter in 'A 42' to 24" $ setFirstParameter 24 (A 42) `shouldBe` A 24 describe "data B" $ do - it "retrieves first parameter from \"B 'x' 'y' 42 'z'\"" $ do + it "retrieves first parameter from \"B 'x' 'y' 42 'z'\"" $ getFirstParameter (B 'x' 'y' 42 'z') `shouldBe` 'x' - it "sets first parameter in \"B 'x' 'y' 42 'z'\" to 'm'" $ do - setFirstParameter 'm' (B 'x' 'y' 42 'z') `shouldBe` (B 'm' 'y' 42 'z') + it "sets first parameter in \"B 'x' 'y' 42 'z'\" to 'm'" $ + setFirstParameter 'm' (B 'x' 'y' 42 'z') `shouldBe` B 'm' 'y' 42 'z' describe "data C" $ do - it "retrieves first parameter from 'CA [1,2,3] 'a''" $ do + it "retrieves first parameter from 'CA [1,2,3] 'a''" $ getFirstParameter (CA [1,2,3] 'a') `shouldBe` [1,2,3] - it "retrieves first parameter from \"CB [1,2,3] 'a'\"" $ do + it "retrieves first parameter from \"CB [1,2,3] 'a'\"" $ getFirstParameter (CB [] 42) `shouldBe` [] - it "sets first parameter in \"CB [1,2,3] 'a'\" to '[]'" $ do - setFirstParameter [] (CA [1,2,3] 'a') `shouldBe` (CA [] 'a') + it "sets first parameter in \"CB [1,2,3] 'a'\" to '[]'" $ + setFirstParameter [] (CA [1,2,3] 'a') `shouldBe` CA [] 'a' describe "data D" $ do - it "retrieves first parameter from 'DB ()" $ do + it "retrieves first parameter from 'DB ()" $ getFirstParameter (DB ()) `shouldBe` () - it "retrieves first parameter from 'DD ()" $ do + it "retrieves first parameter from 'DD ()" $ getFirstParameter (DD ()) `shouldBe` () - it "retrieves first parameter from 'DE ()" $ do + it "retrieves first parameter from 'DE ()" $ getFirstParameter (DE ()) `shouldBe` () diff --git a/test/Language/Fortran/Util/SecondParameterSpec.hs b/test/Language/Fortran/Util/SecondParameterSpec.hs --- a/test/Language/Fortran/Util/SecondParameterSpec.hs +++ b/test/Language/Fortran/Util/SecondParameterSpec.hs @@ -12,44 +12,44 @@ data A = A Char Int deriving (Generic, Eq, Show) data B = B Int Int Int Int deriving (Generic, Eq, Show) -data C = CA String [Char] | CB Int [Char] () deriving (Generic, Eq, Show) +data C = CA String String | CB Int String () deriving (Generic, Eq, Show) data D = DA () () | DB Int () Int Int Int Int Int Int Int | DC () () | DD () () Char deriving (Generic, Eq, Show) instance SecondParameter A Int instance SecondParameter B Int -instance SecondParameter C [Char] +instance SecondParameter C String instance SecondParameter D () spec :: Spec spec = describe "Second parameter retrieving type class" $ do describe "data A" $ do - it "retrieves second parameter from 'A 'a' 42'" $ do + it "retrieves second parameter from 'A 'a' 42'" $ getSecondParameter (A 'x' 42) `shouldBe` 42 - it "sets second parameter in \"A 'a' 42\" to 24" $ do + it "sets second parameter in \"A 'a' 42\" to 24" $ setSecondParameter 24 (A 'x' 42) `shouldBe` A 'x' 24 describe "data B" $ do - it "retrieves second parameter from 'B 41 42 43 44'" $ do + it "retrieves second parameter from 'B 41 42 43 44'" $ getSecondParameter (B 41 42 43 44) `shouldBe` 42 - it "sets second parameter in \"B 41 42 43 44\" to 24" $ do + it "sets second parameter in \"B 41 42 43 44\" to 24" $ setSecondParameter 24 (B 41 42 43 44) `shouldBe` B 41 24 43 44 describe "data C" $ do - it "retrieves second parameter from 'CA \"hello\" ['x', 'y']'" $ do + it "retrieves second parameter from 'CA \"hello\" ['x', 'y']'" $ getSecondParameter (CA "hello" ['x', 'y']) `shouldBe` ['x', 'y'] - it "retrieves second parameter from 'CB 42 [] ()'" $ do + it "retrieves second parameter from 'CB 42 [] ()'" $ getSecondParameter (CB 42 [] ()) `shouldBe` [] - it "sets second parameter in \"CB 42 []\" to ['x','x','x']" $ do + it "sets second parameter in \"CB 42 []\" to ['x','x','x']" $ setSecondParameter "xxx" (CB 42 [] ()) `shouldBe` CB 42 "xxx" () describe "data d" $ do - it "retrieves second parameter from 'DB 42 () 42 42 42 42 42 42 42'" $ do + it "retrieves second parameter from 'DB 42 () 42 42 42 42 42 42 42'" $ getSecondParameter (DB 42 () 42 42 42 42 42 42 42) `shouldBe` () - it "retrieves second parameter from 'DD () () 'a'" $ do + it "retrieves second parameter from 'DD () () 'a'" $ getSecondParameter (DD () () 'a') `shouldBe` () diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -12,22 +12,27 @@ import Language.Fortran.Util.Position import Language.Fortran.Analysis -import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis.Renaming import qualified Data.Map as M import Data.Maybe +u :: SrcSpan u = initSrcSpan +mi77 :: MetaInfo mi77 = MetaInfo { miVersion = Fortran77, miFilename = "" } +mi90 :: MetaInfo mi90 = MetaInfo { miVersion = Fortran90, miFilename = "" } +valTrue :: Expression () valTrue = ExpValue () u $ ValLogical ".true." +valFalse :: Expression () valFalse = ExpValue () u $ ValLogical ".false." varGen :: String -> Expression () varGen str = ExpValue () u $ ValVariable str -intGen :: (Show a, Integral a) => a -> Expression () +intGen :: Integer -> Expression () intGen i = ExpValue () u $ ValInteger $ show i realGen :: (Fractional a, Show a) => a -> Expression () @@ -48,11 +53,15 @@ assVal :: Expression () assVal = ExpValue () u ValAssignment +ixSinGen :: Integer -> Index () ixSinGen i = IxSingle () u Nothing (intGen i) +ixRanGen :: Integer -> Integer -> Index () ixRanGen i j = IxRange () u (Just $ intGen i) (Just $ intGen j) Nothing +shouldBe' :: (Data a, Eq a, Show a) => a -> a -> Expectation shouldBe' a b = resetSrcSpan a `shouldBe` resetSrcSpan b +shouldMatchList' :: (Data a, Eq a, Show a) => [a] -> [a] -> Expectation shouldMatchList' a b = resetSrcSpan a `shouldMatchList` resetSrcSpan b -- To be used in testing it reverts the SrcSpans in AST to dummy initial @@ -77,8 +86,8 @@ extractNameMap :: Data a => ProgramFile (Analysis a) -> M.Map String String extractNameMap pf = eMap `M.union` puMap where - eMap = M.fromList [ (un, n) | ExpValue (Analysis { uniqueName = Just un, sourceName = Just n }) _ _ <- uniE pf ] - puMap = M.fromList [ (un, n) | pu <- uniPU pf, (Analysis { uniqueName = Just un, sourceName = Just n }) <- [getAnnotation pu] ] + eMap = M.fromList [ (un, n) | ExpValue Analysis { uniqueName = Just un, sourceName = Just n } _ _ <- uniE pf ] + puMap = M.fromList [ (un, n) | pu <- uniPU pf, Analysis { uniqueName = Just un, sourceName = Just n } <- [getAnnotation pu] ] uniE :: Data a => ProgramFile a -> [Expression a] uniE = universeBi uniPU :: Data a => ProgramFile a -> [ProgramUnit a]