diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +### 0.2.1.1 (May 18, 2018) + +* Extend Fortran 95 support +* Extend support for legacy extensions + +### 0.2.1.1 (December 13, 2017) + +* Fortran95Experimental module renamed to Fortran95 +* No infinite loops due to symlinks. +* Fortran 95 support. + * AST extended to support more non-standard statements internally. diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: fortran-src -version: 0.2.0.0 -synopsis: Parser and anlyses for Fortran standards 66, 77, 90. -description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, and Fortran 90. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. +version: 0.2.1.1 +synopsis: Parser and anlyses for Fortran standards 66, 77, 90 and 95. +description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. bug-reports: https://github.com/camfort/fortran-src/issues license: Apache-2.0 license-file: LICENSE @@ -13,21 +13,20 @@ -- copyright: category: Language build-type: Simple --- extra-source-files: +extra-source-files: CHANGELOG.md cabal-version: >=1.10 source-repository head type: git location: https://github.com/camfort/fortran-src executable fortran-src - main-is: Main.hs - hs-source-dirs: src + main-is: src/Main.hs build-depends: base >= 4.6 && < 5, mtl >= 2.2 && < 3, array >= 0.5 && < 0.6, uniplate >= 1.6 && < 2, - GenericPretty >= 1.2 && < 2, + GenericPretty >= 1.2.2 && < 2, pretty >= 1.1 && < 2, containers >= 0.5 && < 0.6, text >= 1.2 && < 2, @@ -35,33 +34,8 @@ binary >= 0.8.3.0 && < 0.9, filepath >= 1.4 && < 2, directory >= 1.2 && < 2, - fgl >= 5 && < 6 - other-modules: - Language.Fortran.Analysis - Language.Fortran.Analysis.Renaming - Language.Fortran.Analysis.Types - Language.Fortran.Analysis.BBlocks - Language.Fortran.Analysis.DataFlow - Language.Fortran.AST - Language.Fortran.Intrinsics - Language.Fortran.Lexer.FixedForm - Language.Fortran.Lexer.FreeForm - Language.Fortran.ParserMonad - Language.Fortran.Parser.Any - Language.Fortran.Parser.Fortran66 - Language.Fortran.Parser.Fortran77 - Language.Fortran.Parser.Fortran90 - Language.Fortran.Parser.Utils - Language.Fortran.PrettyPrint - Language.Fortran.Transformation.Disambiguation.Function - Language.Fortran.Transformation.Disambiguation.Intrinsic - Language.Fortran.Transformation.Grouping - Language.Fortran.Transformation.TransformMonad - Language.Fortran.Transformer - Language.Fortran.Util.Position - Language.Fortran.Util.FirstParameter - Language.Fortran.Util.SecondParameter - Language.Fortran.Util.ModFile + fgl >= 5 && < 6, + fortran-src ghc-options: -fno-warn-tabs default-language: Haskell2010 @@ -73,6 +47,7 @@ Language.Fortran.Analysis.BBlocks Language.Fortran.Analysis.DataFlow Language.Fortran.AST + Language.Fortran.LValue Language.Fortran.Intrinsics Language.Fortran.Lexer.FixedForm Language.Fortran.Lexer.FreeForm @@ -81,6 +56,7 @@ Language.Fortran.Parser.Fortran66 Language.Fortran.Parser.Fortran77 Language.Fortran.Parser.Fortran90 + Language.Fortran.Parser.Fortran95 Language.Fortran.Parser.Utils Language.Fortran.PrettyPrint Language.Fortran.Transformation.Disambiguation.Function @@ -100,7 +76,7 @@ mtl >= 2.2 && < 3, array >= 0.5 && < 0.6, uniplate >= 1.6 && < 2, - GenericPretty >= 1.2 && < 2, + GenericPretty >= 1.2.2 && < 2, pretty >= 1.1 && < 2, containers >= 0.5 && < 0.6, text >= 1.2 && < 2, @@ -116,6 +92,7 @@ test-suite spec type: exitcode-stdio-1.0 build-depends: + deepseq, base >= 4.6 && < 5, hspec >= 2.2 && < 3, mtl >= 2.2 && < 3, @@ -123,7 +100,7 @@ uniplate >= 1.6 && < 2, directory >= 1.2 && < 2, filepath >= 1.4 && < 2, - GenericPretty >= 1.2 && < 2, + GenericPretty >= 1.2.2 && < 2, pretty >= 1.1 && < 2, containers >= 0.5 && < 0.6, text >= 1.2 && < 2, @@ -133,4 +110,26 @@ fortran-src hs-source-dirs: test main-is: Spec.hs + other-modules: + Language.Fortran.Analysis.BBlocksSpec + Language.Fortran.Analysis.DataFlowSpec + Language.Fortran.Analysis.RenamingSpec + Language.Fortran.Analysis.TypesSpec + Language.Fortran.AnalysisSpec + Language.Fortran.Lexer.FixedFormSpec + Language.Fortran.Lexer.FreeFormSpec + Language.Fortran.Parser.Fortran2003Spec + Language.Fortran.Parser.Fortran2008Spec + Language.Fortran.Parser.Fortran66Spec + Language.Fortran.Parser.Fortran77Spec + Language.Fortran.Parser.Fortran90Spec + Language.Fortran.Parser.Fortran95Spec + Language.Fortran.Parser.UtilsSpec + Language.Fortran.ParserMonadSpec + Language.Fortran.PrettyPrintSpec + Language.Fortran.Transformation.Disambiguation.FunctionSpec + Language.Fortran.Transformation.GroupingSpec + Language.Fortran.Util.FirstParameterSpec + Language.Fortran.Util.SecondParameterSpec + TestUtil default-language: Haskell2010 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 @@ -64,6 +64,7 @@ | TypeLogical | TypeCharacter | TypeCustom String + | TypeByte deriving (Ord, Eq, Show, Data, Typeable, Generic) instance Binary BaseType @@ -99,7 +100,7 @@ (Maybe [ProgramUnit a]) -- Subprograms | PUSubroutine a SrcSpan - Bool -- Recursive or not + (PUFunctionOpt a) -- Subroutine options Name (Maybe (AList Expression a)) -- Arguments [Block a] -- Body @@ -107,7 +108,7 @@ | PUFunction a SrcSpan (Maybe (TypeSpec a)) -- Return type - Bool -- Recursive or not + (PUFunctionOpt a) -- Function Options Name (Maybe (AList Expression a)) -- Arguments (Maybe (Expression a)) -- Result @@ -120,6 +121,37 @@ | PUComment a SrcSpan (Comment a) deriving (Eq, Show, Data, Typeable, Generic, Functor) +type IsRecursive = Bool +data PUFunctionOpt a = + None a SrcSpan IsRecursive + | Pure a SrcSpan IsRecursive + | Elemental a SrcSpan + deriving (Eq, Show, Data, Typeable, Generic, Functor) + +buildPUFunctionOpt :: (PUFunctionOpt ()) -> (PUFunctionOpt ()) -> Either String (PUFunctionOpt ()) +buildPUFunctionOpt a b = + case (a, b) of + ((None () _ False ), _) -> Right $ setSpan (getTransSpan a b) b + (_, (None () _ False)) -> Right $ setSpan (getTransSpan a b) a + ((Elemental () _), _) -> if functionIsRecursive b + then Left "Function cannot be both elemental and recursive. " + else Right . Elemental () $ getTransSpan a b + (_, (Elemental () _)) -> buildPUFunctionOpt b a + ((Pure () _ r), b) -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive b) + (a, (Pure () _ r)) -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive a) + ((None () _ r), (None () _ r')) -> Right $ None () (getTransSpan a b) (r || r') +-- Should parse: "elemental pure recursive function f()\nend": Right (Elemental ()) FAILED [4] + +buildPUFunctionOpts :: [PUFunctionOpt ()] -> Either String (PUFunctionOpt()) +buildPUFunctionOpts = + foldr merge . Right $ None () initSrcSpan False + where merge a = either Left $ buildPUFunctionOpt a + +functionIsRecursive :: (PUFunctionOpt a) -> Bool +functionIsRecursive (Elemental _ _) = False +functionIsRecursive (Pure _ _ r) = r +functionIsRecursive (None _ _ r) = r + programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _) = bs programUnitBody (PUModule _ _ _ bs _) = bs @@ -157,6 +189,13 @@ (Maybe (Expression a)) -- Label (Statement a) -- Statement + | BlForall a SrcSpan + (Maybe (Expression a)) -- Label + (Maybe String) -- Construct name + (ForallHeader a) -- Header information + [ Block a ] -- Body + (Maybe (Expression a)) -- Label to END DO + | BlIf a SrcSpan (Maybe (Expression a)) -- Label (Maybe String) -- Construct name @@ -183,6 +222,7 @@ | BlDoWhile a SrcSpan (Maybe (Expression a)) -- Label (Maybe String) -- Construct name + (Maybe (Expression a)) -- Target label (Expression a) -- Condition [ Block a ] -- Body (Maybe (Expression a)) -- Label to END DO @@ -197,6 +237,7 @@ data Statement a = StDeclaration a SrcSpan (TypeSpec a) (Maybe (AList Attribute a)) (AList Declarator a) + | StStructure a SrcSpan (Maybe String) (AList StructureItem a) | StIntent a SrcSpan Intent (AList Expression a) | StOptional a SrcSpan (AList Expression a) | StPublic a SrcSpan (Maybe (AList Expression a)) @@ -207,6 +248,7 @@ | StPointer a SrcSpan (AList Declarator a) | StTarget a SrcSpan (AList Declarator a) | StData a SrcSpan (AList DataGroup a) + | StAutomatic a SrcSpan (AList Declarator a) | StNamelist a SrcSpan (AList Namelist a) | StParameter a SrcSpan (AList Declarator a) | StExternal a SrcSpan (AList Expression a) @@ -216,7 +258,7 @@ | StFormat a SrcSpan (AList FormatItem a) | StImplicit a SrcSpan (Maybe (AList ImpList a)) | StEntry a SrcSpan (Expression a) (Maybe (AList Expression a)) (Maybe (Expression a)) - | StInclude a SrcSpan (Expression a) + | StInclude a SrcSpan (Expression a) (Maybe [Block a]) | StDo a SrcSpan (Maybe String) (Maybe (Expression a)) (Maybe (DoSpecification a)) | StDoWhile a SrcSpan (Maybe String) (Maybe (Expression a)) (Expression a) | StEnddo a SrcSpan (Maybe String) @@ -236,7 +278,7 @@ | StPointerAssign a SrcSpan (Expression a) (Expression a) | StLabelAssign a SrcSpan (Expression a) (Expression a) | StGotoUnconditional a SrcSpan (Expression a) - | StGotoAssigned a SrcSpan (Expression a) (AList Expression a) + | StGotoAssigned a SrcSpan (Expression a) (Maybe (AList Expression a)) | StGotoComputed a SrcSpan (AList Expression a) (Expression a) | StCall a SrcSpan (Expression a) (Maybe (AList Argument a)) | StReturn a SrcSpan (Maybe (Expression a)) @@ -247,6 +289,7 @@ | StRead2 a SrcSpan (Expression a) (Maybe (AList Expression a)) | StWrite a SrcSpan (AList ControlPair a) (Maybe (AList Expression a)) | StPrint a SrcSpan (Expression a) (Maybe (AList Expression a)) + | StTypePrint a SrcSpan (Expression a) (Maybe (AList Expression a)) | StOpen a SrcSpan (AList ControlPair a) | StClose a SrcSpan (AList ControlPair a) | StInquire a SrcSpan (AList ControlPair a) @@ -268,7 +311,9 @@ | StType a SrcSpan (Maybe (AList Attribute a)) String | StEndType a SrcSpan (Maybe String) | StSequence a SrcSpan - | StForall a SrcSpan (ForallHeader a) (Statement a) + | StForall a SrcSpan (Maybe String) (ForallHeader a) + | StForallStatement a SrcSpan (ForallHeader a) (Statement a) + | StEndForall a SrcSpan (Maybe String) -- Following is a temporary solution to a complicated FORMAT statement -- parsing problem. | StFormatBogus a SrcSpan String @@ -333,6 +378,16 @@ DataGroup a SrcSpan (AList Expression a) (AList Expression a) deriving (Eq, Show, Data, Typeable, Generic, Functor) +data StructureItem a = + StructFields a SrcSpan (TypeSpec a) (Maybe (AList Attribute a)) (AList Declarator a) + | StructUnion a SrcSpan (AList UnionMap a) + | StructStructure a SrcSpan (Maybe String) (AList StructureItem a) + deriving (Eq, Show, Data, Typeable, Generic, Functor) + +data UnionMap a = + UnionMap a SrcSpan (AList StructureItem a) + deriving (Eq, Show, Data, Typeable, Generic, Functor) + data FormatItem a = FIFormatList a SrcSpan (Maybe String) (AList FormatItem a) | FIHollerith a SrcSpan (Value a) @@ -350,14 +405,23 @@ data Expression a = ExpValue a SrcSpan (Value a) + -- ^ Use a value as an expression. | ExpBinary a SrcSpan BinaryOp (Expression a) (Expression a) + -- ^ A binary operator applied to two expressions. | ExpUnary a SrcSpan UnaryOp (Expression a) + -- ^ A unary operator applied to two expressions. | ExpSubscript a SrcSpan (Expression a) (AList Index a) + -- ^ Array indexing | ExpDataRef a SrcSpan (Expression a) (Expression a) + -- ^ @%@ notation for variables inside data types | ExpFunctionCall a SrcSpan (Expression a) (Maybe (AList Argument a)) + -- ^ A function expression applied to a list of arguments. | ExpImpliedDo a SrcSpan (AList Expression a) (DoSpecification a) + -- ^ Implied do (i.e. one-liner do loops) | ExpInitialisation a SrcSpan (AList Expression a) + -- ^ Array initialisation | ExpReturnSpec a SrcSpan (Expression a) + -- ^ Function return value specification deriving (Eq, Show, Data, Typeable, Generic, Functor) data Index a = @@ -371,15 +435,25 @@ -- All recursive Values data Value a = ValInteger String + -- ^ The string representation of an integer literal | ValReal String + -- ^ The string representation of a real literal | ValComplex (Expression a) (Expression a) + -- ^ The real and imaginary parts of a complex value | ValString String + -- ^ A string literal | ValHollerith String + -- ^ A Hollerith literal | ValVariable Name + -- ^ The name of a variable | ValIntrinsic Name + -- ^ The name of a built-in function | ValLogical String + -- ^ A boolean value | ValOperator String + -- ^ User-defined operators in interfaces | ValAssignment + -- ^ Overloaded assignment in interfaces | ValType String | ValStar deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -427,6 +501,7 @@ | EQ | NE | Or + | XOr | And | Equivalent | NotEquivalent @@ -448,6 +523,7 @@ instance FirstParameter (AList t a) a instance FirstParameter (ProgramUnit a) a +instance FirstParameter (PUFunctionOpt a) a instance FirstParameter (Block a) a instance FirstParameter (Statement a) a instance FirstParameter (Argument a) a @@ -459,6 +535,8 @@ instance FirstParameter (ImpElement a) a instance FirstParameter (CommonGroup a) a instance FirstParameter (DataGroup a) a +instance FirstParameter (StructureItem a) a +instance FirstParameter (UnionMap a) a instance FirstParameter (Namelist a) a instance FirstParameter (FormatItem a) a instance FirstParameter (Expression a) a @@ -470,6 +548,7 @@ instance SecondParameter (AList t a) SrcSpan instance SecondParameter (ProgramUnit a) SrcSpan +instance SecondParameter (PUFunctionOpt a) SrcSpan instance SecondParameter (Block a) SrcSpan instance SecondParameter (Statement a) SrcSpan instance SecondParameter (Argument a) SrcSpan @@ -481,6 +560,8 @@ instance SecondParameter (ImpElement a) SrcSpan instance SecondParameter (CommonGroup a) SrcSpan instance SecondParameter (DataGroup a) SrcSpan +instance SecondParameter (StructureItem a) SrcSpan +instance SecondParameter (UnionMap a) SrcSpan instance SecondParameter (Namelist a) SrcSpan instance SecondParameter (FormatItem a) SrcSpan instance SecondParameter (Expression a) SrcSpan @@ -503,6 +584,8 @@ instance Annotated ImpElement instance Annotated CommonGroup instance Annotated DataGroup +instance Annotated StructureItem +instance Annotated UnionMap instance Annotated Namelist instance Annotated FormatItem instance Annotated Expression @@ -514,6 +597,7 @@ instance Spanned (AList t a) instance Spanned (ProgramUnit a) +instance Spanned (PUFunctionOpt a) instance Spanned (Statement a) instance Spanned (Argument a) instance Spanned (Use a) @@ -525,6 +609,8 @@ instance Spanned (Block a) instance Spanned (CommonGroup a) instance Spanned (DataGroup a) +instance Spanned (StructureItem a) +instance Spanned (UnionMap a) instance Spanned (Namelist a) instance Spanned (FormatItem a) instance Spanned (Expression a) @@ -534,6 +620,14 @@ instance Spanned (DimensionDeclarator a) instance Spanned (ControlPair a) +instance Spanned (ProgramFile a) where + getSpan (ProgramFile _ pus) = + case pus of + [] -> SrcSpan initPosition initPosition + pus -> getSpan pus + + setSpan _ _ = error "Cannot set span to a program unit" + instance (Spanned a) => Spanned [a] where getSpan [] = error "Trying to find how long an empty list spans for." getSpan [x] = getSpan x @@ -611,20 +705,20 @@ getLabel (BlIf _ _ l _ _ _ _) = l getLabel (BlCase _ _ l _ _ _ _ _) = l getLabel (BlDo _ _ l _ _ _ _ _) = l - getLabel (BlDoWhile _ _ l _ _ _ _) = l + getLabel (BlDoWhile _ _ l _ _ _ _ _) = l getLabel _ = Nothing getLastLabel b@BlStatement{} = getLabel b getLastLabel (BlIf _ _ _ _ _ _ l) = l getLastLabel (BlCase _ _ _ _ _ _ _ l) = l getLastLabel (BlDo _ _ _ _ _ _ _ l) = l - getLastLabel (BlDoWhile _ _ _ _ _ _ l) = l + getLastLabel (BlDoWhile _ _ _ _ _ _ _ l) = l getLastLabel _ = Nothing setLabel (BlStatement a s _ st) l = BlStatement a s (Just l) st setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el - setLabel (BlDoWhile a s _ n spec bs el) l = BlDoWhile a s (Just l) n spec bs el + setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el setLabel b l = b class Conditioned f where @@ -675,6 +769,7 @@ instance Out MetaInfo instance Out a => Out (ProgramFile a) instance Out a => Out (ProgramUnit a) +instance Out a => Out (PUFunctionOpt a) instance (Out a, Out (t a)) => Out (AList t a) instance Out a => Out (Statement a) instance Out Only @@ -688,6 +783,8 @@ instance Out a => Out (Block a) instance Out a => Out (CommonGroup a) instance Out a => Out (DataGroup a) +instance Out a => Out (StructureItem a) +instance Out a => Out (UnionMap a) instance Out a => Out (Namelist a) instance Out a => Out (FormatItem a) instance Out a => Out (Expression a) @@ -734,6 +831,7 @@ StFormatBogus {} -> True StInclude {} -> True StDeclaration {} -> True + StStructure {} -> True _ -> False executableStatement :: FortranVersion -> Statement a -> Bool 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 @@ -3,7 +3,8 @@ -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis - ( initAnalysis, stripAnalysis, Analysis(..), varName, srcName, isNamedExpression + ( initAnalysis, stripAnalysis, Analysis(..) + , varName, srcName, lvVarName, lvSrcName, isNamedExpression , genVar, puName, puSrcName, blockRhsExprs, rhsExprs , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..) , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars @@ -16,6 +17,7 @@ import Data.Generics.Uniplate.Data import Data.Data import Language.Fortran.AST +import Language.Fortran.LValue import Data.Graph.Inductive.PatriciaTree (Gr) import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty @@ -24,6 +26,7 @@ import Data.Maybe import Data.Binary import Language.Fortran.Intrinsics (getIntrinsicDefsUses, allIntrinsics) +import Data.Bifunctor (first) -------------------------------------------------- @@ -61,6 +64,7 @@ data ConstructType = CTFunction | CTSubroutine + | CTExternal | CTVariable | CTArray | CTParameter @@ -90,6 +94,19 @@ } deriving (Data, Show, Eq, Generic) +instance Functor Analysis where + fmap f analysis = + Analysis + { prevAnnotation = f (prevAnnotation analysis) + , uniqueName = uniqueName analysis + , sourceName = sourceName analysis + , bBlocks = fmap (first . fmap . fmap . fmap $ f) . bBlocks $ analysis + , insLabel = insLabel analysis + , moduleEnv = moduleEnv analysis + , idType = idType analysis + , allLhsVarsAnn = allLhsVarsAnn analysis + } + instance Out (Analysis a) where doc a = parens . text . unwords . map (uncurry (++) . fmap fromJust) . filter (isJust . snd) $ [ ("uniqueName: ", uniqueName a) @@ -131,6 +148,19 @@ srcName (ExpValue _ _ (ValIntrinsic n)) = n srcName _ = error "Use of srcName on non-variable." +-- | Obtain either uniqueName or source name from an LvSimpleVar variable. +lvVarName :: LValue (Analysis a) -> String +lvVarName (LvSimpleVar (Analysis { uniqueName = Just n }) _ _) = n +lvVarName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n +lvVarName (LvSimpleVar _ _ n) = n +lvVarName _ = error "Use of lvVarName on non-variable." + +-- | Obtain the source name from an LvSimpleVar variable. +lvSrcName :: LValue (Analysis a) -> String +lvSrcName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n +lvSrcName (LvSimpleVar _ _ n) = n +lvSrcName _ = error "Use of lvSrcName on a non-variable" + -- | Generate an ExpValue variable with its source name == to its uniqueName. genVar :: Analysis a -> SrcSpan -> String -> Expression (Analysis a) genVar a s n = ExpValue (a { uniqueName = Just n, sourceName = Just n }) s v @@ -263,7 +293,7 @@ blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _) | ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs | otherwise = universeBi (rhs, e1, e2) -blockRhsExprs (BlDoWhile _ _ e1 _ e2 _ _) = universeBi (e1, e2) +blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2) blockRhsExprs (BlIf _ _ e1 _ e2 _ _) = universeBi (e1, e2) blockRhsExprs b = universeBi b @@ -292,7 +322,7 @@ blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)) | Just uses <- intrinsicUses f = uses blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps -blockVarUses (BlDoWhile _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ allVars e2 +blockVarUses (BlDoWhile _ _ e1 _ _ e2 _ _) = maybe [] allVars e1 ++ allVars e2 blockVarUses (BlIf _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2 blockVarUses b = allVars b 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 @@ -91,7 +91,7 @@ BlIf a s e1 mn e2 bss el -> BlIf a s (mfill i e1) mn (mmfill i e2) bss el BlCase a s e1 mn e2 is bss el -> BlCase a s (mfill i e1) mn (fill i e2) (mmfill i is) bss el BlDo a s e1 mn tl e2 bs el -> BlDo a s (mfill i e1) mn tl (mfill i e2) bs el - BlDoWhile a s e1 n e2 bs el -> BlDoWhile a s (mfill i e1) n (fill i e2) bs el + BlDoWhile a s e1 n tl e2 bs el -> BlDoWhile a s (mfill i e1) n tl (fill i e2) bs el _ -> b where i = insLabel $ getAnnotation b @@ -213,7 +213,7 @@ -- Find target of Goto statements (Return statements default target to -1). examineFinalBlock lm bs@(_:_) | BlStatement _ _ _ (StGotoUnconditional _ _ k) <- last bs = [lookupBBlock lm k] - | BlStatement _ _ _ (StGotoAssigned _ _ _ ks) <- last bs = map (lookupBBlock lm) (aStrip ks) + | BlStatement _ _ _ (StGotoAssigned _ _ _ ks) <- last bs = map (lookupBBlock lm) (maybe [] aStrip ks) | BlStatement _ _ _ (StGotoComputed _ _ ks _) <- last bs = map (lookupBBlock lm) (aStrip ks) | BlStatement _ _ _ (StReturn _ _ _) <- last bs = [-1] | BlStatement _ _ _ (StIfArithmetic _ _ _ k1 k2 k3) <- last bs = @@ -354,7 +354,7 @@ me3' <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing perDoBlock Nothing b bs perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs -perBlock b@(BlDoWhile _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs +perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs perBlock b@(BlStatement _ _ _ (StReturn {})) = processLabel b >> addToBBlock b >> closeBBlock_ perBlock b@(BlStatement _ _ _ (StGotoUnconditional {})) = @@ -474,7 +474,7 @@ -- Strip nested code not necessary since it is duplicated in another -- basic block. stripNestedBlocks (BlDo a s l mn tl ds _ el) = BlDo a s l mn tl ds [] el -stripNestedBlocks (BlDoWhile a s l n e _ el) = BlDoWhile a s l n e [] el +stripNestedBlocks (BlDoWhile a s l tl n e _ el) = BlDoWhile a s l tl n e [] el stripNestedBlocks (BlIf a s l mn exps _ el) = BlIf a s l mn exps [] el stripNestedBlocks (BlCase a s l mn sc inds _ el) = BlCase a s l mn sc inds [] el stripNestedBlocks (BlStatement a s l 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 @@ -122,6 +122,7 @@ | mAttrs <- maybe [] aStrip mAttrAList , isArray <- any isAttrDimension mAttrs , isParam <- any isAttrParameter mAttrs + , isExtrn <- any isAttrExternal mAttrs , decls <- aStrip declAList = do env <- gets environ forM_ decls $ \ decl -> case decl of @@ -130,11 +131,14 @@ DeclVariable _ _ v Nothing _ -> recordType baseType cType n where n = varName v - cType | isArray = CTArray + cType | isExtrn = CTExternal + | isArray = CTArray | isParam = CTParameter | Just (IDType _ (Just ct)) <- M.lookup n env = ct | otherwise = CTVariable - +statement (StExternal _ _ varAList) = do + let vars = aStrip varAList + mapM_ (recordCType CTExternal . varName) vars statement (StExpressionAssign _ _ (ExpSubscript _ _ v ixAList) _) -- | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v) -- it's an array (or a string?) FIXME | all isIxSingle (aStrip ixAList) = do @@ -232,6 +236,9 @@ isAttrParameter (AttrParameter {}) = True isAttrParameter _ = False + +isAttrExternal (AttrExternal {}) = True +isAttrExternal _ = False isIxSingle (IxSingle {}) = True isIxSingle _ = False 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 @@ -13,7 +13,7 @@ import Language.Fortran.ParserMonad (FortranVersion(..)) -data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITParam Int +data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITCharacter | ITParam Int deriving (Show, Eq, Ord, Typeable, Generic) data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) } @@ -51,91 +51,109 @@ func1 = ([0],[1]) func2 = ([0],[1,2]) func3 = ([0],[1,2,3]) +func4 = ([0],[1,2,3,4]) funcN = func2 -- FIXME: implement arbitrary-# parameter functions -- | name => (return-unit, parameter-units) +-- This is an exhaustive list of intrinsics listed in 15.10 of X3.9-1978 fortran77intrinsics :: IntrinsicsTable fortran77intrinsics = M.fromList - [ ("abs" , mkIEntry (ITParam 1) func1) - , ("aimag" , mkIEntry (ITReal) func1) - , ("aint" , mkIEntry (ITReal) func1) - , ("anint" , mkIEntry (ITReal) func1) - , ("cmplx" , mkIEntry (ITComplex) func1) - , ("conjg" , mkIEntry (ITComplex) func1) - , ("dble" , mkIEntry (ITDouble) func1) - , ("dim" , mkIEntry (ITReal) func1) - , ("dprod" , mkIEntry (ITDouble) func1) - , ("int" , mkIEntry (ITInteger) func1) - , ("max" , mkIEntry (ITParam 1) funcN) - , ("min" , mkIEntry (ITParam 1) funcN) - , ("mod" , mkIEntry (ITParam 1) func2) - , ("nint" , mkIEntry (ITInteger) func1) - , ("real" , mkIEntry (ITReal) func1) - , ("sign" , mkIEntry (ITParam 1) func2) + [ ("int" , mkIEntry ITInteger func1) + , ("ifix" , mkIEntry ITInteger func1) + , ("idint" , mkIEntry ITInteger func1) + , ("real" , mkIEntry ITReal func1) + , ("float" , mkIEntry ITReal func1) + , ("sngl" , mkIEntry ITReal func1) + , ("dble" , mkIEntry ITDouble func1) + , ("cmplx" , mkIEntry ITComplex func1) + , ("ichar" , mkIEntry ITInteger func1) + , ("char" , mkIEntry ITCharacter func1) + , ("aint" , mkIEntry (ITParam 1) func1) + , ("dint" , mkIEntry ITDouble func1) + , ("anint" , mkIEntry (ITParam 1) func1) + , ("dnint" , mkIEntry ITDouble func1) + , ("nint" , mkIEntry (ITParam 1) func1) + , ("idnint" , mkIEntry ITDouble func1) + , ("abs" , mkIEntry (ITParam 1) func1) + , ("iabs" , mkIEntry ITInteger func1) + , ("dabs" , mkIEntry ITDouble func1) + , ("cabs" , mkIEntry ITComplex func1) + , ("mod" , mkIEntry (ITParam 1) func2) + , ("amod" , mkIEntry ITReal func2) + , ("dmod" , mkIEntry ITDouble func2) + , ("sign" , mkIEntry (ITParam 1) func2) + , ("isign" , mkIEntry ITInteger func2) + , ("dsign" , mkIEntry ITDouble func2) + , ("dim" , mkIEntry (ITParam 1) func2) + , ("idim" , mkIEntry ITInteger func2) + , ("ddim" , mkIEntry ITDouble func2) + , ("dprod" , mkIEntry ITDouble func2) + , ("max" , mkIEntry (ITParam 1) funcN) + , ("max0" , mkIEntry ITInteger funcN) + , ("amax1" , mkIEntry ITReal funcN) + , ("dmax1" , mkIEntry ITDouble funcN) + , ("amax0" , mkIEntry ITReal funcN) + , ("max1" , mkIEntry ITInteger funcN) + , ("min" , mkIEntry (ITParam 1) funcN) + , ("min0" , mkIEntry ITInteger funcN) + , ("amin1" , mkIEntry ITReal funcN) + , ("dmin1" , mkIEntry ITDouble funcN) + , ("amin0" , mkIEntry ITReal funcN) + , ("min1" , mkIEntry ITInteger funcN) + , ("len" , mkIEntry ITInteger func1) + , ("index" , mkIEntry ITInteger func2) + , ("aimag" , mkIEntry ITReal func1) + , ("conjg" , mkIEntry ITComplex func1) + , ("sqrt" , mkIEntry (ITParam 1) func1) + , ("dsqrt" , mkIEntry ITDouble func1) + , ("csqrt" , mkIEntry ITComplex func1) + , ("exp" , mkIEntry (ITParam 1) func1) + , ("dexp" , mkIEntry ITDouble func1) + , ("cexp" , mkIEntry ITComplex func1) + , ("log" , mkIEntry (ITParam 1) func1) + , ("alog" , mkIEntry ITReal func1) + , ("dlog" , mkIEntry ITDouble func1) + , ("clog" , mkIEntry ITComplex func1) + , ("log10" , mkIEntry (ITParam 1) func1) + , ("alog10" , mkIEntry ITReal func1) + , ("dlog10" , mkIEntry ITDouble func1) + , ("sin" , mkIEntry (ITParam 1) func1) + , ("dsin" , mkIEntry ITDouble func1) + , ("csin" , mkIEntry ITComplex func1) + , ("cos" , mkIEntry (ITParam 1) func1) + , ("dcos" , mkIEntry ITDouble func1) + , ("ccos" , mkIEntry ITComplex func1) + , ("tan" , mkIEntry (ITParam 1) func1) + , ("dtan" , mkIEntry ITDouble func1) + , ("asin" , mkIEntry (ITParam 1) func1) + , ("dasin" , mkIEntry ITDouble func1) + , ("acos" , mkIEntry (ITParam 1) func1) + , ("dacos" , mkIEntry ITDouble func1) + , ("atan" , mkIEntry (ITParam 1) func1) + , ("datan" , mkIEntry ITDouble func1) + , ("atan2" , mkIEntry (ITParam 1) func2) + , ("datan2" , mkIEntry ITDouble func2) + , ("sinh" , mkIEntry (ITParam 1) func1) + , ("dsinh" , mkIEntry ITDouble func1) + , ("cosh" , mkIEntry (ITParam 1) func1) + , ("dcosh" , mkIEntry ITDouble func1) + , ("tanh" , mkIEntry (ITParam 1) func1) + , ("dtanh" , mkIEntry ITDouble func1) + , ("lge" , mkIEntry ITLogical func2) + , ("lgt" , mkIEntry ITLogical func2) + , ("lle" , mkIEntry ITLogical func2) + , ("llt" , mkIEntry ITLogical func2) + -- https://gcc.gnu.org/onlinedocs/gfortran/Argument-list-functions.html + , ("%loc", mkIEntry (ITParam 1) func1) + , ("%ref", mkIEntry (ITParam 1) func1) + , ("%val", mkIEntry (ITParam 1) func1) ] fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList - [ ("iabs" , mkIEntry (ITInteger) func1) - , ("dabs" , mkIEntry (ITDouble) func1) - , ("cabs" , mkIEntry (ITComplex) func1) - , ("dint" , mkIEntry (ITDouble) func1) - , ("dnint" , mkIEntry (ITDouble) func1) - , ("idnint" , mkIEntry (ITInteger) func1) - , ("ifix" , mkIEntry (ITInteger) func1) - , ("idint" , mkIEntry (ITInteger) func1) - , ("min0" , mkIEntry (ITInteger) funcN) - , ("amin1" , mkIEntry (ITReal) funcN) - , ("dmin1" , mkIEntry (ITDouble) funcN) - , ("amin0" , mkIEntry (ITReal) funcN) - , ("min1" , mkIEntry (ITInteger) funcN) - , ("amod" , mkIEntry (ITReal) func2) - , ("dmod" , mkIEntry (ITDouble) func2) - , ("float" , mkIEntry (ITReal) func1) - , ("sngl" , mkIEntry (ITReal) func1) - , ("isign" , mkIEntry (ITInteger) func2) - , ("dsign" , mkIEntry (ITDouble) func2) - , ("present" , mkIEntry (ITLogical) func1) - , ("sqrt" , mkIEntry (ITParam 1) func1) - , ("dsqrt" , mkIEntry (ITDouble) func1) - , ("csqrt" , mkIEntry (ITComplex) func1) - , ("exp" , mkIEntry (ITParam 1) func1) - , ("dexp" , mkIEntry (ITDouble) func1) - , ("cexp" , mkIEntry (ITComplex) func1) - , ("log" , mkIEntry (ITParam 1) func1) - , ("alog" , mkIEntry (ITReal) func1) - , ("dlog" , mkIEntry (ITDouble) func1) - , ("clog" , mkIEntry (ITComplex) func1) - , ("log10" , mkIEntry (ITParam 1) func1) - , ("alog10" , mkIEntry (ITReal) func1) - , ("dlog10" , mkIEntry (ITDouble) func1) - , ("idim" , mkIEntry (ITInteger) func2) - , ("ddim" , mkIEntry (ITDouble) func2) - , ("sin" , mkIEntry (ITReal) func1) - , ("dsin" , mkIEntry (ITDouble) func1) - , ("csin" , mkIEntry (ITComplex) func1) - , ("cos" , mkIEntry (ITReal) func1) - , ("dcos" , mkIEntry (ITDouble) func1) - , ("ccos" , mkIEntry (ITComplex) func1) - , ("tan" , mkIEntry (ITReal) func1) - , ("dtan" , mkIEntry (ITDouble) func1) - , ("asin" , mkIEntry (ITReal) func1) - , ("dasin" , mkIEntry (ITDouble) func1) - , ("acos" , mkIEntry (ITReal) func1) - , ("dacos" , mkIEntry (ITDouble) func1) - , ("atan" , mkIEntry (ITReal) func1) - , ("datan" , mkIEntry (ITDouble) func1) - , ("atan2" , mkIEntry (ITReal) func2) - , ("datan2" , mkIEntry (ITDouble) func2) - , ("sinh" , mkIEntry (ITReal) func1) - , ("dsinh" , mkIEntry (ITDouble) func1) - , ("cosh" , mkIEntry (ITReal) func1) - , ("dcosh" , mkIEntry (ITDouble) func1) - , ("tanh" , mkIEntry (ITReal) func1) - , ("dtanh" , mkIEntry (ITDouble) func1) + [ ("present" , mkIEntry (ITLogical) func1) , ("modulo" , mkIEntry (ITParam 1) func2) , ("ceiling" , mkIEntry (ITParam 1) func1) - , ("floor" , mkIEntry (ITParam 1) func1) , ("iand" , mkIEntry (ITInteger) func2) , ("ior" , mkIEntry (ITInteger) func2) , ("ieor" , mkIEntry (ITInteger) func2) @@ -146,4 +164,27 @@ , ("ishftc" , mkIEntry (ITInteger) func3) , ("btest" , mkIEntry (ITInteger) func2) , ("not" , mkIEntry (ITInteger) func1) + , ("dot_product" , mkIEntry (ITParam 1) func2) + , ("matmul" , mkIEntry (ITParam 1) func2) + , ("all" , mkIEntry ITLogical func2) + , ("any" , mkIEntry ITLogical func2) + , ("count" , mkIEntry ITInteger func2) + , ("maxval" , mkIEntry (ITParam 1) func3) + , ("minval" , mkIEntry (ITParam 1) func3) + , ("product" , mkIEntry (ITParam 1) func3) + , ("sum" , mkIEntry (ITParam 1) func3) + , ("allocated" , mkIEntry ITLogical func1) + , ("lbound" , mkIEntry ITInteger func2) + , ("ubound" , mkIEntry ITInteger func2) + , ("shape" , mkIEntry ITInteger func1) + , ("size" , mkIEntry ITInteger func2) + , ("merge" , mkIEntry ITInteger func3) + , ("pack" , mkIEntry (ITParam 3) func3) + , ("spread" , mkIEntry (ITParam 1) func3) + , ("unpack" , mkIEntry (ITParam 3) func3) + , ("reshape" , mkIEntry (ITParam 1) func4) + , ("eoshift" , mkIEntry (ITParam 1) func4) + , ("transpose" , mkIEntry (ITParam 1) func1) + , ("maxloc" , mkIEntry (ITParam 1) func2) + , ("minloc" , mkIEntry (ITParam 1) func2) ] diff --git a/src/Language/Fortran/LValue.hs b/src/Language/Fortran/LValue.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/LValue.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Language.Fortran.LValue where + +import Data.Data +import GHC.Generics (Generic) + +import Language.Fortran.AST +import Language.Fortran.Util.FirstParameter +import Language.Fortran.Util.Position +import Language.Fortran.Util.SecondParameter + +-- | A subset of 'Expression' which can only contain values that can be assigned +-- to. +data LValue a + = LvSimpleVar a SrcSpan Name + | LvSubscript a SrcSpan (LValue a) (AList Index a) + | LvDataRef a SrcSpan (LValue a) (LValue a) + deriving (Eq, Show, Data, Typeable, Generic, Functor) + + +-- | If the expression can be seen as an lvalue, convert it to an 'LValue'. +toLValue :: Expression a -> Maybe (LValue a) +toLValue (ExpValue ann sp (ValVariable nm)) = Just (LvSimpleVar ann sp nm) +toLValue (ExpSubscript ann sp exp ixs) = LvSubscript ann sp <$> toLValue exp <*> pure ixs +toLValue (ExpDataRef ann sp lhs rhs) = LvDataRef ann sp <$> toLValue lhs <*> toLValue rhs +toLValue _ = Nothing + +instance FirstParameter (LValue a) a +instance SecondParameter (LValue a) SrcSpan + +instance Annotated LValue +instance Spanned (LValue a) 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 @@ -1,5 +1,6 @@ -- -*- Mode: Haskell -*- { +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -7,12 +8,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -module Language.Fortran.Lexer.FixedForm where +module Language.Fortran.Lexer.FixedForm + ( lexer, initParseState, collectFixedTokens, collectFixedTokensSafe + , Token(..), LexAction, AlexInput(..), lexemeMatch, lexN + ) where import Data.Word (Word8) -import Data.Char (toLower, ord) +import Data.Char (toLower, ord, isDigit) import Data.List (isPrefixOf, any) -import Data.Maybe (fromJust, isNothing) +import Data.Maybe (fromJust, isNothing, isJust) import Data.Data import qualified Data.Bits import qualified Data.ByteString.Char8 as B @@ -29,6 +33,14 @@ } $digit = [0-9] +$octalDigit = 0-7 +$hexDigit = [a-f $digit] +$bit = 0-1 + +@binary = b\'$bit+\' | \'$bit+\'b +@octal = o\'$octalDigit+\' | \'$octalDigit+\'o +@hex = x\'$hexDigit+\' | \'$hexDigit+\'x | z\'$hexDigit+\' | \'$hexDigit+\'z + $letter = [a-z] $alphanumeric = [$letter $digit] $alphanumericExtended = [$letter $digit \_] @@ -38,13 +50,18 @@ -- programs out there. @idExtended = $letter $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended? @id = $letter $alphanumeric{0,5} -@label = [1-9] $digit{0,4} +@label = $digit{1,5} +@idLegacy = [$letter \_ \%] [$alphanumericExtended \$]* + @datatype = "integer" | "real" | "doubleprecision" | "complex" | "logical" + -- legacy extensions + | "byte" -- Numbers @integerConst = $digit+ -- Integer constant @posIntegerConst = [1-9] $digit* +@bozLiteralConst = (@binary|@octal|@hex) -- For reals @exponent = [ed] [\+\-]? @integerConst @@ -56,44 +73,63 @@ tokens :- <0> [c!\*d] / { commentP } { lexComment Nothing } + "!" / { bangCommentP &&& legacy77P } { lexComment Nothing } <0> @label / { withinLabelColsP } { addSpanAndMatch TLabel } <0> . / { \_ ai _ _ -> atColP 6 ai } { toSC keyword } <0> " " ; - <0,st,keyword,iif> \n { resetPar >> toSC 0 >> addSpan TNewline } - <0,st,keyword,iif> \r ; + <0,st,keyword,iif,assn,doo> \n { resetPar >> toSC 0 >> addSpan TNewline } + <0,st,keyword,iif,assn,doo> \r ; + <0,st,keyword,iif,assn,doo> ";" { resetPar >> toSC keyword >> addSpan TNewline } "(" { addSpan TLeftPar } + "(" / { legacy77P } { addSpan TLeftPar } "(" { incPar >> addSpan TLeftPar } ")" { addSpan TRightPar } + ")" / { legacy77P } { typeSCChange >> addSpan TRightPar } ")" { maybeToKeyword >> addSpan TRightPar } "(/" / { formatExtendedP } { addSpan TLeftArrayPar } "/)" / { formatExtendedP } { addSpan TRightArrayPar } - "," { addSpan TComma } - "." { addSpan TDot } + "," { addSpan TComma } + "." { addSpan TDot } + "." / { legacy77P } { addSpan TDot } ":" / { fortran77P } { addSpan TColon } @id / { idP } { toSC st >> addSpanAndMatch TId } @idExtended / { extendedIdP } { toSC st >> addSpanAndMatch TId } + @idLegacy / { legacyIdP } { toSC st >> addSpanAndMatch TId } "include" / { extended77P } { toSC st >> addSpan TInclude } -- Tokens related to procedures and subprograms "program" { toSC st >> addSpan TProgram } - "function" { toSC st >> addSpan TFunction } + "function" / { functionP } { toSC st >> addSpan TFunction } "subroutine" { toSC st >> addSpan TSubroutine } "blockdata" { toSC st >> addSpan TBlockData } + "structure" / { legacy77P } { toSC st >> addSpan TStructure } + "union" / { legacy77P } { toSC st >> addSpan TUnion } + "map" / { legacy77P } { toSC st >> addSpan TMap } + "endstructure" / { legacy77P } { toSC st >> addSpan TEndStructure } + "endunion" / { legacy77P } { toSC st >> addSpan TEndUnion } + "endmap" / { legacy77P } { toSC st >> addSpan TEndMap } + "record" / { legacy77P } { toSC st >> addSpan TRecord } "end" { toSC st >> addSpan TEnd } + "endprogram" / { legacy77P } { toSC st >> addSpan TEndProgram } + "endfunction" / { legacy77P } { toSC st >> addSpan TEndFunction } + "endsubroutine" / { legacy77P } { toSC st >> addSpan TEndSubroutine } -- Tokens related to assignment statements - "assign" { toSC st >> addSpan TAssign } + "assign" { toSC assn >> addSpan TAssign } + @integerConst { addSpanAndMatch TInt } + "to" { addSpan TTo } + @id / { notToP } { addSpanAndMatch TId } + @idExtended / { notToP &&& extended77P } { addSpanAndMatch TId } + @idLegacy / { notToP &&& legacy77P } { addSpanAndMatch TId } "=" { addSpan TOpAssign } - "to" { addSpan TTo } -- Tokens related to control statements "goto" { toSC st >> addSpan TGoto } - "if" { toSC iif >> addSpan TIf } - "if" / { fortran77P } { toSC iif >> addSpan TIf } + "if" / { ifP } { toSC iif >> addSpan TIf } "then" / { fortran77P } { toSC keyword >> addSpan TThen } "else" / {fortran77P } { addSpan TElse } "elseif" / {fortran77P } { toSC st >> addSpan TElsif } @@ -104,10 +140,20 @@ "continue" { toSC st >> addSpan TContinue } "stop" { toSC st >> addSpan TStop } "exit" / { extended77P } { toSC st >> addSpan TExit } + "cycle" / { legacy77P } { toSC st >> addSpan TCycle } + "case" / { legacy77P } { toSC st >> addSpan TCase } + "casedefault" / { legacy77P } { toSC st >> addSpan TCaseDefault } + "selectcase" / { legacy77P } { toSC st >> addSpan TSelectCase } + "endselect" / { legacy77P } { toSC st >> addSpan TEndSelect } "pause" { toSC st >> addSpan TPause } - "do" { toSC st >> addSpan TDo } "dowhile" / { extended77P } { toSC st >> addSpan TDoWhile } "enddo" / { extended77P } { toSC st >> addSpan TEndDo } + "do" { toSC doo >> addSpan TDo } + @integerConst { addSpanAndMatch TInt } + "while" / { extended77P } { toSC st >> addSpan TWhile } + @id { toSC st >> addSpanAndMatch TId } + @idExtended / { extended77P } { toSC st >> addSpanAndMatch TId } + @idLegacy / { legacy77P } { toSC st >> addSpanAndMatch TId } -- Tokens related to I/O statements "read" { toSC st >> addSpan TRead } @@ -119,6 +165,7 @@ "open" / { fortran77P } { toSC st >> addSpan TOpen } "close" / { fortran77P } { toSC st >> addSpan TClose } "print" / { fortran77P } { toSC st >> addSpan TPrint } + "type" / { legacy77P } { toSC st >> addSpan TTypePrint } -- Tokens related to non-executable statements @@ -130,29 +177,36 @@ "intrinsic" / { fortran77P } { toSC st >> addSpan TIntrinsic } @datatype { typeSCChange >> addSpanAndMatch TType } @datatype / { implicitStP } { addSpanAndMatch TType } + "doublecomplex" / { extended77P } { typeSCChange >> addSpanAndMatch TType } "doublecomplex" / { implicitTypeExtendedP } { addSpanAndMatch TType } - "character" / { fortran77P } { toSC st >> addSpanAndMatch TType } + "character" / { fortran77P } { typeSCChange >> addSpanAndMatch TType } "character" / { implicitType77P } { addSpanAndMatch TType } "implicit" / { fortran77P } { toSC st >> addSpan TImplicit } - "none" / { fortran77P } { addSpan TNone } + "none" / { implicitType77P } { addSpan TNone } "parameter" / { fortran77P } { toSC st >> addSpan TParameter } "entry" / { fortran77P } { toSC st >> addSpan TEntry } + "pointer" / { legacy77P } { toSC st >> addSpan TPointer } -- Tokens related to data initalization statement "data" { toSC st >> addSpan TData } + "automatic" / { legacy77P } { toSC st >> addSpan TAutomatic } -- Tokens related to format statement - "format" { toSC st >> addSpan TFormat } - "(".*")" / { formatP } { addSpanAndMatch TBlob } + "format" { toSC fmt >> enterFormat >> addSpan TFormat } + "(".*")" { toSC st >> exitFormat >> addSpanAndMatch TBlob } -- Tokens needed to parse integers, reals, double precision and complex -- constants @exponent / { exponentP } { addSpanAndMatch TExponent } - @integerConst { addSpanAndMatch TInt } + @integerConst { addSpanAndMatch TInt } + -- can be part (end) of function type declaration + @integerConst { typeSCChange >> addSpanAndMatch TInt } + @bozLiteralConst / { legacy77P } { addSpanAndMatch TBozInt } -- String - \' / { fortran77P } { strAutomaton 0 } + \' / { fortran77P } { strAutomaton '\'' 0 } + \" / { legacy77P } { strAutomaton '"' 0 } -- Logicals (".true."|".false.") { addSpanAndMatch TBool } @@ -162,12 +216,16 @@ "-" { addSpan TOpMinus } "**" { addSpan TOpExp } "*" { addSpan TStar } + -- can be part of function type declaration + "*" / { legacy77P } { addSpan TStar } "/" { addSpan TSlash } + "&" / { legacy77P } { addSpan TAmpersand } -- Logical operators ".or." { addSpan TOpOr } ".and." { addSpan TOpAnd } ".not." { addSpan TOpNot } + ".xor." / { legacy77P } { addSpan TOpXOr } ".eqv." / { fortran77P } { addSpan TOpEquivalent } ".neqv." / { fortran77P } { addSpan TOpNotEquivalent } @@ -175,7 +233,7 @@ "<" / { extended77P } { addSpan TOpLT } "<=" / { extended77P } { addSpan TOpLE } "==" / { extended77P } { addSpan TOpEQ } - "!=" / { extended77P } { addSpan TOpNE } + "/=" / { extended77P } { addSpan TOpNE } ">" / { extended77P } { addSpan TOpGT } ">=" / { extended77P } { addSpan TOpGE } ".lt." { addSpan TOpLT } @@ -188,9 +246,11 @@ -- ID @id { addSpanAndMatch TId } @idExtended / { extended77P } { addSpanAndMatch TId } + @idLegacy / { legacy77P } { addSpanAndMatch TId } -- Strings @posIntegerConst "h" / { fortran66P } { lexHollerith } + @posIntegerConst "h" / { hollerithP &&& legacy77P } { lexHollerith } { @@ -198,13 +258,13 @@ -- Predicated lexer helpers -------------------------------------------------------------------------------- -formatP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -formatP _ _ _ ai - | Just TFormat{} <- aiPreviousToken ai = True - | otherwise = False +(&&&) :: (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool) + -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool) + -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool) +f &&& g = \ fv ai1 i ai2 -> f fv ai1 i ai2 && g fv ai1 i ai2 formatExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -formatExtendedP fv _ _ ai = fv == Fortran77Extended && +formatExtendedP fv _ _ ai = fv `elem` [Fortran77Extended, Fortran77Legacy] && case xs of [ TFormat _, _ ] -> False [ TLabel _ _, TFormat _ ] -> False @@ -225,14 +285,18 @@ f _ = False extendedIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -extendedIdP fv a b ai = fv == Fortran77Extended && idP fv a b ai +extendedIdP fv a b ai = fv `elem` [Fortran77Extended, Fortran77Legacy] && idP fv a b ai +legacyIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +legacyIdP fv a b ai = fv == Fortran77Legacy && idP fv a b ai + idP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -idP fv _ _ ai = not (doP fv ai) && equalFollowsP fv ai +idP fv ao i ai = not (doP fv ai) && not (ifP fv ao i ai) + && (equalFollowsP fv ai || rParFollowsP fv ai) doP :: FortranVersion -> AlexInput -> Bool doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) && - case unParse (lexer $ f) ps of + case unParse (lexer $ f 0) ps of ParseOk True _ -> True _ -> False where @@ -242,13 +306,62 @@ , psFilename = "" , psParanthesesCount = ParanthesesCount 0 False , psContext = [ ConStart ] } - f t = + f 0 t = case t of TNewline{} -> return False TEOF{} -> return False + TLeftPar{} -> lexer $ f 1 TComma{} -> return True - _ -> lexer f + _ -> lexer $ f 0 + f !n t = + case t of + TLeftPar{} -> lexer $ f (n+1) + TRightPar{} -> lexer $ f (n-1) + _ -> lexer $ f n +ifP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +ifP fv _ _ ai = "if" == (reverse . lexemeMatch . aiLexeme $ ai) && + case unParse (lexer $ f) ps of + ParseOk True _ -> True + _ -> False + where + ps = ParseState + { psAlexInput = ai { aiStartCode = st} + , psVersion = fv + , psFilename = "" + , psParanthesesCount = ParanthesesCount 0 False + , psContext = [ ConStart ] } + f t = + case t of + -- IF is always followed by ( + TLeftPar{} -> return True + _ -> return False + +functionP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +functionP fv _ _ ai = "function" == (reverse . lexemeMatch . aiLexeme $ ai) && + case unParse (lexer $ f) ps of + ParseOk True _ -> True + _ -> False + where + ps = ParseState + { psAlexInput = ai { aiStartCode = st} + , psVersion = fv + , psFilename = "" + , psParanthesesCount = ParanthesesCount 0 False + , psContext = [ ConStart ] } + f t = + case t of + -- a function keyword should be followed by the name and a left paren + TId{} -> lexer f + TLeftPar{} -> return True + _ -> return False + +hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +hollerithP fv _ _ ai = isDigit (lookBack 2 ai) + +notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +notToP fv _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai) + equalFollowsP :: FortranVersion -> AlexInput -> Bool equalFollowsP fv ai = case unParse (lexer $ f False 0) ps of @@ -267,10 +380,15 @@ TEOF{} -> return False TOpAssign{} -> return True TLeftPar{} -> lexer $ f True 1 + TDot{} -> lexer $ f False 0 + TId{} -> lexer $ f False 0 _ -> return False f True 0 t = case t of TOpAssign{} -> return True + TDot{} -> lexer $ f True 0 + TId{} -> lexer $ f True 0 + TLeftPar{} -> lexer $ f True 1 _ -> return False f True n t = case t of @@ -280,11 +398,33 @@ TRightPar{} -> lexer $ f True (n - 1) _ -> lexer $ f True n +rParFollowsP :: FortranVersion -> AlexInput -> Bool +rParFollowsP fv ai = + case unParse (lexer $ f) ps of + ParseOk True _ -> True + _ -> False + where + ps = ParseState + { psAlexInput = ai { aiStartCode = st} + , psVersion = fv + , psFilename = "" + , psParanthesesCount = ParanthesesCount 0 False + , psContext = [ ConStart ] } + f t = + case t of + TRightPar{} -> return True + _ -> return False + commentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool commentP _ aiOld _ aiNew = atColP 1 aiOld && _endsWithLine where _endsWithLine = (posColumn . aiPosition) aiNew /= 1 +bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +bangCommentP fv aiOld i aiNew = _endsWithLine + where + _endsWithLine = (posColumn . aiPosition) aiNew /= 1 + withinLabelColsP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool withinLabelColsP _ aiOld _ aiNew = getCol aiOld >= 1 && getCol aiNew <= 6 where @@ -299,20 +439,26 @@ -- as an exponent token. exponentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool exponentP _ _ _ ai = - case aiPreviousToken ai of - Just (TInt _ _) -> True - Just (TDot _) -> True + case aiPreviousTokensInLine ai of + -- real*8 d8 is not an exponent + TInt{} : TStar{} : TType{} : _ -> False + TInt{} : _ -> True + TDot{} : _ -> True _ -> False fortran66P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool fortran66P fv _ _ _ = fv == Fortran66 fortran77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended +fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended || fv == Fortran77Legacy extended77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool -extended77P fv _ _ _ = fv == Fortran77Extended +extended77P fv _ _ _ = fv == Fortran77Extended || fv == Fortran77Legacy +legacy77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool +legacy77P fv _ _ _ = fv == Fortran77Legacy + + -------------------------------------------------------------------------------- -- Lexer helpers -------------------------------------------------------------------------------- @@ -362,6 +508,26 @@ ai <- getAlex putAlex $ ai { aiWhiteSensitiveCharCount = 0 } +setCaseSensitive :: LexAction () +setCaseSensitive = do + ai <- getAlex + putAlex $ ai { aiCaseSensitive = True } + +setCaseInsensitive :: LexAction () +setCaseInsensitive = do + ai <- getAlex + putAlex $ ai { aiCaseSensitive = False } + +enterFormat :: LexAction () +enterFormat = do + ai <- getAlex + putAlex $ ai { aiInFormat = True } + +exitFormat :: LexAction () +exitFormat = do + ai <- getAlex + putAlex $ ai { aiInFormat = False } + instance Spanned Lexeme where getSpan lexeme = let ms = lexemeStart lexeme @@ -402,11 +568,18 @@ m <- getMatch s <- getLexemeSpan alex <- getAlex + version <- getVersion + let emitComment = case version of + Fortran77Legacy + -> return Nothing + _ -> return $ Just $ TComment s $ tail m let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 } case mc of - Just '\n' -> return $ Just $ TComment s $ tail m + Just '\n' -> emitComment Just _ -> case alexGetByte modifiedAlex of + Just (w, _) | fromIntegral w == ord '\n' -> do + emitComment Just (_, newAlex) -> do putAlex newAlex lexComment Nothing @@ -414,7 +587,7 @@ Nothing -> case alexGetByte modifiedAlex of Just (_, newAlex) -> lexComment (Just $ (head . lexemeMatch . aiLexeme) newAlex) - Nothing -> return $ Just $ TComment s $ tail m + Nothing -> emitComment {- @@ -436,37 +609,39 @@ +-------------+ Chars -} -strAutomaton :: Int -> LexAction (Maybe Token) -strAutomaton 0 = do +strAutomaton :: Char -> Int -> LexAction (Maybe Token) +strAutomaton c 0 = do + setCaseSensitive incWhiteSensitiveCharCount alex <- getAlex case alexGetByte alex of Just (_, newAlex) -> do putAlex newAlex m <- getMatch - if last m == '\'' - then strAutomaton 1 - else strAutomaton 0 - Nothing -> strAutomaton 3 -strAutomaton 1 = do + if last m == c + then strAutomaton c 1 + else strAutomaton c 0 + Nothing -> strAutomaton c 3 +strAutomaton c 1 = do incWhiteSensitiveCharCount alex <- getAlex case alexGetByte alex of Just (_, newAlex) -> do let m = lexemeMatch . aiLexeme $ newAlex - if head m == '\'' + if head m == c then do putAlex newAlex putMatch $ reverse . tail $ m - strAutomaton 0 - else strAutomaton 2 - Nothing -> strAutomaton 2 -strAutomaton 2 = do + strAutomaton c 0 + else strAutomaton c 2 + Nothing -> strAutomaton c 2 +strAutomaton c 2 = do s <- getLexemeSpan m <- getMatch resetWhiteSensitiveCharCount + setCaseInsensitive return $ Just $ TString s $ (init . tail) m -strAutomaton 3 = fail "Unmatched string." +strAutomaton c 3 = fail "Unmatched string." lexHollerith :: LexAction (Maybe Token) lexHollerith = do @@ -490,10 +665,14 @@ then return $ Just match' else case alexGetByte alex of + Just (w, newAlex) | fromIntegral w == ord '\n' -> do + return . Just $! pad match' Just (_, newAlex) -> do putAlex newAlex lexN n Nothing -> return Nothing + where + pad s = s ++ replicate (n - length s) ' ' maybeToKeyword :: LexAction (Maybe Token) maybeToKeyword = do @@ -513,6 +692,11 @@ else toSC st where f TFunction{} = return True + -- can be part of function type declaration + f TLeftPar{} = lexer f + f TRightPar{} = lexer f + f TStar{} = lexer f + f TInt{} = lexer f f _ = return False toSC :: Int -> LexAction (Maybe Token) @@ -539,6 +723,16 @@ | TFunction SrcSpan | TSubroutine SrcSpan | TBlockData SrcSpan + | TStructure SrcSpan + | TRecord SrcSpan + | TUnion SrcSpan + | TMap SrcSpan + | TEndProgram SrcSpan + | TEndFunction SrcSpan + | TEndSubroutine SrcSpan + | TEndStructure SrcSpan + | TEndUnion SrcSpan + | TEndMap SrcSpan | TEnd SrcSpan | TAssign SrcSpan | TOpAssign SrcSpan @@ -554,10 +748,16 @@ | TSave SrcSpan | TContinue SrcSpan | TStop SrcSpan + | TCycle SrcSpan | TExit SrcSpan + | TCase SrcSpan + | TCaseDefault SrcSpan + | TSelectCase SrcSpan + | TEndSelect SrcSpan | TPause SrcSpan | TDo SrcSpan | TDoWhile SrcSpan + | TWhile SrcSpan | TEndDo SrcSpan | TRead SrcSpan | TWrite SrcSpan @@ -568,9 +768,11 @@ | TOpen SrcSpan | TClose SrcSpan | TPrint SrcSpan + | TTypePrint SrcSpan | TDimension SrcSpan | TCommon SrcSpan | TEquivalence SrcSpan + | TPointer SrcSpan | TExternal SrcSpan | TIntrinsic SrcSpan | TType SrcSpan String @@ -579,9 +781,11 @@ | TNone SrcSpan | TParameter SrcSpan | TData SrcSpan + | TAutomatic SrcSpan | TFormat SrcSpan | TBlob SrcSpan String | TInt SrcSpan String + | TBozInt SrcSpan String | TExponent SrcSpan String | TBool SrcSpan String | TOpPlus SrcSpan @@ -589,8 +793,10 @@ | TOpExp SrcSpan | TStar SrcSpan | TSlash SrcSpan + | TAmpersand SrcSpan | TOpOr SrcSpan | TOpAnd SrcSpan + | TOpXOr SrcSpan | TOpNot SrcSpan | TOpEquivalent SrcSpan | TOpNotEquivalent SrcSpan @@ -645,6 +851,9 @@ , aiStartCode :: Int , aiPreviousToken :: Maybe Token , aiPreviousTokensInLine :: [ Token ] + , aiCaseSensitive :: Bool + , aiInFormat :: Bool + , aiFortranVersion :: FortranVersion } deriving (Show) instance Loc AlexInput where @@ -666,7 +875,11 @@ , aiWhiteSensitiveCharCount = 6 , aiStartCode = 0 , aiPreviousToken = Nothing - , aiPreviousTokensInLine = [ ] } + , aiPreviousTokensInLine = [ ] + , aiCaseSensitive = False + , aiInFormat = False + , aiFortranVersion = Fortran77 + } updateLexeme :: Maybe Char -> Position -> AlexInput -> AlexInput updateLexeme maybeChar p ai = @@ -674,10 +887,11 @@ match = lexemeMatch lexeme newMatch = case maybeChar of - Just c -> toLower c : match + Just c -> c : match Nothing -> match start = lexemeStart lexeme - newStart = if isNothing start then Just p else start + -- skipping should not start a new lexeme + newStart = if isNothing start && isJust maybeChar then Just p else start newEnd = Just p in ai { aiLexeme = Lexeme newMatch newStart newEnd } @@ -685,7 +899,7 @@ -- Definitions needed for alexScanUser -------------------------------------------------------------------------------- -data Move = Continuation | Char | Newline +data Move = Continuation | Char | Newline | NewlineComment | Comment alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte ai @@ -695,17 +909,23 @@ | posAbsoluteOffset _position == aiEndOffset ai = Nothing -- Skip the continuation line altogether | isContinuation ai && _isWhiteInsensitive = skip Continuation ai + -- Skip the newline before a comment + | aiFortranVersion ai == Fortran77Legacy && + _isWhiteInsensitive && isNewlineComment ai = skip NewlineComment ai -- If we are not parsing a Hollerith skip whitespace | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai + -- Ignore inline comments + | aiFortranVersion ai == Fortran77Legacy && + _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai -- Read genuine character and advance. Also covers white sensitivity. | otherwise = - let (_b:_bs) = (utf8Encode . toLower) _curChar in + let (_b:_bs) = utf8Encode _curChar in Just(_b, updateLexeme (Just _curChar) _position ai { aiPosition = case _curChar of - '\n' -> advance Newline _position - _ -> advance Char _position, + '\n' -> advance Newline ai + _ -> advance Char ai, aiBytes = _bs, aiPreviousChar = _curChar, aiWhiteSensitiveCharCount = @@ -714,10 +934,11 @@ else aiWhiteSensitiveCharCount ai - 1 }) where - _curChar = currentChar ai + _curChar = (if aiCaseSensitive ai then id else toLower) $ currentChar ai _bytes = aiBytes ai _position = aiPosition ai _isWhiteInsensitive = aiWhiteSensitiveCharCount ai == 0 + _inFormat = aiInFormat ai alexInputPrevChar :: AlexInput -> Char alexInputPrevChar ai = aiPreviousChar ai @@ -731,19 +952,29 @@ currentChar :: AlexInput -> Char currentChar ai = B.index (aiSourceBytes ai) (fromIntegral . posAbsoluteOffset . aiPosition $ ai) +lookBack :: Int -> AlexInput -> Char +lookBack n ai = B.index (aiSourceBytes ai) (fromIntegral . subtract n . posAbsoluteOffset . aiPosition $ ai) + isContinuation :: AlexInput -> Bool isContinuation ai = take 6 _next7 == "\n " && not (last _next7 `elem` [' ', '0', '\n', '\r']) where _next7 = takeNChars 7 ai +isNewlineComment :: AlexInput -> Bool +isNewlineComment ai = + _next1 == "\n" && isCommentLine ai p + where + _next1 = takeNChars 1 ai + p = (aiPosition ai) { posAbsoluteOffset = posAbsoluteOffset (aiPosition ai) + 1 } + skip :: Move -> AlexInput -> Maybe (Word8, AlexInput) skip move ai = - let _newPosition = advance move $ aiPosition ai in + let _newPosition = advance move ai in alexGetByte $ updateLexeme Nothing _newPosition $ ai { aiPosition = _newPosition } -advance :: Move -> Position -> Position -advance move position = +advance :: Move -> AlexInput -> Position +advance move ai = case move of Char -> position { posAbsoluteOffset = _absl + 1, posColumn = _col + 1 } @@ -751,11 +982,68 @@ position { posAbsoluteOffset = _absl + 7, posColumn = 7, posLine = _line + 1 } Newline -> position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 } + NewlineComment -> + skipComment ai + position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 } + Comment -> + skipComment ai position where + position = aiPosition ai _col = posColumn position _line = posLine position _absl = posAbsoluteOffset position +skipComment :: AlexInput -> Position -> Position +skipComment ai p = + p { posAbsoluteOffset = posAbsoluteOffset p + length line + , posColumn = posColumn p + length line + } + where + line = takeLine p ai + +skipCommentLines :: AlexInput -> Position -> Position +skipCommentLines ai p = go p p + where + go p' p + -- eof is not a comment line + | not (null line) + , isCommentLine ai p + = go p p{ posAbsoluteOffset = posAbsoluteOffset p + length line + 1 -- skip the newline + , posColumn = 1, posLine = posLine p + 1 + } + | isContinuation ai' + = advance Continuation ai' + | otherwise + -- after skipping comment lines, place cursor right at the last newline + = p2 + where + line = takeLine p ai + line' = takeLine p' ai + p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line' + , posColumn = length line' + 1 + } + ai' = ai { aiPosition = p2 } + +isCommentLine :: AlexInput -> Position -> Bool +isCommentLine ai p + -- eof is not a comment line + | posAbsoluteOffset p == aiEndOffset ai + = False + | map toLower (take 1 line) `elem` ["c", "d", "!", "*"] + || all (`elem` " \t") line + || head (dropWhile (`elem` " \t") line) == '!' + = True + | otherwise + = False + where + line = takeLine p ai + +takeLine :: Position -> AlexInput -> String +takeLine p ai = + B.unpack . B.takeWhile (/='\n') . B.drop (fromIntegral _dropN) $ aiSourceBytes ai + where + _dropN = posAbsoluteOffset p + utf8Encode :: Char -> [Word8] utf8Encode = map fromIntegral . _go . ord where @@ -821,7 +1109,8 @@ , psContext = [ ConStart ] } _vanillaAlexInput = vanillaAlexInput { aiSourceBytes = srcBytes - , aiEndOffset = fromIntegral $ B.length srcBytes } + , aiEndOffset = fromIntegral $ B.length srcBytes + , aiFortranVersion = fortranVersion } collectFixedTokens :: FortranVersion -> B.ByteString -> [Token] collectFixedTokens version srcInput = 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 @@ -105,7 +105,11 @@ "function" / { typeSpecP } { addSpan TFunction } <0> "end"\ *"function" { addSpan TEndFunction } "result" / { resultP } { addSpan TResult } +<0> "pure" { toSC 0 >> addSpan TPure } +<0> "elemental" { toSC 0 >> addSpan TElemental } <0> "recursive" { toSC 0 >> addSpan TRecursive } + "pure" / { typeSpecP } { toSC 0 >> addSpan TPure } + "elemental" / { typeSpecP } { toSC 0 >> addSpan TElemental } "recursive" / { typeSpecP } { toSC 0 >> addSpan TRecursive } <0> "subroutine" { addSpan TSubroutine } <0> "end"\ *"subroutine" { addSpan TEndSubroutine } @@ -993,6 +997,8 @@ | TFunction SrcSpan | TEndFunction SrcSpan | TResult SrcSpan + | TPure SrcSpan + | TElemental SrcSpan | TRecursive SrcSpan | TSubroutine SrcSpan | TEndSubroutine SrcSpan 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 @@ -6,8 +6,10 @@ import Language.Fortran.Parser.Fortran66 ( fortran66Parser, fortran66ParserWithModFiles ) import Language.Fortran.Parser.Fortran77 ( fortran77Parser, fortran77ParserWithModFiles - , extended77Parser, extended77ParserWithModFiles ) + , extended77Parser, extended77ParserWithModFiles + , legacy77Parser, legacy77ParserWithModFiles ) import Language.Fortran.Parser.Fortran90 ( fortran90Parser, fortran90ParserWithModFiles ) +import Language.Fortran.Parser.Fortran95 ( fortran95Parser, fortran95ParserWithModFiles ) import qualified Data.ByteString.Char8 as B import Data.Char (toLower) @@ -20,6 +22,7 @@ | isExtensionOf ".fpp" = Fortran77 | isExtensionOf ".ftn" = Fortran77 | isExtensionOf ".f90" = Fortran90 + | isExtensionOf ".f95" = Fortran95 | isExtensionOf ".f03" = Fortran2003 | isExtensionOf ".f2003" = Fortran2003 | isExtensionOf ".f08" = Fortran2008 @@ -34,7 +37,9 @@ [ (Fortran66, fromParseResult `after` fortran66Parser) , (Fortran77, fromParseResult `after` fortran77Parser) , (Fortran77Extended, fromParseResult `after` extended77Parser) - , (Fortran90, fromParseResult `after` fortran90Parser) ] + , (Fortran77Legacy, fromParseResult `after` legacy77Parser) + , (Fortran90, fromParseResult `after` fortran90Parser) + , (Fortran95, fromParseResult `after` fortran95Parser) ] type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserWithModFilesVersions :: [(FortranVersion, ParserWithModFiles)] @@ -42,7 +47,9 @@ [ (Fortran66, \m s -> fromParseResult . fortran66ParserWithModFiles m s) , (Fortran77, \m s -> fromParseResult . fortran77ParserWithModFiles m s) , (Fortran77Extended, \m s -> fromParseResult . extended77ParserWithModFiles m s) - , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s) ] + , (Fortran77Legacy, \m s -> fromParseResult . legacy77ParserWithModFiles m s) + , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s) + , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) ] after g f x = g . (f x) 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) False $3 $4 Nothing (reverse $6) Nothing } + { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing } | function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE - { PUFunction () (getTransSpan $1 $6) Nothing False $2 $3 Nothing (reverse $5) Nothing } + { PUFunction () (getTransSpan $1 $6) Nothing (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing } | subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE - { PUSubroutine () (getTransSpan $1 $6) False $2 $3 (reverse $5) Nothing } + { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing } | blockData NEWLINE BLOCKS end MAYBE_NEWLINE { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } @@ -185,7 +185,7 @@ : EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 } | goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 } -| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 $3 } +| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) } | goto LABELS_IN_STATEMENT VARIABLE { StGotoComputed () (getTransSpan $1 $3) $2 $3 } | if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } | call VARIABLE ARGUMENTS 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 @@ -1,30 +1,40 @@ -- -*- Mode: Haskell -*- { -module Language.Fortran.Parser.Fortran77 ( expressionParser - , statementParser - , fortran77Parser - , extended77Parser - , fortran77ParserWithModFiles - , extended77ParserWithModFiles - ) where +module Language.Fortran.Parser.Fortran77 + ( expressionParser + , statementParser + , fortran77Parser + , extended77Parser + , legacy77Parser + , includeParser + , fortran77ParserWithModFiles + , extended77ParserWithModFiles + , legacy77ParserWithModFiles + , legacy77ParserWithIncludes + ) where import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST import Control.Monad.State +import Data.List import Data.Maybe (isNothing, fromJust) import qualified Data.ByteString.Char8 as B import Language.Fortran.Util.Position import Language.Fortran.Util.ModFile import Language.Fortran.ParserMonad -import Language.Fortran.Lexer.FixedForm +import Language.Fortran.Lexer.FixedForm hiding (Move(..)) import Language.Fortran.Transformer import Language.Fortran.AST -import Debug.Trace +import Data.Generics.Uniplate.Operations +import System.Directory +import System.FilePath +import Control.Exception } %name programParser PROGRAM +%name includesParser INCLUDES %name statementParser STATEMENT %name expressionParser EXPRESSION %monad { LexAction } @@ -44,7 +54,17 @@ program { TProgram _ } function { TFunction _ } subroutine { TSubroutine _ } + endprogram { TEndProgram _ } + endfunction { TEndFunction _ } + endsubroutine { TEndSubroutine _ } blockData { TBlockData _ } + structure { TStructure _ } + union { TUnion _ } + map { TMap _ } + endstructure { TEndStructure _ } + endunion { TEndUnion _ } + endmap { TEndMap _ } + record { TRecord _ } end { TEnd _ } '=' { TOpAssign _ } assign { TAssign _ } @@ -61,13 +81,20 @@ continue { TContinue _ } stop { TStop _ } exit { TExit _ } + cycle { TCycle _ } + case { TCase _ } + selectcase { TSelectCase _ } + endselect { TEndSelect _ } + casedefault { TCaseDefault _ } pause { TPause _ } do { TDo _ } doWhile { TDoWhile _ } + while { TWhile _ } enddo { TEndDo _ } read { TRead _ } write { TWrite _ } print { TPrint _ } + typeprint { TTypePrint _ } open { TOpen _ } close { TClose _ } inquire { TInquire _ } @@ -78,6 +105,7 @@ equivalence { TEquivalence _ } external { TExternal _ } dimension { TDimension _ } + byte { TType _ "byte" } character { TType _ "character" } integer { TType _ "integer" } real { TType _ "real" } @@ -88,12 +116,15 @@ intrinsic { TIntrinsic _ } implicit { TImplicit _ } parameter { TParameter _ } + pointer { TPointer _ } entry { TEntry _ } none { TNone _ } data { TData _ } + automatic { TAutomatic _ } format { TFormat _ } blob { TBlob _ _ } int { TInt _ _ } + boz { TBozInt _ _ } exponent { TExponent _ _ } bool { TBool _ _ } '+' { TOpPlus _ } @@ -101,10 +132,12 @@ '**' { TOpExp _ } '*' { TStar _ } '/' { TSlash _ } + '&' { TAmpersand _ } eqv { TOpEquivalent _ } neqv { TOpNotEquivalent _ } or { TOpOr _ } and { TOpAnd _ } + xor { TOpXOr _ } not { TOpNot _ } '<' { TOpLT _ } '<=' { TOpLE _ } @@ -119,7 +152,7 @@ label { TLabel _ _ } newline { TNewline _ } -%left eqv neqv +%left eqv neqv xor %left or %left and %right not @@ -136,6 +169,24 @@ %% +maybe(p) +: p { Just $1 } +| {- empty -} { Nothing } + +rev_list1(p) +: p { [$1] } +| rev_list1(p) p { $2 : $1 } + +rev_list(p) +: rev_list1(p) { $1 } +| {- empty -} { [] } + +list1(p) +: rev_list1(p) { reverse $1 } + +list(p) +: rev_list(p) { reverse $1 } + -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 } PROGRAM @@ -148,28 +199,60 @@ PROGRAM_UNITS :: { [ ProgramUnit A0 ] } PROGRAM_UNITS -: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 } -| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] } +: PROGRAM_UNITS maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { $3 : $1 } +| maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] } PROGRAM_UNIT :: { ProgramUnit A0 } PROGRAM_UNIT -: program NAME NEWLINE BLOCKS end { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing } -| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end - { PUFunction () (getTransSpan $1 $7) (Just $1) False $3 $4 Nothing (reverse $6) Nothing } -| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end - { PUFunction () (getTransSpan $1 $6) Nothing False $2 $3 Nothing (reverse $5) Nothing } -| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end - { PUSubroutine () (getTransSpan $1 $6) False $2 $3 (reverse $5) Nothing } -| blockData NEWLINE BLOCKS end { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } -| blockData NAME NEWLINE BLOCKS end { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } +: program NAME NEWLINE BLOCKS ENDPROG + { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing } +| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN + { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing } +| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN + { PUFunction () (getTransSpan $1 $6) Nothing (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing } +| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB + { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing } +| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } +| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } +END :: { Token } +END +: end { $1 } +| LABEL_IN_6COLUMN end { $2 } + +ENDPROG :: { Token } +ENDPROG +: END { $1 } +| endprogram MAYBE_ID { $1 } +| LABEL_IN_6COLUMN endprogram MAYBE_ID { $2 } + +ENDFUN :: { Token } +ENDFUN +: END { $1 } +| endfunction MAYBE_ID { $1 } +| LABEL_IN_6COLUMN endfunction MAYBE_ID { $2 } + +ENDSUB :: { Token } +ENDSUB +: END { $1 } +| endsubroutine MAYBE_ID { $1 } +| LABEL_IN_6COLUMN endsubroutine MAYBE_ID { $2 } + MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } : '(' MAYBE_VARIABLES ')' { $2 } | {- Nothing -} { Nothing } +MAYBE_ID :: { Maybe Name } +: id { let (TId _ name) = $1 in Just name } +| {- empty -} { Nothing } + NAME :: { Name } : id { let (TId _ name) = $1 in name } +INCLUDES :: { [ Block A0 ] } +INCLUDES +: maybe(NEWLINE) list(BLOCK) { $2 } + BLOCKS :: { [ Block A0 ] } BLOCKS : BLOCKS BLOCK { $2 : $1 } @@ -185,8 +268,6 @@ COMMENT_BLOCK : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } -MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing } - NEWLINE :: { Token } NEWLINE : NEWLINE newline { $1 } @@ -207,6 +288,7 @@ : do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) } | do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) } | do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) } +| do { StDo () (getSpan $1) Nothing Nothing Nothing } DO_SPECIFICATION :: { DoSpecification A0 } DO_SPECIFICATION @@ -225,6 +307,10 @@ | endif { StEndif () (getSpan $1) Nothing } | doWhile '(' EXPRESSION ')' { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 } +| do LABEL_IN_STATEMENT while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $6) Nothing (Just $2) $5 } +| do LABEL_IN_STATEMENT ',' while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 } | enddo { StEnddo () (getSpan $1) Nothing } | call VARIABLE ARGUMENTS { StCall () (getTransSpan $1 $3) $2 $ Just $3 } @@ -236,8 +322,22 @@ | stop INTEGER_OR_STRING { StStop () (getTransSpan $1 $2) $ Just $2 } | stop { StStop () (getSpan $1) Nothing } | exit { StExit () (getSpan $1) Nothing } +| cycle { StCycle () (getSpan $1) Nothing } | pause INTEGER_OR_STRING { StPause () (getTransSpan $1 $2) $ Just $2 } | pause { StPause () (getSpan $1) Nothing } +| selectcase '(' EXPRESSION ')' + { StSelectCase () (getTransSpan $1 $4) Nothing $3 } +| casedefault { StCase () (getSpan $1) Nothing Nothing } +| casedefault id + { let TId s id = $2 in StCase () (getTransSpan $1 s) (Just id) Nothing } +| case '(' INDICIES ')' + { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) } +| case '(' INDICIES ')' id + { let TId s id = $5 + in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) } +| endselect { StEndcase () (getSpan $1) Nothing } +| endselect id + { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } -- IO Statements | read CILIST IN_IOLIST { StRead () (getTransSpan $1 $3) $2 (Just $ aReverse $3) } | read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing } @@ -247,6 +347,8 @@ | write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing } | print FORMAT_ID ',' OUT_IOLIST { StPrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) } | print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing } +| typeprint FORMAT_ID ',' OUT_IOLIST { StTypePrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) } +| typeprint FORMAT_ID { StTypePrint () (getTransSpan $1 $2) $2 Nothing } | open CILIST { StOpen () (getTransSpan $1 $2) $2 } | close CILIST { StClose () (getTransSpan $1 $2) $2 } | inquire CILIST { StInquire () (getTransSpan $1 $2) $2 } @@ -265,13 +367,11 @@ -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT { $1 } -| VARIABLE { $1 } | '*' { ExpValue () (getSpan $1) ValStar } UNIT :: { Expression A0 } UNIT : INTEGER_LITERAL { $1 } -| VARIABLE { $1 } | SUBSCRIPT { $1 } | '*' { ExpValue () (getSpan $1) ValStar } @@ -323,6 +423,7 @@ | ARITHMETIC_SIGN CI_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | CI_EXPRESSION or CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } | CI_EXPRESSION and CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 } +| CI_EXPRESSION xor CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | not CI_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | CI_EXPRESSION eqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } | CI_EXPRESSION neqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 } @@ -334,7 +435,6 @@ -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT { $1 } -| VARIABLE { $1 } -- Input IOList used in read like statements is much more restrictive as it -- doesn't make sense to read into an integer. @@ -348,8 +448,7 @@ IN_IO_ELEMENT :: { Expression A0 } IN_IO_ELEMENT -: VARIABLE { $1 } -| SUBSCRIPT { $1 } +: SUBSCRIPT { $1 } | '(' IN_IOLIST ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) (aReverse $2) $4 } OUT_IOLIST :: { AList Expression A0 } @@ -375,8 +474,9 @@ GOTO_STATEMENT :: { Statement A0 } GOTO_STATEMENT : goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 } -| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 $3 } -| goto VARIABLE ',' LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $4) $2 $4 } +| goto VARIABLE { StGotoAssigned () (getTransSpan $1 $2) $2 Nothing } +| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) } +| goto VARIABLE ',' LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $4) $2 (Just $4) } | goto LABELS_IN_STATEMENT EXPRESSION { StGotoComputed () (getTransSpan $1 $3) $2 $3 } | goto LABELS_IN_STATEMENT ',' EXPRESSION { StGotoComputed () (getTransSpan $1 $4) $2 $4 } @@ -390,7 +490,9 @@ | dimension ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) } | common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) } | equivalence EQUIVALENCE_GROUPS { StEquivalence () (getTransSpan $1 $2) (aReverse $2) } -| data DATA_GROUPS { StData () (getTransSpan $1 $2) (aReverse $2) } +| pointer POINTER_LIST { StPointer () (getTransSpan $1 $2) (fromReverseList $2) } +| data DATA_GROUPS { StData () (getTransSpan $1 $2) (fromReverseList $2) } +| automatic DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) } -- Following is a fake node to make arbitrary FORMAT statements parsable. -- Must be fixed in the future. TODO | format blob @@ -402,8 +504,39 @@ { StParameter () (getTransSpan $1 $4) $ fromReverseList $3 } | entry VARIABLE { StEntry () (getTransSpan $1 $2) $2 Nothing Nothing } | entry VARIABLE ENTRY_ARGS { StEntry () (getTransSpan $1 $3) $2 (Just $3) Nothing } -| include STRING { StInclude () (getTransSpan $1 $2) $2 } +| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing } +| structure MAYBE_NAME NEWLINE STRUCTURE_DECLARATIONS endstructure + { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) } +MAYBE_NAME :: { Maybe Name } +MAYBE_NAME +: '/' NAME '/' { Just $2 } +| {- empty -} { Nothing } + +STRUCTURE_DECLARATIONS :: { [StructureItem A0] } +STRUCTURE_DECLARATIONS +: STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT + { $2 : $1 } +| STRUCTURE_DECLARATION_STATEMENT { [ $1 ] } + +STRUCTURE_DECLARATION_STATEMENT :: { StructureItem A0 } +STRUCTURE_DECLARATION_STATEMENT +: DECLARATION_STATEMENT NEWLINE + { let StDeclaration () s t attrs decls = $1 + in StructFields () s t attrs decls } +| union NEWLINE UNION_MAPS endunion NEWLINE + { StructUnion () (getTransSpan $1 $5) (fromReverseList $3) } + +UNION_MAPS :: { [ UnionMap A0 ] } +UNION_MAPS +: UNION_MAPS UNION_MAP { $2 : $1 } +| UNION_MAP { [ $1 ] } + +UNION_MAP :: { UnionMap A0 } +UNION_MAP +: map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE + { UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } + ENTRY_ARGS :: { AList Expression A0 } ENTRY_ARGS : ENTRY_ARGS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 } @@ -431,7 +564,7 @@ DECLARATION_STATEMENT :: { Statement A0 } DECLARATION_STATEMENT -: TYPE_SPEC DECLARATORS { StDeclaration () (getTransSpan $1 $2) $1 Nothing $2 } +: TYPE_SPEC maybe(',') DECLARATORS { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) } IMP_LISTS :: { AList ImpList A0 } IMP_LISTS @@ -466,14 +599,23 @@ ELEMENT :: { Expression A0 } ELEMENT -: VARIABLE { $1 } -| SUBSCRIPT { $1 } +: SUBSCRIPT { $1 } -DATA_GROUPS :: { AList DataGroup A0 } +DATA_GROUPS :: { [DataGroup A0] } DATA_GROUPS -: DATA_GROUPS ',' NAME_LIST '/' DATA_ITEMS '/' { setSpan (getTransSpan $1 $6) $ (DataGroup () (getTransSpan $3 $6) (aReverse $3) (aReverse $5)) `aCons` $1 } -| NAME_LIST '/' DATA_ITEMS '/' { AList () (getTransSpan $1 $4) [ DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) ] } +: DATA_GROUPS ',' DATA_GROUP { $3 : $1 } +| DATA_GROUPS DATA_GROUP { $2 : $1 } +| DATA_GROUP { [$1] } +DATA_GROUP :: { DataGroup A0 } +DATA_GROUP +: DATA_NAMES '/' DATA_ITEMS '/' { DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) } + +DATA_NAMES :: { AList Expression A0 } +DATA_NAMES +: NAME_LIST { $1 } +| IMPLIED_DO { fromList () [ $1 ] } + DATA_ITEMS :: { AList Expression A0 } DATA_ITEMS : DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} @@ -481,7 +623,7 @@ DATA_ITEM :: { Expression A0 } DATA_ITEM -: INTEGER_LITERAL '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +: INTEGER_CONSTANT '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | DATA_ITEM_LEVEL1 { $1 } DATA_ITEM_LEVEL1 :: { Expression A0 } @@ -492,12 +634,24 @@ | '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | LOGICAL_LITERAL { $1 } | STRING { $1 } +| HOLLERITH { $1 } EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 } EQUIVALENCE_GROUPS : EQUIVALENCE_GROUPS ',' '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 } | '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] } +POINTER_LIST :: { [ Declarator A0 ] } +POINTER_LIST +: POINTER_LIST ',' POINTER + { $3 : $1 } +| POINTER + { [ $1 ] } + +POINTER :: { Declarator A0 } +: '(' VARIABLE ',' VARIABLE ')' + { DeclVariable () (getTransSpan $1 $5) $2 Nothing (Just $4) } + COMMON_GROUPS :: { AList CommonGroup A0 } COMMON_GROUPS : COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 } @@ -543,12 +697,54 @@ ARRAY_DECLARATOR : VARIABLE '(' DIMENSION_DECLARATORS ')' { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/' + { DeclArray () (getTransSpan $1 $7) $1 (aReverse $3) Nothing + (Just (ExpInitialisation () (getSpan $6) (fromReverseList $6))) } +| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')' + { DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing } +| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/' + { DeclArray () (getTransSpan $1 $9) $1 (aReverse $5) (Just $3) + (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION + { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION_LIST '/' + { DeclArray () (getTransSpan $1 $9) $1 (aReverse $3) (Just $6) + (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) } +SIMPLE_EXPRESSION_LIST :: { [Expression A0] } +SIMPLE_EXPRESSION_LIST +: SIMPLE_EXPRESSION_LIST ',' SIMPLE_EXPRESSION { $3 : $1 } +| SIMPLE_EXPRESSION { [ $1 ] } + +SIMPLE_EXPRESSION :: { Expression A0 } +SIMPLE_EXPRESSION +: INTEGER_CONSTANT '*' CONSTANT { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +| CONSTANT { $1 } +| '(' '*' ')' { ExpValue () (getSpan $2) ValStar } +| '(' EXPRESSION ')' { $2 } + +CONSTANT :: { Expression A0 } +CONSTANT +: VARIABLE { $1 } +| SIGNED_NUMERIC_LITERAL { $1 } +| LOGICAL_LITERAL { $1 } +| STRING { $1 } +| HOLLERITH { $1 } + +INTEGER_CONSTANT :: { Expression A0 } +INTEGER_CONSTANT +: VARIABLE { $1 } +| SIGNED_NUMERIC_LITERAL { $1 } + VARIABLE_DECLARATOR :: { Declarator A0 } VARIABLE_DECLARATOR : VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing } -| VARIABLE '*' EXPRESSION +| VARIABLE '*' SIMPLE_EXPRESSION { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing } +| VARIABLE '/' SIMPLE_EXPRESSION '/' + { DeclVariable () (getTransSpan $1 $4) $1 Nothing (Just $3) } +| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/' + { DeclVariable () (getTransSpan $1 $6) $1 (Just $3) (Just $5) } DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } DIMENSION_DECLARATORS @@ -584,7 +780,9 @@ -- Expression all by itself subsumes all other callable expressions. CALLABLE_EXPRESSION :: { Argument A0 } CALLABLE_EXPRESSION -: HOLLERITH { Argument () (getSpan $1) Nothing $1 } +: id '=' EXPRESSION + { let TId span keyword = $1 + in Argument () (getTransSpan span $3) (Just keyword) $3 } | EXPRESSION { Argument () (getSpan $1) Nothing $1 } EXPRESSION :: { Expression A0 } @@ -597,6 +795,7 @@ | EXPRESSION '/' '/' EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } | ARITHMETIC_SIGN EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | EXPRESSION or EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| EXPRESSION xor EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | EXPRESSION and EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 } | not EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | EXPRESSION eqv EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } @@ -607,16 +806,18 @@ | '(' EXPRESSION ',' EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) } | LOGICAL_LITERAL { $1 } | STRING { $1 } +| HOLLERITH { $1 } -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT, -- hence putting it here would cause a reduce/reduce conflict. | SUBSCRIPT { $1 } -| VARIABLE { $1 } | IMPLIED_DO { $1 } | '(/' EXPRESSION_LIST '/)' { let { exps = reverse $2; expList = AList () (getSpan exps) exps } in ExpInitialisation () (getTransSpan $1 $3) expList } +| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 } +| '&' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 } IMPLIED_DO :: { Expression A0 } IMPLIED_DO @@ -651,6 +852,7 @@ | CONSTANT_EXPRESSION '/' '/' CONSTANT_EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } | ARITHMETIC_SIGN CONSTANT_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | CONSTANT_EXPRESSION or CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| CONSTANT_EXPRESSION xor CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 } | CONSTANT_EXPRESSION and CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 } | not CONSTANT_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 } | CONSTANT_EXPRESSION RELATIONAL_OPERATOR CONSTANT_EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } @@ -659,7 +861,13 @@ | '(' CONSTANT_EXPRESSION ',' CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | LOGICAL_LITERAL { $1 } | string { let (TString s cs) = $1 in ExpValue () s (ValString cs) } -| VARIABLE { $1 } +| SUBSCRIPT { $1 } +| HOLLERITH { $1 } +| '(/' EXPRESSION_LIST '/)' { + let { exps = reverse $2; + expList = AList () (getSpan exps) exps } + in ExpInitialisation () (getTransSpan $1 $3) expList + } ARITHMETIC_CONSTANT_EXPRESSION :: { Expression A0 } ARITHMETIC_CONSTANT_EXPRESSION @@ -685,13 +893,13 @@ SUBSCRIPT :: { Expression A0 } SUBSCRIPT -: VARIABLE '(' ')' +: SUBSCRIPT '.' VARIABLE + { ExpDataRef () (getTransSpan $1 $3) $1 $3 } +| SUBSCRIPT '(' ')' { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing } -| VARIABLE '(' INDICIES ')' +| SUBSCRIPT '(' INDICIES ')' { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } -| VARIABLE '(' INDICIES ')' '(' INDICIES ')' - { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) - in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) } +| VARIABLE { $1 } INDICIES :: { [ Index A0 ] } : INDICIES ',' INDEX { $3 : $1 } @@ -717,8 +925,16 @@ : VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing } VARIABLES :: { [ Expression A0 ] } -VARIABLES : VARIABLES ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] } +VARIABLES +: VARIABLES ',' VARIABLE_OR_STAR { $3 : $1 } +| VARIABLE_OR_STAR { [ $1 ] } +VARIABLE_OR_STAR :: { Expression A0 } +VARIABLE_OR_STAR +: VARIABLE { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } +| '&' { ExpValue () (getSpan $1) ValStar } + -- This may also be used to parse a function name, or an array name. Since when -- are valid options in a production there is no way of differentiating them at -- this stage. @@ -727,7 +943,9 @@ VARIABLE : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s } -INTEGER_LITERAL :: { Expression A0 } : int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i } +INTEGER_LITERAL :: { Expression A0 } +: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i } +| boz { let TBozInt s i = $1 in ExpValue () s $ ValInteger i } REAL_LITERAL :: { Expression A0 } REAL_LITERAL @@ -777,45 +995,47 @@ TYPE_SPEC :: { TypeSpec A0 } TYPE_SPEC -: integer KIND_SELECTOR { TypeSpec () (getSpan $1) TypeInteger Nothing } -| real KIND_SELECTOR { TypeSpec () (getSpan $1) TypeReal Nothing } +: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 } +| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 } | doublePrecision KIND_SELECTOR - { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } -| logical KIND_SELECTOR { TypeSpec () (getSpan $1) TypeLogical Nothing } -| complex KIND_SELECTOR { TypeSpec () (getSpan $1) TypeComplex Nothing } + { TypeSpec () (getSpan ($1, $2)) TypeDoublePrecision $2 } +| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } +| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } | doubleComplex KIND_SELECTOR - { TypeSpec () (getSpan $1) TypeDoubleComplex Nothing } + { TypeSpec () (getSpan ($1, $2)) TypeDoubleComplex $2 } | character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +| byte KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 } +| record '/' NAME '/' { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing } KIND_SELECTOR :: { Maybe (Selector A0) } KIND_SELECTOR +: KIND_SELECTOR1 + { Just $1 } +| {- EMPTY -} + { Nothing } + +KIND_SELECTOR1 :: { Selector A0 } +KIND_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION - { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) } -| '*' '(' STAR ')' { Just $ Selector () (getTransSpan $1 $4) Nothing (Just $3) } -| {- EMPTY -} { Nothing } + { Selector () (getTransSpan $1 $2) Nothing (Just $2) } +| '*' '(' STAR ')' { Selector () (getTransSpan $1 $4) Nothing (Just $3) } CHAR_SELECTOR :: { Maybe (Selector A0) } -CHAR_SELECTOR -: '(' ARITHMETIC_CONSTANT_EXPRESSION ')' - { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing } -| BASIC_CHAR_SELECTOR { $1 } +: CHAR_SELECTOR1 + { Just $1 } +| {- EMPTY -} + { Nothing } -BASIC_CHAR_SELECTOR :: { Maybe (Selector A0) } -BASIC_CHAR_SELECTOR +CHAR_SELECTOR1 :: { Selector A0 } +CHAR_SELECTOR1 : '*' ARITHMETIC_CONSTANT_EXPRESSION - { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing } -| '*' '(' STAR ')' { Just $ Selector () (getTransSpan $1 $4) (Just $3) Nothing } -| {- EMPTY -} { Nothing } + { Selector () (getTransSpan $1 $2) (Just $2) Nothing } +| '*' '(' STAR ')' + { Selector () (getTransSpan $1 $4) (Just $3) Nothing } IMP_TYPE_SPEC :: { TypeSpec A0 } IMP_TYPE_SPEC -: integer { TypeSpec () (getSpan $1) TypeInteger Nothing } -| real { TypeSpec () (getSpan $1) TypeReal Nothing } -| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } -| logical { TypeSpec () (getSpan $1) TypeLogical Nothing } -| complex { TypeSpec () (getSpan $1) TypeComplex Nothing } -| doubleComplex { TypeSpec () (getSpan $1) TypeDoubleComplex Nothing } -| character BASIC_CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +: TYPE_SPEC { $1 } STAR :: { Expression A0 } STAR : '*' { ExpValue () (getSpan $1) ValStar } @@ -858,6 +1078,7 @@ [ GroupLabeledDo , GroupDo , GroupIf + , GroupCase , DisambiguateIntrinsic , DisambiguateFunction ] @@ -872,6 +1093,69 @@ where transform = transformWithModFiles mods transformations77Extended parseState = initParseState sourceCode Fortran77Extended filename + +transformations77Legacy = + [ GroupLabeledDo + , GroupDo + , GroupIf + , DisambiguateIntrinsic + , DisambiguateFunction + ] +legacy77Parser :: + B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +legacy77Parser = legacy77ParserWithModFiles emptyModFiles + +legacy77ParserWithModFiles :: + ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +legacy77ParserWithModFiles mods sourceCode filename = + fmap (pfSetFilename filename . transform) $ parse parseState + where + transform = transformWithModFiles mods transformations77Legacy + parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename + +legacy77ParserWithIncludes :: + [String] -> B.ByteString -> String -> IO (ParseResult AlexInput Token (ProgramFile A0)) +legacy77ParserWithIncludes incs sourceCode filename = + fmap (pfSetFilename filename . transform) <$> doParse + where + doParse = case parse parseState of + ParseFailed e -> return (ParseFailed e) + ParseOk p x -> do + p' <- descendBiM (inlineInclude Fortran77Legacy incs) p + return (ParseOk p' x) + transform = transformWithModFiles emptyModFiles transformations77Legacy + parseState = initParseState sourceCode Fortran77Legacy filename + +includeParser :: + FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0] +includeParser version sourceCode filename = + runParse includesParser parseState + where + -- ensure the file ends with a newline.. + parseState = initParseState (sourceCode `B.snoc` '\n') version filename + +inlineInclude :: FortranVersion -> [String] -> Statement A0 -> IO (Statement A0) +inlineInclude fv dirs st = case st of + StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do + inc <- truncateLines <$> readInDirs dirs path + case includeParser fv inc path of + ParseOk blocks _ -> do + blocks' <- descendBiM (inlineInclude fv dirs) blocks + return $ StInclude a s e (Just blocks') + ParseFailed e -> throwIO e + _ -> return st + +readInDirs :: [String] -> String -> IO B.ByteString +readInDirs [] f = fail $ "cannot find file: " ++ f +readInDirs (d:ds) f = do + b <- doesFileExist (df) + if b then + B.readFile (df) + else + readInDirs ds f + +truncateLines :: B.ByteString -> B.ByteString +truncateLines b = B.unlines . map (B.filter (/='\r') . B.take 72) . B.lines $ b parseError :: Token -> LexAction a parseError _ = do 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 @@ -1,6 +1,7 @@ -- -*- Mode: Haskell -*- { module Language.Fortran.Parser.Fortran90 ( statementParser + , functionParser , fortran90Parser , fortran90ParserWithModFiles ) where @@ -27,6 +28,7 @@ } %name programParser PROGRAM +%name functionParser SUBPROGRAM_UNIT %name statementParser STATEMENT %monad { LexAction } %lexer { lexer } { TEOF _ } @@ -237,22 +239,25 @@ SUBPROGRAM_UNIT :: { ProgramUnit A0 } : TYPE_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $10 $3; - return $ PUFunction () (getTransSpan $1 $10) (Just $1) False $3 $4 $6 (reverse $8) $9 } } + return $ PUFunction () (getTransSpan $1 $10) (Just $1) (None () initSrcSpan False) $3 $4 $6 (reverse $8) $9 } } | TYPE_SPEC recursive function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $11 $4; - return $ PUFunction () (getTransSpan $1 $11) (Just $1) True $4 $5 $7 (reverse $9) $10 } } + return $ PUFunction () (getTransSpan $1 $11) (Just $1) (None () (getSpan $2) True) $4 $5 $7 (reverse $9) $10 } } | recursive TYPE_SPEC function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $11 $4; - return $ PUFunction () (getTransSpan $1 $11) (Just $2) True $4 $5 $6 (reverse $9) $10 } } + return $ PUFunction () (getTransSpan $1 $11) (Just $2) (None () (getSpan $1) True) $4 $5 $6 (reverse $9) $10 } } | function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END {% do { unitNameCheck $9 $2; - return $ PUFunction () (getTransSpan $1 $9) Nothing False $2 $3 $4 (reverse $7) $8 } } + return $ PUFunction () (getTransSpan $1 $9) Nothing (None () initSrcSpan False) $2 $3 $4 (reverse $7) $8 } } +| recursive function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END + {% do { unitNameCheck $10 $3; + return $ PUFunction () (getTransSpan $1 $10) Nothing (None () initSrcSpan True) $3 $4 $5 (reverse $8) $9 } } | subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END {% do { unitNameCheck $8 $2; - return $ PUSubroutine () (getTransSpan $1 $8) False $2 $3 (reverse $6) $7 } } + return $ PUSubroutine () (getTransSpan $1 $8) (None () initSrcSpan False) $2 $3 (reverse $6) $7 } } | recursive subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END {% do { unitNameCheck $9 $3; - return $ PUSubroutine () (getTransSpan $1 $9) True $3 $4 (reverse $7) $8 } } + return $ PUSubroutine () (getTransSpan $1 $9) (None () initSrcSpan True) $3 $4 (reverse $7) $8 } } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } @@ -407,7 +412,7 @@ | endType { StEndType () (getSpan $1) Nothing } | endType id { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) } -| include STRING { StInclude () (getTransSpan $1 $2) $2 } +| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing } -- Following is a fake node to make arbitrary FORMAT statements parsable. -- Must be fixed in the future. TODO | format blob @@ -467,10 +472,14 @@ | cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) } | exit { StExit () (getSpan $1) Nothing } | exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) } +-- GO TO label | goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 } +-- GO TO scalar-int-variable | goto VARIABLE { StGotoUnconditional () (getTransSpan $1 $2) $2 } +-- GO TO scalar-int-variable [,] label-list | goto VARIABLE MAYBE_COMMA '(' INTEGERS ')' - { StGotoAssigned () (getTransSpan $1 $6) $2 (fromReverseList $5) } + { StGotoAssigned () (getTransSpan $1 $6) $2 (Just (fromReverseList $5)) } +-- GO TO label-list [,] scalar-int-expression | goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 } | assign INTEGER_LITERAL to VARIABLE diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Parser/Fortran95.y @@ -0,0 +1,1178 @@ +-- -*- Mode: Haskell -*- +{ +module Language.Fortran.Parser.Fortran95 ( functionParser + , statementParser + , fortran95Parser + , fortran95ParserWithModFiles + ) where + +import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST +import Control.Monad.State +import Data.Maybe (fromMaybe, isJust) +import Data.List (nub) +import Data.Either (either, lefts, rights) +import Control.Applicative +import qualified Data.ByteString.Char8 as B + +#ifdef DEBUG +import Data.Data (toConstr) +#endif + +import Language.Fortran.Util.Position +import Language.Fortran.Util.ModFile +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FreeForm +import Language.Fortran.AST +import Language.Fortran.Transformer + +import Debug.Trace + +} + +%name programParser PROGRAM +%name statementParser STATEMENT +%name functionParser SUBPROGRAM_UNIT +%monad { LexAction } +%lexer { lexer } { TEOF _ } +%tokentype { Token } +%error { parseError } + +%token + id { TId _ _ } + comment { TComment _ _ } + string { TString _ _ } + int { TIntegerLiteral _ _ } + float { TRealLiteral _ _ } + boz { TBozLiteral _ _ } + ',' { TComma _ } + ',2' { TComma2 _ } + ';' { TSemiColon _ } + ':' { TColon _ } + '::' { TDoubleColon _ } + '=' { TOpAssign _ } + '=>' { TArrow _ } + '%' { TPercent _ } + '(' { TLeftPar _ } + '(2' { TLeftPar2 _ } + ')' { TRightPar _ } + '(/' { TLeftInitPar _ } + '/)' { TRightInitPar _ } + opCustom { TOpCustom _ _ } + '**' { TOpExp _ } + '+' { TOpPlus _ } + '-' { TOpMinus _ } + '*' { TStar _ } + '/' { TOpDivision _ } + slash { TSlash _ } + or { TOpOr _ } + and { TOpAnd _ } + not { TOpNot _ } + eqv { TOpEquivalent _ } + neqv { TOpNotEquivalent _ } + '<' { TOpLT _ } + '<=' { TOpLE _ } + '==' { TOpEQ _ } + '!=' { TOpNE _ } + '>' { TOpGT _ } + '>=' { TOpGE _ } + bool { TLogicalLiteral _ _ } + program { TProgram _ } + endProgram { TEndProgram _ } + function { TFunction _ } + endFunction { TEndFunction _ } + result { TResult _ } + pure { TPure _ } + elemental { TElemental _ } + recursive { TRecursive _ } + subroutine { TSubroutine _ } + endSubroutine { TEndSubroutine _ } + blockData { TBlockData _ } + endBlockData { TEndBlockData _ } + module { TModule _ } + endModule { TEndModule _ } + contains { TContains _ } + use { TUse _ } + only { TOnly _ } + interface { TInterface _ } + endInterface { TEndInterface _ } + moduleProcedure { TModuleProcedure _ } + assignment { TAssignment _ } + operator { TOperator _ } + call { TCall _ } + return { TReturn _ } + entry { TEntry _ } + include { TInclude _ } + public { TPublic _ } + private { TPrivate _ } + parameter { TParameter _ } + allocatable { TAllocatable _ } + dimension { TDimension _ } + external { TExternal _ } + intent { TIntent _ } + intrinsic { TIntrinsic _ } + optional { TOptional _ } + pointer { TPointer _ } + save { TSave _ } + target { TTarget _ } + in { TIn _ } + out { TOut _ } + inout { TInOut _ } + data { TData _ } + namelist { TNamelist _ } + implicit { TImplicit _ } + equivalence { TEquivalence _ } + common { TCommon _ } + allocate { TAllocate _ } + deallocate { TDeallocate _ } + nullify { TNullify _ } + none { TNone _ } + goto { TGoto _ } + to { TTo _ } + continue { TContinue _ } + stop { TStop _ } + do { TDo _ } + enddo { TEndDo _ } + while { TWhile _ } + if { TIf _ } + then { TThen _ } + else { TElse _ } + elsif { TElsif _ } + endif { TEndIf _ } + case { TCase _ } + selectcase { TSelectCase _ } + endselect { TEndSelect _ } + default { TDefault _ } + cycle { TCycle _ } + exit { TExit _ } + where { TWhere _ } + elsewhere { TElsewhere _ } + endwhere { TEndWhere _ } + type { TType _ } + endType { TEndType _ } + sequence { TSequence _ } + kind { TKind _ } + len { TLen _ } + integer { TInteger _ } + real { TReal _ } + doublePrecision { TDoublePrecision _ } + logical { TLogical _ } + character { TCharacter _ } + complex { TComplex _ } + open { TOpen _ } + close { TClose _ } + read { TRead _ } + write { TWrite _ } + print { TPrint _ } + backspace { TBackspace _ } + rewind { TRewind _ } + inquire { TInquire _ } + endfile { TEndfile _ } + format { TFormat _ } + blob { TBlob _ _ } + end { TEnd _ } + newline { TNewline _ } + forall { TForall _ } + endforall { TEndForall _ } +-- Precedence of operators + +-- Level 6 +%left opCustom + +-- Level 5 +%left eqv neqv +%left or +%left and +%right not + +-- Level 4 +%nonassoc '==' '!=' '>' '<' '>=' '<=' +%nonassoc RELATIONAL + +-- Level 3 +%left CONCAT + +-- Level 2 +%left '+' '-' +%left '*' '/' +%right SIGN +%right '**' + +-- Level 1 +%right DEFINED_UNARY + +-- Level 0 +%left '%' + +%% + +-- This rule is to ignore leading whitespace +PROGRAM :: { ProgramFile A0 } +: NEWLINE PROGRAM_INNER { $2 } +| PROGRAM_INNER { $1 } + +PROGRAM_INNER :: { ProgramFile A0 } +: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran95, miFilename = "" }) (reverse $1) } + +PROGRAM_UNITS :: { [ ProgramUnit A0 ] } +: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 } +| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] } + +PROGRAM_UNIT :: { ProgramUnit A0 } +: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END + {% do { unitNameCheck $6 $2; + return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } } +| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END + {% do { unitNameCheck $6 $2; + return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } } +| blockData NEWLINE BLOCKS BLOCK_DATA_END + { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } +| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END + {% do { unitNameCheck $5 $2; + return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } } +| SUBPROGRAM_UNIT { $1 } + +MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] } +: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 } +| {- Empty -} { Nothing } + +SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] } +: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 } +| {- EMPTY -} { [ ] } + +SUBPROGRAM_UNIT :: { ProgramUnit A0 } +: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END + {% do { unitNameCheck $10 $3; + let (fSpec, typeSpec) = $1 in + return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9 } } +| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END + {% do { unitNameCheck $9 $3; + let (fSpec, _) = $1 in + return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8 } } +| comment { let (TComment s c) = $1 in PUComment () s (Comment c) } +| recursive RECURSIVE_SUBPROGRAM_UNIT { setSpan (getTransSpan $1 $2) $2 } + +RECURSIVE_SUBPROGRAM_UNIT :: { ProgramUnit A0 } +: FUNCTION_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END + {% do + unitNameCheck $10 $3 + fSpec <- either fail return $ fst $1 `buildPUFunctionOpt` None () (getSpan $ fst $1) True + let typeSpec = snd $1 + return $ PUFunction () (getTransSpan $2 $10) typeSpec fSpec $3 $4 $6 (reverse $8) $9 + } +| FUNCTION_SPEC subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END + {% do + unitNameCheck $9 $3 + fSpec <- either fail return $ fst $1 `buildPUFunctionOpt` None () (getSpan $ fst $1) True + return $ PUSubroutine () (getTransSpan $2 $9) fSpec $3 $4 (reverse $7) $8 + } + + +FUNCTION_SPEC :: { (PUFunctionOpt A0, Maybe (TypeSpec A0)) } +: PFUNCTION_SPECS {% do + let funcSpecs = lefts $1 + let typeSpecs = rights $1 + if length typeSpecs > 1 + then fail "Specified a type spec multiple times in a function spec." + else if length (nub funcSpecs) /= length funcSpecs then fail "Specified a function spec multiple times." + else do + let typeSpec = case typeSpecs of + [] -> Nothing + (x:_) -> Just x + funcSpec <- either fail return $ buildPUFunctionOpts funcSpecs + return (funcSpec, typeSpec) + } + +PFUNCTION_SPECS :: { [Either (PUFunctionOpt A0) (TypeSpec A0)] } +: {- EMPTY -} { [] } +| PFUNCTION_SPEC PFUNCTION_SPECS { $1 : $2 } + +-- crucically, recursive cannot appear first, which is dealt with in SUBPROGRAM_UNIT +| PFUNCTION_SPEC recursive PFUNCTION_SPECS { $1 : Left (None () (getSpan $2) True) : $3 } + +PFUNCTION_SPEC :: { Either (PUFunctionOpt A0) (TypeSpec A0) } +: pure { Left $ Pure () (getSpan $1) False } +| elemental { Left $ Elemental () (getSpan $1) } +| TYPE_SPEC { Right $ $1 } + +MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } +: '(' MAYBE_VARIABLES ')' { $2 } +| {- Nothing -} { Nothing } + +RESULT :: { Maybe (Expression a) } +: result '(' VARIABLE ')' { Just $3 } +| {- EMPTY -} { Nothing } + +PROGRAM_END :: { Token } +: end { $1 } | endProgram { $1 } | endProgram id { $2 } +MODULE_END :: { Token } +: end { $1 } | endModule { $1 } | endModule id { $2 } +FUNCTION_END :: { Token } +: end { $1 } | endFunction { $1 } | endFunction id { $2 } +SUBROUTINE_END :: { Token } +: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 } +BLOCK_DATA_END :: { Token } +: end { $1 } | endBlockData { $1 } | endBlockData id { $2 } + +NAME :: { Name } : id { let (TId _ name) = $1 in name } + +BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } + +BLOCK :: { Block A0 } +: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE + { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } +| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } +| interface MAYBE_EXPRESSION NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE + { BlInterface () (getTransSpan $1 $7) $2 $4 $5 } +| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE + { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 } +| COMMENT_BLOCK { $1 } + +MAYBE_EXPRESSION :: { Maybe (Expression A0) } +: EXPRESSION { Just $1 } +| {- EMPTY -} { Nothing } + +MAYBE_COMMENT :: { Maybe Token } +: comment { Just $1 } +| {- EMPTY -} { Nothing } + +SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] } +: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 } + +MODULE_PROCEDURES :: { [ Block A0 ] } +: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 } +| { [ ] } + +MODULE_PROCEDURE :: { Block A0 } +: moduleProcedure VARIABLES NEWLINE + { let { al = fromReverseList $2; + st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) } + in BlStatement () (getTransSpan $1 $3) Nothing st } + +COMMENT_BLOCK :: { Block A0 } +: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } + +MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing } + +NEWLINE :: { Token } +: NEWLINE newline { $1 } +| NEWLINE ';' { $1 } +| newline { $1 } +| ';' { $1 } + +STATEMENT :: { Statement A0 } +: NONEXECUTABLE_STATEMENT { $1 } +| EXECUTABLE_STATEMENT { $1 } + +EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 } +: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 } + +NONEXECUTABLE_STATEMENT :: { Statement A0 } +: DECLARATION_STATEMENT { $1 } +| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $6 + in StIntent () (getTransSpan $1 expAList) $3 expAList } +| optional MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StOptional () (getTransSpan $1 expAList) expAList } +| public MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StPublic () (getTransSpan $1 expAList) (Just expAList) } +| public { StPublic () (getSpan $1) Nothing } +| private MAYBE_DCOLON EXPRESSION_LIST + { let expAList = fromReverseList $3 + in StPrivate () (getTransSpan $1 expAList) (Just expAList) } +| private { StPrivate () (getSpan $1) Nothing } +| save MAYBE_DCOLON SAVE_ARGS + { let saveAList = (fromReverseList $3) + in StSave () (getTransSpan $1 saveAList) (Just saveAList) } +| save { StSave () (getSpan $1) Nothing } +| dimension MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StDimension () (getTransSpan $1 declAList) declAList } +| allocatable MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StAllocatable () (getTransSpan $1 declAList) declAList } +| pointer MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StPointer () (getTransSpan $1 declAList) declAList } +| target MAYBE_DCOLON DECLARATOR_LIST + { let declAList = fromReverseList $3 + in StTarget () (getTransSpan $1 declAList) declAList } +| data cDATA DATA_GROUPS cPOP + { let dataAList = fromReverseList $3 + in StData () (getTransSpan $1 dataAList) dataAList } +| parameter '(' PARAMETER_ASSIGNMENTS ')' + { let declAList = fromReverseList $3 + in StParameter () (getTransSpan $1 $4) declAList } +| implicit none { StImplicit () (getTransSpan $1 $2) Nothing } +| implicit cIMPLICIT IMP_LISTS cPOP + { let impAList = fromReverseList $3 + in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList } +| namelist cNAMELIST NAMELISTS cPOP + { let nameALists = fromReverseList $3 + in StNamelist () (getTransSpan $1 nameALists) nameALists } +| equivalence EQUIVALENCE_GROUPS + { let eqALists = fromReverseList $2 + in StEquivalence () (getTransSpan $1 eqALists) eqALists } +| common cCOMMON COMMON_GROUPS cPOP + { let commonAList = fromReverseList $3 + in StCommon () (getTransSpan $1 commonAList) commonAList } +| external VARIABLES + { let alist = fromReverseList $2 + in StExternal () (getTransSpan $1 alist) alist } +| intrinsic VARIABLES + { let alist = fromReverseList $2 + in StIntrinsic () (getTransSpan $1 alist) alist } +| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing } +| use VARIABLE ',' RENAME_LIST + { let alist = fromReverseList $4 + in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) } +| use VARIABLE ',' only ':' RENAME_LIST + { let alist = fromReverseList $6 + in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) } +| entry VARIABLE RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 } +| entry VARIABLE '(' ')' RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 } +| entry VARIABLE '(' VARIABLES ')' RESULT + { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 } +| sequence { StSequence () (getSpan $1) } +| type ATTRIBUTE_LIST '::' id + { let { TId span id = $4; + alist = if null $2 then Nothing else (Just . fromReverseList) $2 } + in StType () (getTransSpan $1 span) alist id } +| type id + { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id } +| endType { StEndType () (getSpan $1) Nothing } +| endType id + { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) } +| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing } +-- Following is a fake node to make arbitrary FORMAT statements parsable. +-- Must be fixed in the future. TODO +| format blob + { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } + +EXECUTABLE_STATEMENT :: { Statement A0 } +: allocate '(' DATA_REFS ')' + { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } +| allocate '(' DATA_REFS ',' CILIST_PAIR ')' + { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +| nullify '(' DATA_REFS ')' + { StNullify () (getTransSpan $1 $4) (fromReverseList $3) } +| deallocate '(' DATA_REFS ')' + { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing } +| deallocate '(' DATA_REFS ',' CILIST_PAIR ')' + { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) } +| EXPRESSION_ASSIGNMENT_STATEMENT { $1 } +| POINTER_ASSIGNMENT_STMT { $1 } +| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT + { StWhere () (getTransSpan $1 $5) $3 $5 } +| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) $3 } +| elsewhere { StElsewhere () (getSpan $1) } +| endwhere { StEndWhere () (getSpan $1) } +| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL + { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 } +| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 } +| id ':' if '(' EXPRESSION ')' then + { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 } +| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 } +| elsif '(' EXPRESSION ')' then id + { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 } +| else { StElse () (getSpan $1) Nothing } +| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) } +| endif { StEndif () (getSpan $1) Nothing } +| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) } +| do { StDo () (getSpan $1) Nothing Nothing Nothing } +| id ':' do + { let TId s id = $1 + in StDo () (getTransSpan s $3) (Just id) Nothing Nothing } +| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION + { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) } +| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) } +| id ':' do DO_SPECIFICATION + { let TId s id = $1 + in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) } +| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 } +| do while '(' EXPRESSION ')' + { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 } +| id ':' do while '(' EXPRESSION ')' + { let TId s id = $1 + in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 } +| enddo { StEnddo () (getSpan $1) Nothing } +| enddo id + { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) } +| cycle { StCycle () (getSpan $1) Nothing } +| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) } +| exit { StExit () (getSpan $1) Nothing } +| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) } +-- GO TO label +| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 } +-- GO TO label-list [,] scalar-int-expression +| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION + { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 } +| continue { StContinue () (getSpan $1) } +| stop { StStop () (getSpan $1) Nothing } +| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) } +| selectcase '(' EXPRESSION ')' + { StSelectCase () (getTransSpan $1 $4) Nothing $3 } +| id ':' selectcase '(' EXPRESSION ')' + { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 } +| case default { StCase () (getTransSpan $1 $2) Nothing Nothing } +| case default id + { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing } +| case '(' INDICIES ')' + { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) } +| case '(' INDICIES ')' id + { let TId s id = $5 + in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) } +| endselect { StEndcase () (getSpan $1) Nothing } +| endselect id + { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) } +| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT + { StIfLogical () (getTransSpan $1 $5) $3 $5 } +| read CILIST IN_IOLIST + { let alist = fromReverseList $3 + in StRead () (getTransSpan $1 alist) $2 (Just alist) } +| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing } +| read FORMAT_ID ',' IN_IOLIST + { let alist = fromReverseList $4 + in StRead2 () (getTransSpan $1 alist) $2 (Just alist) } +| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing } +| write CILIST OUT_IOLIST + { let alist = fromReverseList $3 + in StWrite () (getTransSpan $1 alist) $2 (Just alist) } +| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing } +| print FORMAT_ID ',' OUT_IOLIST + { let alist = fromReverseList $4 + in StPrint () (getTransSpan $1 alist) $2 (Just alist) } +| print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing } +| open CILIST { StOpen () (getTransSpan $1 $2) $2 } +| close CILIST { StClose () (getTransSpan $1 $2) $2 } +| inquire CILIST { StInquire () (getTransSpan $1 $2) $2 } +| rewind CILIST { StRewind () (getTransSpan $1 $2) $2 } +| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 } +| endfile CILIST { StEndfile () (getTransSpan $1 $2) $2 } +| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 } +| backspace CILIST { StBackspace () (getTransSpan $1 $2) $2 } +| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 } +| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing } +| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing } +| call VARIABLE '(' ARGUMENTS ')' + { let alist = fromReverseList $4 + in StCall () (getTransSpan $1 $5) $2 (Just alist) } +| return { StReturn () (getSpan $1) Nothing } +| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) } +| FORALL { $1 } +| END_FORALL { $1 } + +ARGUMENTS :: { [ Argument A0 ] } +: ARGUMENTS ',' ARGUMENT { $3 : $1 } +| ARGUMENT { [ $1 ] } + +ARGUMENT :: { Argument A0 } +: id '=' EXPRESSION + { let TId span keyword = $1 + in Argument () (getTransSpan span $3) (Just keyword) $3 } +| EXPRESSION + { Argument () (getSpan $1) Nothing $1 } + +RENAME_LIST :: { [ Use A0 ] } +: RENAME_LIST ',' RENAME { $3 : $1 } +| RENAME { [ $1 ] } + +RENAME :: { Use A0 } +: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 } +| VARIABLE { UseID () (getSpan $1) $1 } + +MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () } + +FORMAT_ID :: { Expression A0 } +: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| INTEGER_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +UNIT :: { Expression A0 } +: INTEGER_LITERAL { $1 } +| DATA_REF { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +CILIST :: { AList ControlPair A0 } +: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + cp2 = ControlPair () (getSpan $4) Nothing $4; + tail = fromReverseList $6 } + in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail } +| '(' CILIST_ELEMENT ',' FORMAT_ID ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + cp2 = ControlPair () (getSpan $4) Nothing $4 } + in AList () (getTransSpan $1 $5) [ cp1, cp2 ] } +| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')' + { let { cp1 = ControlPair () (getSpan $2) Nothing $2; + tail = fromReverseList $4 } + in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail } +| '(' CILIST_ELEMENT ')' + { let cp1 = ControlPair () (getSpan $2) Nothing $2 + in AList () (getTransSpan $1 $3) [ cp1 ] } +| '(' CILIST_PAIRS ')' { fromReverseList $2 } + +CILIST_PAIRS :: { [ ControlPair A0 ] } +: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 } +| CILIST_PAIR { [ $1 ] } + +CILIST_PAIR :: { ControlPair A0 } +: id '=' CILIST_ELEMENT + { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 } + +CILIST_ELEMENT :: { Expression A0 } +: CI_EXPRESSION { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +CI_EXPRESSION :: { Expression A0 } +: CI_EXPRESSION '+' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } +| CI_EXPRESSION '-' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } +| CI_EXPRESSION '*' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +| CI_EXPRESSION '/' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Division $1 $3 } +| CI_EXPRESSION '**' CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 } +| CI_EXPRESSION '/' '/' CI_EXPRESSION %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| ARITHMETIC_SIGN CI_EXPRESSION %prec SIGN + { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } +| CI_EXPRESSION or CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| CI_EXPRESSION and CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) And $1 $3 } +| not CI_EXPRESSION + { ExpUnary () (getTransSpan $1 $2) Not $2 } +| CI_EXPRESSION eqv CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } +| CI_EXPRESSION neqv CI_EXPRESSION + { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 } +| CI_EXPRESSION RELATIONAL_OPERATOR CI_EXPRESSION %prec RELATIONAL + { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } +| opCustom CI_EXPRESSION %prec DEFINED_UNARY + { let TOpCustom span str = $1 + in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 } +| CI_EXPRESSION opCustom CI_EXPRESSION + { let TOpCustom _ str = $2 + in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 } +| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } +| INTEGER_LITERAL { $1 } +| LOGICAL_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } + +IN_IOLIST :: { [ Expression A0 ] } +: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1} +| IN_IO_ELEMENT { [ $1 ] } + +IN_IO_ELEMENT :: { Expression A0 } +: DATA_REF { $1 } +| '(' IN_IOLIST ',' DO_SPECIFICATION ')' + { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 } + +OUT_IOLIST :: { [ Expression A0 ] } +: OUT_IOLIST ',' EXPRESSION { $3 : $1} +| EXPRESSION { [ $1 ] } + +COMMON_GROUPS :: { [ CommonGroup A0 ] } +: COMMON_GROUPS COMMON_GROUP { $2 : $1 } +| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 } +| INIT_COMMON_GROUP { [ $1 ] } + +COMMON_GROUP :: { CommonGroup A0 } +: COMMON_NAME PART_REFS + { let alist = fromReverseList $2 + in CommonGroup () (getTransSpan $1 alist) (Just $1) alist } +| '/' '/' PART_REFS + { let alist = fromReverseList $3 + in CommonGroup () (getTransSpan $1 alist) Nothing alist } + +INIT_COMMON_GROUP :: { CommonGroup A0 } +: COMMON_NAME PART_REFS + { let alist = fromReverseList $2 + in CommonGroup () (getTransSpan $1 alist) (Just $1) alist } +| '/' '/' PART_REFS + { let alist = fromReverseList $3 + in CommonGroup () (getTransSpan $1 alist) Nothing alist } +| PART_REFS + { let alist = fromReverseList $1 + in CommonGroup () (getSpan alist) Nothing alist } + +EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] } +: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')' + { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 } +| '(' PART_REFS ')' + { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] } + +NAMELISTS :: { [ Namelist A0 ] } +: NAMELISTS NAMELIST { $2 : $1 } +| NAMELISTS ',2' NAMELIST { $3 : $1 } +| NAMELIST { [ $1 ] } + +NAMELIST :: { Namelist A0 } +: '/' VARIABLE '/' VARIABLES + { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 } + +MAYBE_VARIABLES :: { Maybe (AList Expression A0) } +: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing } + +VARIABLES :: { [ Expression A0 ] } +: VARIABLES ',' VARIABLE { $3 : $1 } +| VARIABLE { [ $1 ] } + +IMP_LISTS :: { [ ImpList A0 ] } +: IMP_LISTS ',' IMP_LIST { $3 : $1 } +| IMP_LIST { [ $1 ] } + +IMP_LIST :: { ImpList A0 } +: TYPE_SPEC '(2' IMP_ELEMENTS ')' + { ImpList () (getTransSpan $1 $4) $1 (aReverse $3) } + +IMP_ELEMENTS :: { AList ImpElement A0 } +: IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } +| IMP_ELEMENT { AList () (getSpan $1) [ $1 ] } + +IMP_ELEMENT :: { ImpElement A0 } +: id {% do + let (TId s id) = $1 + if length id /= 1 + then fail "Implicit argument must be a character." + else return $ ImpCharacter () s id + } +| id '-' id {% do + let (TId _ id1) = $1 + let (TId _ id2) = $3 + if length id1 /= 1 || length id2 /= 1 + then fail "Implicit argument must be a character." + else return $ ImpRange () (getTransSpan $1 $3) id1 id2 + } + +PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] } +: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 } +| PARAMETER_ASSIGNMENT { [ $1 ] } + +PARAMETER_ASSIGNMENT :: { Declarator A0 } +: VARIABLE '=' EXPRESSION + { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) } + +DECLARATION_STATEMENT :: { Statement A0 } +: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST + { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2; + declAList = fromReverseList $4 } + in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList } +| TYPE_SPEC DECLARATOR_LIST + { let { declAList = fromReverseList $2 } + in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList } + +ATTRIBUTE_LIST :: { [ Attribute A0 ] } +: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 } +| {- EMPTY -} { [ ] } + +ATTRIBUTE_SPEC :: { Attribute A0 } +: public { AttrPublic () (getSpan $1) } +| private { AttrPrivate () (getSpan $1) } +| allocatable { AttrAllocatable () (getSpan $1) } +| dimension '(' DIMENSION_DECLARATORS ')' + { AttrDimension () (getTransSpan $1 $4) $3 } +| external { AttrExternal () (getSpan $1) } +| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 } +| intrinsic { AttrIntrinsic () (getSpan $1) } +| optional { AttrOptional () (getSpan $1) } +| pointer { AttrPointer () (getSpan $1) } +| parameter { AttrParameter () (getSpan $1) } +| save { AttrSave () (getSpan $1) } +| target { AttrTarget () (getSpan $1) } + +INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut } + +DATA_GROUPS :: { [ DataGroup A0 ] } +: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash + { let { nameAList = fromReverseList $3; + dataAList = fromReverseList $5 } + in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 } +| DATA_LIST slash EXPRESSION_LIST slash + { let { nameAList = fromReverseList $1; + dataAList = fromReverseList $3 } + in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] } + +MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () } + +DATA_LIST :: { [ Expression A0 ] } +: DATA_LIST ',' DATA_ELEMENT { $3 : $1 } +| DATA_ELEMENT { [ $1 ] } + +DATA_ELEMENT :: { Expression A0 } +: DATA_REF { $1 } | IMPLIED_DO { $1 } + +SAVE_ARGS :: { [ Expression A0 ] } +: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] } + +SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 } + +COMMON_NAME :: { Expression A0 } +: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 } + +DECLARATOR_LIST :: { [ Declarator A0 ] } +: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 } +| INITIALISED_DECLARATOR { [ $1 ] } + +INITIALISED_DECLARATOR :: { Declarator A0 } +: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 } +| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 } +| DECLARATOR { $1 } + +DECLARATOR :: { Declarator A0 } +: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing } +| VARIABLE '*' EXPRESSION + { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing } +| VARIABLE '*' '(' '*' ')' + { let star = ExpValue () (getSpan $4) ValStar + in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' + { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION + { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing } +| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')' + { let star = ExpValue () (getSpan $7) ValStar + in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing } + +DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } +: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR + { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } +| DIMENSION_DECLARATOR + { AList () (getSpan $1) [ $1 ] } + +DIMENSION_DECLARATOR :: { DimensionDeclarator A0 } +: EXPRESSION ':' EXPRESSION + { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) } +| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) } +-- Lower bound only +| EXPRESSION ':' + { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing } +| EXPRESSION ':' '*' + { let { span = getSpan $3; + star = ExpValue () span ValStar } + in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) } +| '*' + { let { span = getSpan $1; + star = ExpValue () span ValStar } + in DimensionDeclarator () span Nothing (Just star) } +| ':' + { let span = getSpan $1 + in DimensionDeclarator () span Nothing Nothing } + +TYPE_SPEC :: { TypeSpec A0 } +: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 } +| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 } +| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing } +| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } +| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } +| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } +| type '(' id ')' + { let TId _ id = $3 + in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing } + +KIND_SELECTOR :: { Maybe (Selector A0) } +: '(' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) } +| '(' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) } +| {- EMPTY -} { Nothing } + +CHAR_SELECTOR :: { Maybe (Selector A0) } +: '*' EXPRESSION + { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing } +-- The following rule is a bug in the spec. +-- | '*' EXPRESSION ',' +-- { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing } +| '*' '(' '*' ')' + { let star = ExpValue () (getSpan $3) ValStar + in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing } +| '(' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing } +| '(' len '=' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing } +| '(' LEN_EXPRESSION ',' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) } +| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) } +| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) } +| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')' + { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) } +| {- EMPTY -} { Nothing } + +LEN_EXPRESSION :: { Expression A0 } +: EXPRESSION { $1 } +| '*' { ExpValue () (getSpan $1) ValStar } + +EXPRESSION :: { Expression A0 } +: EXPRESSION '+' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 } +| EXPRESSION '-' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 } +| EXPRESSION '*' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } +| EXPRESSION '/' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Division $1 $3 } +| EXPRESSION '**' EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 } +| EXPRESSION '/' '/' EXPRESSION %prec CONCAT + { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 } +| ARITHMETIC_SIGN EXPRESSION %prec SIGN + { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } +| EXPRESSION or EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Or $1 $3 } +| EXPRESSION and EXPRESSION + { ExpBinary () (getTransSpan $1 $3) And $1 $3 } +| not EXPRESSION + { ExpUnary () (getTransSpan $1 $2) Not $2 } +| EXPRESSION eqv EXPRESSION + { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 } +| EXPRESSION neqv EXPRESSION + { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 } +| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL + { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 } +| opCustom EXPRESSION %prec DEFINED_UNARY + { let TOpCustom span str = $1 + in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 } +| EXPRESSION opCustom EXPRESSION + { let TOpCustom _ str = $2 + in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 } +| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 } +| NUMERIC_LITERAL { $1 } +| '(' EXPRESSION ',' EXPRESSION ')' + { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) } +| LOGICAL_LITERAL { $1 } +| STRING { $1 } +| DATA_REF { $1 } +| IMPLIED_DO { $1 } +| '(/' EXPRESSION_LIST '/)' + { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) } +| operator '(' opCustom ')' + { let TOpCustom _ op = $3 + in ExpValue () (getTransSpan $1 $4) (ValOperator op) } +| assignment { ExpValue () (getSpan $1) ValAssignment } +| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 } + +DATA_REFS :: { [ Expression A0 ] } +: DATA_REFS ',' DATA_REF { $3 : $1 } +| DATA_REF { [ $1 ] } + +DATA_REF :: { Expression A0 } +: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 } +| PART_REF { $1 } + +PART_REFS :: { [ Expression A0 ] } +: PART_REFS ',' PART_REF { $3 : $1 } +| PART_REF { [ $1 ] } + +PART_REF :: { Expression A0 } +: VARIABLE { $1 } +| VARIABLE '(' ')' + { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing } +| VARIABLE '(' INDICIES ')' + { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) } +| VARIABLE '(' INDICIES ')' '(' INDICIES ')' + { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) + in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) } + +INDICIES :: { [ Index A0 ] } +: INDICIES ',' INDEX { $3 : $1 } +| INDEX { [ $1 ] } + +INDEX :: { Index A0 } +: RANGE { $1 } +| RANGE ':' EXPRESSION + { let IxRange () s lower upper _ = $1 + in IxRange () (getTransSpan s $3) lower upper (Just $3) } +| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 } +-- Following is only as an intermediate stage before having been turned into +-- an argument by later transformation. +| id '=' EXPRESSION + { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 } + +RANGE :: { Index A0 } +: ':' { IxRange () (getSpan $1) Nothing Nothing Nothing } +| ':' EXPRESSION { IxRange () (getTransSpan $1 $2) Nothing (Just $2) Nothing } +| EXPRESSION ':' { IxRange () (getTransSpan $1 $2) (Just $1) Nothing Nothing } +| EXPRESSION ':' EXPRESSION + { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing } + +DO_SPECIFICATION :: { DoSpecification A0 } +: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) } +| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing } + +IMPLIED_DO :: { Expression A0 } +: '(' EXPRESSION ',' DO_SPECIFICATION ')' + { let expList = AList () (getSpan $2) [ $2 ] + in ExpImpliedDo () (getTransSpan $1 $5) expList $4 } +| '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')' + { let expList = AList () (getTransSpan $2 $4) [ $2, $4 ] + in ExpImpliedDo () (getTransSpan $1 $5) expList $6 } +| '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')' + { let { exps = reverse $6; + expList = AList () (getTransSpan $2 exps) ($2 : $4 : reverse $6) } + in ExpImpliedDo () (getTransSpan $1 $9) expList $8 } + +FORALL :: { Statement A0 } +: id ':' forall FORALL_HEADER { + let (TId s1 id) = $1 in + let (h,s2) = $4 in + StForall () (getTransSpan s1 s2) (Just id) h +} +| forall FORALL_HEADER { + let (h,s) = $2 in + StForall () (getTransSpan $1 s) Nothing h +} +| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT { + let (h,_) = $2 in + StForallStatement () (getTransSpan $1 $3) h $3 +} + +FORALL_HEADER + :: { (ForallHeader A0, SrcSpan) } +FORALL_HEADER : + -- Standard simple forall header + '(' FORALL_TRIPLET_SPEC ')' { (ForallHeader [$2] Nothing, getTransSpan $1 $3) } + -- forall header with scale expression + | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')' + { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) } + -- multi forall header + | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')' + { (ForallHeader $2 Nothing, getTransSpan $1 $3) } + -- multi forall header with scale + | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')' + { (ForallHeader $2 (Just $4), getTransSpan $1 $5) } + +FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE + :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] } +FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE +: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 } +| {- empty -} { [] } + +FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) } +FORALL_TRIPLET_SPEC +: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) } +| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) } + +FORALL_ASSIGNMENT_STMT :: { Statement A0 } +FORALL_ASSIGNMENT_STMT : + EXPRESSION_ASSIGNMENT_STATEMENT { $1 } + | POINTER_ASSIGNMENT_STMT { $1 } + +POINTER_ASSIGNMENT_STMT :: { Statement A0 } +POINTER_ASSIGNMENT_STMT : + DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 } + +END_FORALL :: { Statement A0 } +END_FORALL : + endforall { StEndForall () (getSpan $1) Nothing } + | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)} + +EXPRESSION_LIST :: { [ Expression A0 ] } +: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 } +| EXPRESSION { [ $1 ] } + +ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) } +: '-' { (getSpan $1, Minus) } +| '+' { (getSpan $1, Plus) } + +RELATIONAL_OPERATOR :: { BinaryOp } +: '==' { EQ } +| '!=' { NE } +| '>' { GT } +| '>=' { GTE } +| '<' { LT } +| '<=' { LTE } + +VARIABLE :: { Expression A0 } +: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s } + +NUMERIC_LITERAL :: { Expression A0 } +: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 } + +INTEGERS :: { [ Expression A0 ] } +: INTEGERS ',' INTEGER_LITERAL { $3 : $1 } +| INTEGER_LITERAL { [ $1 ] } + +INTEGER_LITERAL :: { Expression A0 } +: int { let TIntegerLiteral s i = $1 in ExpValue () s $ ValInteger i } +| boz { let TBozLiteral s i = $1 in ExpValue () s $ ValInteger i } + +REAL_LITERAL :: { Expression A0 } +: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r } + +LOGICAL_LITERAL :: { Expression A0 } +: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b } + +STRING :: { Expression A0 } +: string { let TString s c = $1 in ExpValue () s $ ValString c } + +cDATA :: { () } : {% pushContext ConData } +cIMPLICIT :: { () } : {% pushContext ConImplicit } +cNAMELIST :: { () } : {% pushContext ConNamelist } +cCOMMON :: { () } : {% pushContext ConCommon } +cPOP :: { () } : {% popContext } + +{ + +unitNameCheck :: Token -> String -> Parse AlexInput Token () +unitNameCheck (TId _ name1) name2 + | name1 == name2 = return () + | otherwise = fail "Unit name does not match the corresponding END statement." +unitNameCheck _ _ = return () + +parse = runParse programParser + +transformations95 = + [ GroupLabeledDo + , GroupDo + , GroupIf + , GroupCase + , DisambiguateIntrinsic + , DisambiguateFunction + ] + +fortran95Parser :: + B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +fortran95Parser sourceCode filename = + (pfSetFilename filename . transform transformations95) <$> parse parseState + where + parseState = initParseState sourceCode Fortran95 filename + +fortran95ParserWithModFiles :: + ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0) +fortran95ParserWithModFiles mods sourceCode filename = + fmap (pfSetFilename filename . transform) $ parse parseState + where + transform = transformWithModFiles mods transformations95 + parseState = initParseState sourceCode Fortran95 filename + +parseError :: Token -> LexAction a +parseError token = do + parseState <- get +#ifdef DEBUG + tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex +#endif + fail $ psFilename parseState ++ ": parsing failed. " + ++ specifics token +#ifdef DEBUG + ++ '\n' : show tokens +#endif + where specifics (TPause _) = "\nPAUSE statements are not supported in Fortran 95 or later. " + specifics (TAssign _) = "\nASSIGN statements are not supported in Fortran 95 or later. " + specifics _ = "" + +} 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 @@ -26,7 +26,9 @@ data FortranVersion = Fortran66 | Fortran77 | Fortran77Extended + | Fortran77Legacy | Fortran90 + | Fortran95 | Fortran2003 | Fortran2008 deriving (Ord, Eq, Data, Typeable, Generic) @@ -35,7 +37,9 @@ show Fortran66 = "Fortran 66" show Fortran77 = "Fortran 77" show Fortran77Extended = "Fortran 77 Extended" + show Fortran77Legacy = "Fortran 77 Legacy" show Fortran90 = "Fortran 90" + show Fortran95 = "Fortran 95" show Fortran2003 = "Fortran 2003" show Fortran2008 = "Fortran 2008" 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 @@ -8,7 +8,7 @@ import Data.Maybe (isJust, isNothing) import Data.List (foldl') -import Prelude hiding (EQ,LT,GT) +import Prelude hiding (EQ,LT,GT,(<>)) import Language.Fortran.AST import Language.Fortran.ParserMonad @@ -108,12 +108,18 @@ where nextI = incIndentation i - pprint v (PUSubroutine _ _ isRec name mArgs body mSubs) i - | isRec, v < Fortran90 = tooOld v "Recursive subroutine" Fortran90 + pprint v (PUSubroutine _ _ funcSpec name mArgs body mSubs) i + | Pure _ _ _ <- funcSpec, v < Fortran95 = tooOld v "Pure subroutine" Fortran90 + | Elemental _ _ <- funcSpec, v < Fortran90 = tooOld v "Elemental subroutine" Fortran90 + | functionIsRecursive funcSpec, v < Fortran90 = tooOld v "Recursive subroutine" Fortran90 | isJust mSubs, v < Fortran90 = tooOld v "Subroutine subprogram" Fortran90 | otherwise = indent curI - ((if isRec then "recursive" else empty) <+> + ((case funcSpec of + (Elemental _ _) -> "elemental" + (Pure _ _ _) -> "pure" + otherwise -> empty) <+> + (if functionIsRecursive funcSpec then "recursive" else empty) <+> "subroutine" <+> text name <> lparen pprint' v mArgs rparen <> newline) <> pprint v body nextI <> @@ -128,14 +134,20 @@ then incIndentation i else incIndentation fixedForm - pprint v (PUFunction _ _ mRetType isRec name mArgs mRes body mSubs) i - | isRec, v < Fortran90 = tooOld v "Recursive function" Fortran90 + pprint v (PUFunction _ _ mRetType fSpec name mArgs mRes body mSubs) i + | (Elemental _ _) <- fSpec, v < Fortran95 = tooOld v "Elemental function" Fortran90 + | (Pure _ _ _) <- fSpec, v < Fortran95 = tooOld v "Pure function" Fortran90 + | functionIsRecursive fSpec, v < Fortran90 = tooOld v "Recursive function" Fortran90 | isJust mRes, v < Fortran90 = tooOld v "Function result" Fortran90 | isJust mSubs, v < Fortran90 = tooOld v "Function subprogram" Fortran90 | otherwise = indent curI (pprint' v mRetType <+> - (if isRec then "recursive" else empty) <+> + (case fSpec of + (Elemental _ _) -> "elemental" + (Pure _ _ _) -> "pure" + otherwise -> empty) <+> + (if functionIsRecursive fSpec then "recursive" else empty) <+> "function" <+> text name <> lparen pprint' v mArgs rparen <+> "result" lparen pprint' v mRes rparen <> newline) <> @@ -262,13 +274,15 @@ then indent i (pprint' v label <+> stDoc) else pprint' v mLabel `overlay` indent i stDoc - pprint v (BlDoWhile _ _ mLabel mName cond body el) i + pprint v (BlDoWhile _ _ mLabel mName mTarget cond body el) i | v >= Fortran77Extended = labeledIndent mLabel (pprint' v mName colon <+> - "do while" <+> parens (pprint' v cond) <> newline) <> + "do" <+> pprint' v mTarget <+> "while" <+> parens (pprint' v cond) <> newline) <> pprint v body nextI <> - labeledIndent el ("end do" <+> pprint' v mName <> newline) + if isJust mTarget && isNothing mName + then empty + else labeledIndent el ("end do" <+> pprint' v mName <> newline) | otherwise = tooOld v "Do while loop" Fortran77Extended where nextI = incIndentation i @@ -308,7 +322,11 @@ | otherwise = tooOld v "Character data type" Fortran77 pprint' v (TypeCustom str) | v >= Fortran90 = "type" <+> parens (text str) + | v >= Fortran77Extended = "record" <+> char '/' <> text str <> char '/' | otherwise = tooOld v "User defined type" Fortran90 + pprint' v TypeByte + | v >= Fortran77Extended = "byte" + | otherwise = tooOld v "Byte" Fortran77Extended instance Pretty (TypeSpec a) where pprint' v (TypeSpec _ _ baseType mSelector) = @@ -348,6 +366,13 @@ text "::" <+> pprint' v declList + pprint' v st@(StStructure _ _ mName itemList) + | v /= Fortran77Extended = tooOld v "Structure" Fortran77Extended + | otherwise = + "structure" <> (if isJust mName then " /" <> pprint' v mName <> "/" else empty) <> newline <> + foldl' (\doc item -> doc <> pprint v item (incIndentation (Just 0)) <> newline) empty (aStrip itemList) <> + "end structure" + pprint' v (StIntent _ _ intent exps) | v >= Fortran90 = "intent" <+> parens (pprint' v intent) <+> "::" <+> pprint' v exps @@ -389,6 +414,10 @@ | v >= Fortran90 = "data" <+> pprint' v aDataGroups | otherwise = "data" <+> hsep (map (pprint' v) dataGroups) + pprint' v (StAutomatic _ _ decls) + | v == Fortran77Extended = "automatic" <+> pprint' v decls + | otherwise = tooOld v "Target statement" Fortran90 + pprint' v (StNamelist _ _ namelist) | v >= Fortran90 = "namelist" <+> pprint' v namelist | otherwise = tooOld v "Namelist statement" Fortran90 @@ -421,7 +450,7 @@ pprint' v name <+> parens (pprint' v mArgs) <+> "result (" pprint' v mResult char ')' - pprint' v (StInclude _ _ file) = "include" <+> pprint' v file + pprint' v (StInclude _ _ file _) = "include" <+> pprint' v file pprint' v (StDo _ s mConstructor mLabel mDoSpec) | v < Fortran90 @@ -555,6 +584,10 @@ "write" <+> parens (pprint' v cilist) <+> pprint' v mIolist pprint' v (StPrint _ _ formatId mIolist) = "print" <+> pprint' v formatId <> comma pprint' v mIolist + pprint' v (StTypePrint _ _ formatId mIolist) + | v == Fortran77Extended + = "type" <+> pprint' v formatId <> comma pprint' v mIolist + | otherwise = tooOld v "Type (print) statement" Fortran77Extended pprint' v (StOpen _ _ cilist) = "open" <+> parens (pprint' v cilist) pprint' v (StClose _ _ cilist) = "close" <+> parens (pprint' v cilist) @@ -769,6 +802,20 @@ pprint' v (ValString str) = quotes $ text str pprint' v valLit = text . getFirstParameter $ valLit +instance IndentablePretty (StructureItem a) where + pprint v (StructFields a s spec mAttrs decls) i = pprint' v (StDeclaration a s spec mAttrs decls) + pprint v (StructUnion _ _ maps) i = + "union" <> newline <> + foldl' (\doc item -> doc <> pprint v item (incIndentation i) <> newline) empty (aStrip maps) <> + "end union" + pprint v (StructStructure a s mName items) i = pprint' v (StStructure a s mName items) + +instance IndentablePretty (UnionMap a) where + pprint v (UnionMap _ _ items) i = + "map" <> newline <> + foldl' (\doc item -> doc <> pprint v item (incIndentation i) <> newline) empty (aStrip items) <> + "end map" + instance Pretty (Declarator a) where pprint' v (DeclVariable _ _ e mLen mInit) | v >= Fortran90 = @@ -835,6 +882,7 @@ pprint' v EQ = if v <= Fortran77Extended then ".eq." else "==" pprint' v NE = if v <= Fortran77Extended then ".ne." else "/=" pprint' v Or = ".or." + pprint' v XOr = ".xor." pprint' v And = ".and." pprint' v Equivalent | v >= Fortran77 = ".eqv." 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 @@ -33,6 +33,9 @@ expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies) | Just (IDType _ (Just CTFunction)) <- idType a , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies) + expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies) + | Just (IDType _ (Just CTExternal)) <- idType a + , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies) expression e@(ExpSubscript a1 s v@(ExpValue a _ (ValIntrinsic _)) indicies) | Just (IDType _ (Just CTIntrinsic)) <- idType a , indiciesRangeFree indicies = ExpFunctionCall a1 s v (Just $ aMap fromIndex indicies) 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 @@ -1,38 +1,71 @@ -module Language.Fortran.Transformation.Grouping ( groupIf +module Language.Fortran.Transformation.Grouping ( groupForall + , groupIf , groupDo , groupLabeledDo , groupCase ) where import Language.Fortran.AST +import Language.Fortran.Util.Position import Language.Fortran.Analysis import Language.Fortran.Transformation.TransformMonad +import Data.Data +import Data.Generics.Uniplate.Operations -genericGroup :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Transform a () +type ABlocks a = [ Block (Analysis a) ] + +genericGroup :: Data a => (ABlocks a -> ABlocks a) -> Transform a () genericGroup groupingFunction = - modifyProgramFile $ - \(ProgramFile mi pus) -> - ProgramFile mi (map go pus) + modifyProgramFile $ transformBi groupingFunction + +-------------------------------------------------------------------------------- +-- Grouping FORALL statement blocks into FORALL blocks in entire parse tree +-------------------------------------------------------------------------------- +groupForall :: Data a => Transform a () +groupForall = genericGroup groupForall' + + +groupForall' :: ABlocks a -> ABlocks a +groupForall' [] = [] +groupForall' (b:bs) = b' : bs' where - go pu = - case pu of - PUMain a s n bs subPUs -> - PUMain a s n (groupingFunction bs) (map go <$> subPUs) - PUModule a s n bs subPUs -> - PUModule a s n (groupingFunction bs) (map go <$> subPUs) - PUSubroutine a s r n as bs subPUs -> - PUSubroutine a s r n as (groupingFunction bs) (map go <$> subPUs) - PUFunction a s r rec n as res bs subPUs -> - PUFunction a s r rec n as res (groupingFunction bs) (map go <$> subPUs) - bd@PUBlockData {} -> bd -- Block data cannot have any if statements. - c@PUComment {} -> c + (b', bs') = case b of + BlStatement a s label st + | StForall _ _ mTarget header <- st -> + let ( blocks, leftOverBlocks, endLabel ) = + collectNonForallBlocks groupedBlocks mTarget + in ( BlForall a (getTransSpan s blocks) label mTarget header blocks endLabel + , leftOverBlocks) + | StForallStatement _ _ header st' <- st -> + let block = BlStatement a (getSpan st') Nothing st' in + ( BlForall a (getTransSpan s st') label Nothing header [block] Nothing, groupedBlocks ) + b | containsGroups b -> + ( applyGroupingToSubblocks groupForall' b, groupedBlocks ) + _ -> (b, groupedBlocks) + groupedBlocks = groupForall' bs +collectNonForallBlocks :: ABlocks a -> Maybe String + -> ( ABlocks a + , ABlocks a + , Maybe (Expression (Analysis a)) ) +collectNonForallBlocks blocks mNameTarget = + case blocks of + b@(BlStatement _ _ mLabel (StEndForall _ _ mName)):rest + | mName == mNameTarget -> ([], rest, mLabel) + | otherwise -> + error "Forall block name does not match that of the end statement." + b:bs -> + let (bs', rest, mLabel) = collectNonForallBlocks bs mNameTarget + in (b : bs', rest, mLabel) + _ -> error "Premature file ending while parsing structured forall block." + + -------------------------------------------------------------------------------- -- Grouping if statement blocks into if blocks in entire parse tree -------------------------------------------------------------------------------- -groupIf :: Transform a () +groupIf :: Data a => Transform a () groupIf = genericGroup groupIf' -- Actual grouping is done here. @@ -44,9 +77,9 @@ -- structured if block. -- 1.5 Prepend the block to the left over artefacts, which have already been -- grouped in 1.1 --- 2. Case: head is a statement block contianing any other statement: +-- 2. Case: head is a statement block containing any other statement: -- 2.1 Group everything to the right and prepend the head. -groupIf' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ] +groupIf' :: ABlocks a -> ABlocks a groupIf' [] = [] groupIf' (b:bs) = b' : bs' where @@ -82,10 +115,10 @@ -- In that case it decomposes the block into list of (maybe) conditions and -- blocks that those conditions correspond to. Additionally, it returns -- whatever is after the if block. -decomposeIf :: [ Block (Analysis a) ] +decomposeIf :: ABlocks a -> ( [ Maybe (Expression (Analysis a)) ], - [ [ Block (Analysis a) ] ], - [ Block (Analysis a) ], + [ ABlocks a ], + ABlocks a, Maybe (Expression (Analysis a)) ) decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):rest) = decomposeIf' blocks @@ -109,7 +142,7 @@ , endLabel ) -- This compiles the executable blocks under various if conditions. -collectNonConditionalBlocks :: [ Block (Analysis a) ] -> ([ Block (Analysis a) ], [ Block (Analysis a) ]) +collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a) collectNonConditionalBlocks blocks = case blocks of BlStatement _ _ _ StElsif{}:_ -> ([], blocks) @@ -129,20 +162,20 @@ -- Grouping new do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- -groupDo :: Transform a () +groupDo :: Data a => Transform a () groupDo = genericGroup groupDo' -groupDo' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ] +groupDo' :: ABlocks a -> ABlocks a groupDo' [ ] = [ ] groupDo' blocks@(b:bs) = b' : bs' where (b', bs') = case b of BlStatement a s label st -- Do While statement - | StDoWhile _ _ mTarget _ condition <- st -> + | StDoWhile _ _ mTarget Nothing condition <- st -> let ( blocks, leftOverBlocks, endLabel ) = collectNonDoBlocks groupedBlocks mTarget - in ( BlDoWhile a (getTransSpan s blocks) label mTarget condition blocks endLabel + in ( BlDoWhile a (getTransSpan s blocks) label mTarget Nothing condition blocks endLabel , leftOverBlocks) -- Vanilla do statement | StDo _ _ mName Nothing doSpec <- st -> @@ -155,9 +188,9 @@ _ -> ( b, groupedBlocks ) groupedBlocks = groupDo' bs -- Assume everything to the right is grouped. -collectNonDoBlocks :: [ Block (Analysis a) ] -> Maybe String - -> ( [ Block (Analysis a)] - , [ Block (Analysis a) ] +collectNonDoBlocks :: ABlocks a -> Maybe String + -> ( ABlocks a + , ABlocks a , Maybe (Expression (Analysis a)) ) collectNonDoBlocks blocks mNameTarget = case blocks of @@ -174,10 +207,10 @@ -- Grouping labeled do statement blocks into do blocks in entire parse tree -------------------------------------------------------------------------------- -groupLabeledDo :: Transform a () +groupLabeledDo :: Data a => Transform a () groupLabeledDo = genericGroup groupLabeledDo' -groupLabeledDo' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ] +groupLabeledDo' :: ABlocks a -> ABlocks a groupLabeledDo' [ ] = [ ] groupLabeledDo' blos@(b:bs) = b' : bs' where @@ -189,6 +222,13 @@ lastLabel = getLastLabel $ last blocks in ( BlDo a (getTransSpan s blocks) label mn tl doSpec blocks lastLabel , leftOverBlocks ) + BlStatement a s label + (StDoWhile _ _ mn tl@Just{} cond) -> + let ( blocks, leftOverBlocks ) = + collectNonLabeledDoBlocks tl groupedBlocks + lastLabel = getLastLabel $ last blocks + in ( BlDoWhile a (getTransSpan s blocks) label mn tl cond blocks lastLabel + , leftOverBlocks ) b | containsGroups b -> ( applyGroupingToSubblocks groupLabeledDo' b, groupedBlocks ) _ -> (b, groupedBlocks) @@ -197,8 +237,8 @@ groupedBlocks = groupLabeledDo' bs -collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> [ Block (Analysis a) ] - -> ([ Block (Analysis a) ], [ Block (Analysis a) ]) +collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> ABlocks a + -> (ABlocks a, ABlocks a) collectNonLabeledDoBlocks targetLabel blocks = case blocks of -- Didn't find a statement with matching label; don't group @@ -212,17 +252,20 @@ compLabel :: Maybe (Expression a) -> Maybe (Expression a) -> Bool compLabel (Just (ExpValue _ _ (ValInteger l1))) - (Just (ExpValue _ _ (ValInteger l2))) = l1 == l2 + (Just (ExpValue _ _ (ValInteger l2))) = strip l1 == strip l2 compLabel _ _ = False +strip :: String -> String +strip = dropWhile (=='0') + -------------------------------------------------------------------------------- -- Grouping case statements -------------------------------------------------------------------------------- -groupCase :: Transform a () +groupCase :: Data a => Transform a () groupCase = genericGroup groupCase' -groupCase' :: [ Block (Analysis a) ] -> [ Block (Analysis a) ] +groupCase' :: ABlocks a -> ABlocks a groupCase' [] = [] groupCase' (b:bs) = b' : bs' where @@ -239,10 +282,10 @@ groupedBlocks = groupCase' bs -- Assume everything to the right is grouped. isComment b = case b of { BlComment{} -> True; _ -> False } -decomposeCase :: [ Block (Analysis a) ] -> Maybe String +decomposeCase :: ABlocks a -> Maybe String -> ( [ Maybe (AList Index (Analysis a)) ] - , [ [ Block (Analysis a) ] ] - , [ Block (Analysis a) ] + , [ ABlocks a ] + , ABlocks a , Maybe (Expression (Analysis a)) ) decomposeCase blocks@(BlStatement _ _ mLabel st:rest) mTargetName = case st of @@ -265,7 +308,7 @@ , rest', endLabel ) -- This compiles the executable blocks under various if conditions. -collectNonCaseBlocks :: [ Block (Analysis a) ] -> ([ Block (Analysis a) ], [ Block (Analysis a) ]) +collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a) collectNonCaseBlocks blocks = case blocks of b@(BlStatement _ _ _ st):_ @@ -290,7 +333,7 @@ BlInterface{} -> False BlComment{} -> False -applyGroupingToSubblocks :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Block (Analysis a) -> Block (Analysis a) +applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a) applyGroupingToSubblocks f b | BlStatement{} <- b = error "Individual statements do not have subblocks. Must not occur." @@ -298,7 +341,7 @@ | BlCase a s l mn scrutinee conds blocks el <- b = BlCase a s l mn scrutinee conds (map f blocks) el | BlDo a s l n tl doSpec blocks el <- b = BlDo a s l n tl doSpec (f blocks) el - | BlDoWhile a s l n doSpec blocks el <- b = BlDoWhile a s l n doSpec (f blocks) el + | BlDoWhile a s l n tl doSpec blocks el <- b = BlDoWhile a s l n tl doSpec (f blocks) el | BlInterface{} <- b = error "Interface blocks do not have groupable subblocks. Must not occur." | BlComment{} <- b = diff --git a/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs --- a/src/Language/Fortran/Transformer.hs +++ b/src/Language/Fortran/Transformer.hs @@ -13,7 +13,8 @@ import Language.Fortran.AST (ProgramFile) data Transformation = - GroupIf + GroupForall + | GroupIf | GroupCase | GroupDo | GroupLabeledDo @@ -23,7 +24,8 @@ transformationMapping :: Data a => [ (Transformation, Transform a ()) ] transformationMapping = - [ (GroupIf, groupIf) + [ (GroupForall, groupForall) + , (GroupIf, groupIf) , (GroupCase, groupCase) , (GroupDo, groupDo) , (GroupLabeledDo, groupLabeledDo) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -8,6 +8,7 @@ import Data.Text.Encoding.Error (replace) import Text.PrettyPrint (render) +import Text.Read import System.Console.GetOpt @@ -84,7 +85,7 @@ sgr = genSuperBBGr bbm case actionOpt of - Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended ] -> + Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended, Fortran77Legacy ] -> print $ FixedForm.collectFixedTokens version contents Lex | version `elem` [Fortran90, Fortran2003, Fortran2008] -> print $ FreeForm.collectFreeTokens version contents @@ -100,14 +101,17 @@ -- List files in dir rGetDirContents :: String -> IO [String] -rGetDirContents d = do +rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d' + where + go seen d = do ds <- getDirectoryContents d fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries where f x = do - g <- doesDirectoryExist (d ++ "/" ++ x) - if g then do - x' <- rGetDirContents (d ++ "/" ++ x) + path <- canonicalizePath $ d ++ "/" ++ x + g <- doesDirectoryExist path + if g && not (path `elem` seen) then do + x' <- go (path : seen) path return $ map (\ y -> x ++ "/" ++ y) x' else return [x] @@ -208,8 +212,8 @@ options = [ Option ['v'] ["fortranVersion"] - (ReqArg (\v opts -> opts { fortranVersion = Just $ read v }) "VERSION") - "Fortran version to use, format: Fortran[66/77/77Extended/90]" + (ReqArg (\v opts -> opts { fortranVersion = readMaybe v }) "VERSION") + "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]" , Option ['a'] ["action"] (ReqArg (\a opts -> opts { action = read a }) "ACTION") @@ -257,18 +261,21 @@ header = "Usage: forpar [OPTION...] " instance Read FortranVersion where - readsPrec _ value = - let options = [ ("66", Fortran66) - , ("77e", Fortran77Extended) - , ("77", Fortran77) - , ("90", Fortran90) - , ("03", Fortran2003) - , ("08", Fortran2008)] in - tryTypes options - where - tryTypes [] = [] - tryTypes ((attempt,result):xs) = - if attempt `isInfixOf` value then [(result, "")] else tryTypes xs + readsPrec _ value = tryTypes options + where + value' = map toLower value + options = [ ("66" , Fortran66) + , ("77e", Fortran77Extended) + , ("77l", Fortran77Legacy) + , ("77" , Fortran77) + , ("90" , Fortran90) + , ("95" , Fortran95) + , ("03" , Fortran2003) + , ("08" , Fortran2008) ] + tryTypes [] = [] + tryTypes ((attempt,result):xs) + | attempt `isInfixOf` value' = [(result, "")] + | otherwise = tryTypes xs instance {-# OVERLAPPING #-} Show [ FixedForm.Token ] where show = unlines . lines' diff --git a/test/Language/Fortran/Analysis/BBlocksSpec.hs b/test/Language/Fortran/Analysis/BBlocksSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/BBlocksSpec.hs @@ -0,0 +1,134 @@ +module Language.Fortran.Analysis.BBlocksSpec where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Parser.Fortran77 +import Language.Fortran.Lexer.FixedForm (initParseState) +import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.AST +import Language.Fortran.Analysis +import Language.Fortran.Analysis.BBlocks +import Language.Fortran.Analysis.Renaming +import qualified Data.Map as M +import qualified Data.IntSet as IS +import Data.Graph.Inductive +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Maybe +import qualified Data.ByteString.Char8 as B + +pParser :: String -> ProgramFile (Analysis ()) +pParser source = rename . analyseBBlocks . analyseRenames . initAnalysis . fromParseResultUnsafe + $ extended77Parser (B.pack source) "" + +spec :: Spec +spec = + describe "Basic Blocks" $ do + describe "loop4" $ do + it "nodes and edges length" $ do + let pf = pParser programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let ns = nodes gr + let es = edges gr + (length ns, length es) `shouldBe` (11, 12) + it "branching nodes" $ do + let pf = pParser programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20])) `shouldBe` (2, 2) + it "all reachable" $ do + let pf = pParser programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let reached = IS.fromList $ dfs [0] gr + let nodeSet = IS.fromList $ nodes gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let pf = pParser programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let reached = IS.fromList $ rdfs [-1] gr + let nodeSet = IS.fromList $ nodes gr + reached `shouldBe` nodeSet + describe "if arith" $ do + it "nodes and edges length" $ do + let pf = pParser programArithIf + let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf + let ns = nodes gr + let es = edges gr + (length ns, length es) `shouldBe` (6, 7) + it "branching nodes" $ do + let pf = pParser programArithIf + let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf + (IS.size (findSuccsBB gr [10]), IS.size (findSuccsBB gr [20]), IS.size (findSuccsBB gr [30])) `shouldBe` (1, 1, 1) + it "all reachable" $ do + let pf = pParser programArithIf + let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf + let reached = IS.fromList $ dfs [0] gr + let nodeSet = IS.fromList $ nodes gr + reached `shouldBe` nodeSet + it "all terminate" $ do + let pf = pParser programArithIf + let gr = fromJust . M.lookup (Named "arithif") $ genBBlockMap pf + let reached = IS.fromList $ rdfs [-1] gr + let nodeSet = IS.fromList $ nodes gr + reached `shouldBe` nodeSet + +-------------------------------------------------- +-- Label-finding helper functions to help write tests that are +-- insensitive to minor changes to the AST. + +-- For each label in the list, find the corresponding basic block, +-- return as an IntSet. +findLabelsBB :: BBGr a -> [Int] -> IS.IntSet +findLabelsBB gr = IS.fromList . mapMaybe (flip findLabeledBBlock gr . show) + +findLabelBB :: BBGr a -> Int -> Node +findLabelBB gr = (error "findLabelBB" `fromMaybe`) . flip findLabeledBBlock gr . show + +-- For each label in the list, find the successors of the +-- corresponding basic block, return as an IntSet. +findSuccsBB :: BBGr a -> [Int] -> IS.IntSet +findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show) + +-------------------------------------------------- +-- Test programs + +programLoop4 = unlines [ + " program loop4" + , " integer r, i, j" + , "" + , " r = 0" + , "" + , "c outer loop" + , " i = 1" + , " 10 if (i .gt. 10) goto 40" + , "" + , "c inner loop" + , " j = 1" + , " 20 if (j .gt. 5) goto 30" + , " r = r + i * j" + , " j = j + 1" + , " goto 20" + , "c inner loop end" + , "" + , " 30 i = i + 1" + , " goto 10" + , "c outer loop end" + , "" + , " 40 write (*,*) r" + , " end" + ] + +programArithIf = unlines [ + " program arithif" + , " integer n" + , " n = 0" + , " if (n) 10, 20, 30" + , " 10 write (*,*) 10" + , " 20 write (*,*) 20" + , " 30 write (*,*) 30" + , " end"] + + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Analysis/DataFlowSpec.hs b/test/Language/Fortran/Analysis/DataFlowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/DataFlowSpec.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Fortran.Analysis.DataFlowSpec where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Parser.Fortran77 +import qualified Language.Fortran.Parser.Fortran90 as F90 +import Language.Fortran.Lexer.FixedForm (initParseState) +import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.AST +import Language.Fortran.Analysis +import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis.BBlocks +import Language.Fortran.Analysis.DataFlow +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Graph.Inductive +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Maybe +import Data.List +import Data.Data +import Data.Generics.Uniplate.Operations +import qualified Data.ByteString.Char8 as B + +data F77 = F77 +data F90 = F90 + +class Parser t where + parser :: t -> String -> String -> ProgramFile A0 +instance Parser F77 where + parser F77 src file = fromParseResultUnsafe $ extended77Parser (B.pack src) file +instance Parser F90 where + parser F90 src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file + +pParser :: Parser t => t -> String -> ProgramFile (Analysis ()) +pParser version source = rename . analyseBBlocks . analyseRenames . initAnalysis + . resetSrcSpan $ parser version source "" + +withParse :: Data a => Parser t => t -> String -> (ProgramFile (Analysis A0) -> a) -> a +withParse version source f = underRenaming (f . analyseBBlocks) (parser version source "") + +testGraph version f p = fromJust . M.lookup (Named f) . withParse version p $ genBBlockMap +testPfAndGraph version f p = fmap (fromJust . M.lookup (Named f)) . withParse version p $ \ pf -> (pf, genBBlockMap pf) + +testGenDefMap version = flip (withParse version) (genDefMap . genBlockMap . analyseBBlocks . initAnalysis) + +testBackEdges version f p = bedges + where + gr = testGraph version f p + domMap = dominators gr + bedges = genBackEdgeMap domMap gr + +spec :: Spec +spec = + describe "Dataflow" $ do + ---------------------------------------------- + let pf = pParser F77 programLoop4 + describe "loop4" $ do + it "genBackEdgeMap" $ do + let gr = testGraph F77 "loop4" programLoop4 + testBackEdges F77 "loop4" programLoop4 `shouldBe` + IM.fromList [(findLabelBB gr 8, findLabelBB gr 10), (findLabelBB gr 7, findLabelBB gr 20)] + + it "loopNodes" $ do + let pf = pParser F77 programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + S.fromList (loopNodes bedges gr) `shouldBe` + S.fromList [findLabelsBB gr [5,6,7,20], IS.unions [findLabelsBB gr [4,5,6,7,8,10,20,30], findSuccsBB gr [20]]] + + it "genDefMap" $ + testGenDefMap F77 programLoop4 `shouldBe` + M.fromList [("i",findLabelsBl pf [3,30]),("j",findLabelsBl pf [4,6]),("r",findLabelsBl pf [2,5])] + + it "reachingDefinitions" $ do + let pf = pParser F77 programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let bm = genBlockMap pf + let dm = genDefMap bm + IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe` + Just (findLabelsBl pf [2,3,4,5,6,30], findLabelsBl pf [3,4,5,6,30]) + + it "flowsTo" $ do + let pf = pParser F77 programLoop4 + let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf + let bm = genBlockMap pf + let dm = genDefMap bm + (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe` + -- Find the flows of the assignment statements in the program. + findLabelsBlEdges pf [(2,5),(2,40) -- r = 0 + ,(3,5),(3,10),(3,30) -- i = 1 + ,(4,5),(4,6),(4,20) -- j = 1 + ,(5,5),(5,40) -- r = r + i * j + ,(6,5),(6,6),(6,20) -- j = j + 1 + ,(30,5),(30,10),(30,30) -- i = i + 1 + ] + + ---------------------------------------------- + let pf = pParser F90 programLoop4Alt + let sgr = genSuperBBGr (genBBlockMap pf) + let gr = superBBGrGraph sgr + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + let bm = genBlockMap pf + let dm = genDefMap bm + + describe "loop4 alt (module)" $ do + it "genBackEdgeMap" $ do + let gr = testGraph F90 "loop4" programLoop4Alt + testBackEdges F90 "loop4" programLoop4Alt `shouldBe` + IM.fromList [(findLabelBB gr 22, findLabelBB gr 20), (findLabelBB gr 31, findLabelBB gr 10)] + + it "loopNodes" $ do + S.fromList (loopNodes bedges gr) `shouldBe` + S.fromList [findLabelsBB gr [20,21,22], findLabelsBB gr [10,11,20,21,22,31,40]] + + it "genDefMap" $ + testGenDefMap F90 programLoop4Alt `shouldBe` + M.fromList [("i",findLabelsBl pf [2,31]),("j",findLabelsBl pf [11,22]),("r",findLabelsBl pf [1,21])] + + it "reachingDefinitions" $ do + IM.lookup (findLabelBB gr 21) (reachingDefinitions dm gr) `shouldBe` + Just (findLabelsBl pf [1,2,11,21,22,31], findLabelsBl pf [2,11,21,22,31]) + + it "flowsTo" $ do + (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe` + -- Find the flows of the assignment statements in the program. + findLabelsBlEdges pf [(1,21),(1,41) -- r = 0 + ,(2,10),(2,21),(2,31) -- i = 1 + ,(11,20),(11,21),(11,22) -- j = 1 + ,(21,21),(21,41) -- r = r + i * j + ,(22,20),(22,21),(22,22) -- j = j + 1 + ,(31,10),(31,21),(31,31) -- i = i + 1 + ] + + ----------------------------------------------- + + describe "rd3" $ do + it "genBackEdgeMap" $ do + let gr = testGraph F77 "f" programRd3 + testBackEdges F77 "f" programRd3 `shouldBe` IM.singleton (findLabelBB gr 4) (findLabelBB gr 1) + + it "loopNodes" $ do + let (pf, gr) = testPfAndGraph F77 "f" programRd3 + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + S.fromList (loopNodes bedges gr) `shouldBe` + S.fromList [findLabelsBB gr [1,2,3,4]] + + it "reachingDefinitions" $ do + let (pf, gr) = testPfAndGraph F77 "f" programRd3 + let bm = genBlockMap pf + let dm = genDefMap bm + IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe` + Just (IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3]] + ,IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3,5]]) + + it "flowsTo" $ do + let (pf, gr) = testPfAndGraph F77 "f" programRd3 + let bm = genBlockMap pf + let dm = genDefMap bm + (S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldSatisfy` + -- Find the flows of the assignment statements in the program. + S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3) -- do 4 i = 2, 10 + ,(2,3) -- b(i) = a(i-1) + x + ,(3,2),(3,5) -- a(i) = b(i) + ]) + + describe "rd4" $ do + it "ivMapByASTBlock" $ do + let (pf, gr) = testPfAndGraph F77 "f" programRd4 + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + let ivMap = genInductionVarMapByASTBlock bedges gr + (sort . map (\ x -> (head x, length x)) . group . sort . map S.size $ IM.elems ivMap) `shouldBe` [(1,3),(2,3)] + + describe "bug36" $ do + let pf = pParser F90 programBug36 + let sgr = genSuperBBGr (genBBlockMap pf) + let gr = superBBGrGraph sgr + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + it "loopNodes" $ do + length (loopNodes bedges gr) `shouldBe` 2 + + describe "funcflow1" $ do + let pf = pParser F90 programFuncFlow1 + let sgr = genSuperBBGr (genBBlockMap pf) + let gr = superBBGrGraph sgr + let bm = genBlockMap pf + let dm = genDefMap bm + let rDefs = reachingDefinitions dm gr + let flTo = genFlowsToGraph bm dm gr rDefs + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + let diMap = genDerivedInductionMap bedges gr + it "flowsTo" $ do + (S.fromList . edges . trc $ flTo) `shouldSatisfy` + -- Find the flows of the assignment statements in the program. + S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)]) + + describe "funcflow2" $ do + let pf = pParser F90 programFuncFlow2 + let sgr = genSuperBBGr (genBBlockMap pf) + let gr = superBBGrGraph sgr + let bm = genBlockMap pf + let dm = genDefMap bm + let rDefs = reachingDefinitions dm gr + let flTo = genFlowsToGraph bm dm gr rDefs + let domMap = dominators gr + let bedges = genBackEdgeMap domMap gr + let diMap = genDerivedInductionMap bedges gr + let (iLabel, iName):_ = [ (fromJust (insLabel a), varName e) + | e@(ExpValue a _ (ValVariable _)) <- rhsExprs pf, srcName e == "i" ] + let (jLabel, jName):_ = [ (fromJust (insLabel a), varName e) + | e@(ExpValue a _ (ValVariable _)) <- lhsExprs pf, srcName e == "j" ] + it "flowsTo" $ do + (S.fromList . edges . trc $ flTo) `shouldSatisfy` + -- Find the flows of the assignment statements in the program. + S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)]) + it "derivedInduction" $ do + IM.lookup iLabel diMap `shouldBe` Just (IELinear iName 1 0) + IM.lookup jLabel diMap `shouldBe` Just (IELinear iName 6 2) + + describe "other" $ do + it "dominators on disconnected graph" $ do + dominators (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)] :: Gr () ())) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])] + +-------------------------------------------------- +-- Label-finding helper functions to help write tests that are +-- insensitive to minor changes to the AST. + +-- For each Fortran label in the list, find the corresponding basic +-- block, return as an IntSet. +findLabelsBB :: BBGr a -> [Int] -> IS.IntSet +findLabelsBB gr = IS.fromList . mapMaybe (flip findLabeledBBlock gr . show) + +findLabelBB :: BBGr a -> Int -> Node +findLabelBB gr = (error "findLabelBB" `fromMaybe`) . flip findLabeledBBlock gr . show + +-- For each Fortran label in the list, find the successors of the +-- corresponding basic block, return as an IntSet. +findSuccsBB :: BBGr a -> [Int] -> IS.IntSet +findSuccsBB gr = IS.fromList . concatMap (suc gr) . mapMaybe (flip findLabeledBBlock gr . show) + +-- For each Fortran label in the list, find the AST-block label numbers ('insLabel') associated +findLabelsBl :: forall a. Data a => ProgramFile (Analysis a) -> [Int] -> IS.IntSet +findLabelsBl pf labs = IS.fromList [ i | b <- universeBi pf :: [Block (Analysis a)] + , ExpValue _ _ (ValInteger lab') <- maybeToList (getLabel b) + , lab' `elem` labsS + , let a = getAnnotation b + , i <- maybeToList (insLabel a) ] + where labsS = map show labs + +-- Translate a list of edges given as Fortran labels into a set of +-- edges given as AST-block label numbers. +findLabelsBlEdges :: Data a => ProgramFile (Analysis a) -> [(Int, Int)] -> S.Set (Int, Int) +findLabelsBlEdges pf = S.fromList . map convEdge + where + convEdge (a, b) + | a':_ <- IS.toList (findLabelsBl pf [a]) -- FIXME: inefficient + , b':_ <- IS.toList (findLabelsBl pf [b]) = (a', b') + | otherwise = error $ "findLabelsBlEdges (" ++ show a ++ "," ++ show b ++ ")" + +-- Get the set of AST-block labels found in a given basic block +findBBlockBl :: BBGr (Analysis a) -> Int -> IS.IntSet +findBBlockBl gr = IS.fromList . mapMaybe (insLabel . getAnnotation) . concat . maybeToList . lab gr + +-------------------------------------------------- +-- Test programs + +programLoop4 = unlines [ + " program loop4" + , " 1 integer r, i, j" + , "" + , " 2 r = 0" + , "" + , " 3 i = 1" + , " 10 if (i .gt. 10) goto 40" + , "" + , " 4 j = 1" + , " 20 if (j .gt. 5) goto 30" + , " 5 r = r + i * j" + , " 6 j = j + 1" + , " 7 goto 20" + , "" + , " 30 i = i + 1" + , " 8 goto 10" + , "" + , " 40 write (*,*) r" + , " end" + ] + +programLoop4Alt = unlines [ + " module loopMod" + , " implicit none" + , " contains" + , " subroutine loop4()" + , " integer r, i, j" + , "" + , " 1 r = 0" + , "" +-- , "! outer loop" + , " 2 i = 1" + , " 10 do while (i .gt. 10)" + , "" +-- , "! inner loop" + , " 11 j = 1" + , " 20 do while (j .gt. 5)" + , " 21 r = r + i * j" + , " 22 j = j + 1" + , " end do" +-- , "! inner loop end" + , "" + , " 31 i = i + 1" + , " end do" +-- , "! outer loop end" + , "" + , " 41 write (*,*) r" + , " end subroutine" + , " end module" + ] + +programRd3 = unlines [ + " function f(x)" + , " integer i, a, b, x, f" + , " dimension a(10), b(10)" + , "" + , " 1 do 4 i = 2, 10" + , " 2 b(i) = a(i-1) + x" + , " 3 a(i) = b(i)" + , " 4 continue" + , " 5 f = a(10)" + , " end" + , " program rd3" + , " implicit none" + , " integer f" + , "" + , " write (*,*) f(1)" + , " end" + , "" + ] + +programRd4 = unlines [ + " function f(x)" + , " integer i, j, a, b, x, f" + , " dimension a(10), b(10)" + , "" + , " do 10 i = 2, 10" + , " do 20 j = 2, 10" + , " b(i) = a(i-1) + x" + , " 20 continue" + , " a(i) = b(i)" + , " 10 continue" + , " f = a(10)" + , " end" + , " program rd3" + , " implicit none" + , " integer f" + , "" + , " write (*,*) f(1)" + , " end" + , "" + ] + +-- do not use line numbers +programBug36 = unlines [ + "program foo" + , " implicit none" + , " integer :: i, j" + , " real, dimension(100) :: a, b" + , " do i=1,100" + , " do j=1,100" + , " a(i) = b(i) + b(1)" + , " end do" + , " end do" + , "end program" + ] + +programFuncFlow1 = unlines [ + " program main" + , " integer :: i, j" + , " 1 i = 1" + , " 2 j = f(i)" + , " contains" + , " integer function f(k)" + , " integer :: k" + , " 3 f = k + 1" + , " end function f" + , " end program main" + ] + +programFuncFlow2 = unlines [ + " program main" + , " integer :: i, j" + , " 1 do i = 1, 10" + , " 2 j = 2*f(3*i)" + , " end do" + , " contains" + , " integer function f(k)" + , " integer :: k" + , " 3 f = k + 1" + , " end function f" + , " end program main" + ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Analysis/RenamingSpec.hs b/test/Language/Fortran/Analysis/RenamingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/RenamingSpec.hs @@ -0,0 +1,371 @@ +module Language.Fortran.Analysis.RenamingSpec (spec) where + +import Test.Hspec +import TestUtil + +import Data.Map ((!), elems) +import qualified Data.Map as M +import Data.List + +import Language.Fortran.ParserMonad +import Language.Fortran.AST +import Language.Fortran.Util.Position +import qualified Language.Fortran.Parser.Fortran90 as F90 +import Language.Fortran.Analysis +import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Data.Generics.Uniplate.Data +import Data.Generics.Uniplate.Operations +import Data.Data +import qualified Data.ByteString.Char8 as B + +import Debug.Trace + +testF90 pf = (resetSrcSpan . analyseRenames . initAnalysis) $ pf +extractNameMap' = extractNameMap . analyseRenames . initAnalysis +unrename' = stripAnalysis . unrename . rename . analyseRenames . initAnalysis +renameAndStrip' x = stripAnalysis . rename . analyseRenames . initAnalysis $ x + +countUnrenamed e = length [ () | ExpValue (Analysis { uniqueName = Nothing }) _ (ValVariable {}) <- uniE_PF e ] + where uniE_PF :: ProgramFile (Analysis ()) -> [Expression (Analysis ())] + uniE_PF = universeBi + +fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file + +spec :: Spec +spec = do + describe "Basic" $ do + it "num-entries 1" $ do + let entry = extractNameMap' ex3 + shouldBe ( length (filter (=="f1") (elems entry)) + , length (filter (=="a") (elems entry)) + , length (filter (=="b") (elems entry)) + , length (filter (=="d") (elems entry)) ) + ( 1, 2, 2, 2 ) + + -- Test that every symbol that is supposed to be renamed is renamed. + it "complete ex1" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex1) `shouldBe` 0 + it "complete ex2" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex2) `shouldBe` 0 + it "complete ex3" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex3) `shouldBe` 0 + it "complete ex4" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex4) `shouldBe` 0 + it "complete ex5" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex5) `shouldBe` 0 + it "complete ex6" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex6) `shouldBe` 0 + it "complete ex8" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex8) `shouldBe` 0 + it "complete ex9" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex9) `shouldBe` 0 + it "complete ex10" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex10) `shouldBe` 0 + it "complete ex11" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex11) `shouldBe` 0 + it "complete ex12" $ do + countUnrenamed (analyseRenames . initAnalysis $ ex12) `shouldBe` 0 + + it "complete exScope1" $ do + countUnrenamed (analyseRenames . initAnalysis $ exScope1) `shouldBe` 0 + it "complete exScope2" $ do + countUnrenamed (analyseRenames . initAnalysis $ exScope2) `shouldBe` 0 + + it "functions 1" $ do + let entry = extractNameMap' ex3 + length (filter (=="f1") (elems entry)) `shouldBe'` 1 + + describe "Identity" $ do + it "unrename-rename 1" $ do + let entry = unrename' ex1 + entry `shouldBe'` ex1 + + it "unrename-rename 2" $ do + let entry = unrename' ex2 + entry `shouldBe'` ex2 + + it "unrename-rename 3" $ do + let entry = unrename' ex3 + entry `shouldBe'` ex3 + + it "unrename-rename 4" $ do + let entry = unrename' ex4 + entry `shouldBe'` ex4 + + describe "Shadowing" $ do + it "exScope1 testing non-shadowing of subprogram names" $ do + let entry = extractNameMap' exScope1 + let keys = M.keys entry + length keys `shouldBe` 1 + + it "exScope2 testing shadowing of variables" $ do + let entry = extractNameMap' exScope2 + length (filter (=="x") (elems entry)) `shouldBe` 2 + + describe "Ordering" $ do + it "exScope3 testing out-of-order definitions" $ do + let entry = extractNameMap' exScope3 + length (filter (=="f1") (elems entry)) `shouldBe` 1 + length (filter (=="f2") (elems entry)) `shouldBe` 1 + length (filter (=="s1") (elems entry)) `shouldBe` 1 + length (filter (=="s2") (elems entry)) `shouldBe` 1 + +-------------------------------------------------- + +ex1 = ProgramFile mi77 [ ex1pu1 ] +ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing + +ex2 = ProgramFile mi77 [ ex2pu1 ] +ex2pu1 = PUMain () u (Just "main") ex2pu1bs Nothing +ex2pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclVariable () u (varGen "c") Nothing Nothing + , DeclVariable () u (varGen "d") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "c") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "d") (AList () u [ ixSinGen 1 ])) (intGen 1)) ] + +ex3 = ProgramFile mi77 [ ex3pu1, ex3pu2 ] +ex3pu1 = PUMain () u (Just "main") ex3pu1bs Nothing +ex3pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclVariable () u (varGen "c") Nothing Nothing + , DeclVariable () u (varGen "d") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "c") Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "c") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (varGen "d") (ExpBinary () u Addition (varGen "d") (intGen 1))) ] +ex3pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "d", varGen "b"]) Nothing (ex3pu1bs ++ [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "d")) ]) Nothing + +ex4 = ProgramFile mi77 [ ex4pu1, ex4pu2 ] +ex4pu1 = PUMain () u (Just "main") ex4pu1bs Nothing +ex4pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "f1") Nothing Nothing + , DeclVariable () u (varGen "r") Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpValue () u (ValVariable "r")) + (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) + (Just $ AList () u [ Argument () u Nothing $ intGen 1 ]))) ] +ex4pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing + +ex5 = ProgramFile mi77 [ ex5pu1, ex5pu2 ] +ex5pu1 = PUMain () u (Just "main") ex5pu1bs Nothing +ex5pu1bs = [] +ex5pu2 = PUModule () u "ex5mod" ex5pu2bs (Just [ex5pu2pu1]) +ex5pu2bs = [] +ex5pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing + + +ex6 = ProgramFile mi77 [ ex6pu1, ex6pu2 ] +ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing +ex6pu1bs = [] +ex6pu2 = PUModule () u "ex6mod" ex6pu2bs (Just [ex6pu2pu1]) +ex6pu2bs = [] +ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [Argument () u Nothing (varGen "x")]))) ] (Just [ex5pu2pu1]) + +parseF90 = resetSrcSpan . flip fortran90Parser "" . unlines + +ex8 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module m1" + , " implicit none" + , "contains" + , " integer function foo ()" + , " foo = 0" + , " end function foo" + , "end module m1" + , "" + , "module m2" + , " implicit none" + , "contains" + , " integer function foo2 (x)" + , " use m1" + , " integer :: x" + , " foo2 = foo () + x" + , " end function foo2" + , "end module m2" + , "" + , "module m3" + , " implicit none" + , "contains" + , " integer function foo () result (r)" + , " r = 1" + , " end function foo" + , "end module m3" + , "" + , "program main" + , " use m1" + , " integer :: x" + , " x = foo ()" + , "end program main" + ] + +ex9 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module m1" + , " implicit none" + , " integer :: x" + , "contains" + , " integer function f () result (x)" + , " integer :: x" + , " x = 0" + , " end function f" + , " subroutine s ()" + , " x = 0" + , " end subroutine s" + , "end module m1" + ] + +ex10 = ProgramFile mi77 [ ex10pu1 ] +ex10pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex10pu1bs Nothing +ex10pu1bs = + [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ] + +ex11 = ProgramFile mi77 [ ex11pu1 ] +ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1bs = + [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ] + +ex12 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module m1" + , " implicit none" + , " integer :: z" + , "contains" + , " integer function foo ()" + , " foo = 0" + , " end function foo" + , "end module m1" + , "" + , "module m2" + , " implicit none" + , "contains" + , " integer function foo2 (x)" + , " use m1" + , " integer :: x" + , " foo2 = foo () + x" + , " end function foo2" + , "end module m2" + , "" + , "module m3" + , " implicit none" + , "contains" + , " integer function foo () result (r)" + , " r = 1" + , " end function foo" + , "end module m3" + , "" + , "program main" + , " use m1, only: z" + , " use m3, only: foo" + , " integer :: x" + , " x = foo ()" + , "end program main" + ] + + +exScope1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "program scope1" + -- local variables cannot take on the name of subprogram, therefore + -- this declaration must be simply redeclaring the function x. + , " integer :: x" + , "" + , " print *, x()" -- function use prior to definition is OK + , "" + , "end program scope1" + , "integer function x ()" + , " x = 1" + , "end function x" + , "" + ] + +exScope2 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module scope2" + , " integer :: x" + , "contains" + , " subroutine s1 ()" + , " ! this is variable shadowing" + , " integer :: x" + , " x = 1" + , " print *, x" + , " call s2 ()" + , " print *, x" + , " contains" + , " subroutine s2" + , " ! reference to outside variable" + , " x = 2" + , " end subroutine s2" + , " end subroutine s1" + , "end module scope2" + , "" + , "program main" + , " use scope2" + , " x = 0" + , " print *, x" + , " call s1 ()" + , " print *, x" + , " ! should print 0 at end" + , "end program main" + ] + +exScope3 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module m1" + , " implicit none" + , " integer :: x" + , "contains" + , "" + , " subroutine s1 ()" + , " call s2 (f1(x))" + , " end subroutine s1" + , "" + , " integer function f1(x)" + , " integer :: x, f2" + , " f1 = f2(x)" + , " end function f1" + , "" + , "" + , "end module m1" + , "" + , "program main" + , " use m1" + , " implicit none" + , " call s1()" + , " print *, f1(x)" + , "end program main" + , "" + , "subroutine s2 (x)" + , " integer :: x, f2" + , " x = f2 (x)" + , "end subroutine s2" + , "" + , "function f2(x)" + , " integer :: x, f2" + , " f2 = x + 1" + , "end function f2" + ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Analysis/TypesSpec.hs b/test/Language/Fortran/Analysis/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Analysis/TypesSpec.hs @@ -0,0 +1,160 @@ +module Language.Fortran.Analysis.TypesSpec where + +import Test.Hspec +import TestUtil + +import Data.Map ((!)) + +import Data.Data +import Language.Fortran.AST +import Language.Fortran.Analysis.Types +import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import Language.Fortran.Analysis +import qualified Language.Fortran.Parser.Fortran90 as F90 +import Language.Fortran.ParserMonad +import qualified Data.ByteString.Char8 as B + +import Debug.Trace + +inferTable :: Data a => ProgramFile a -> TypeEnv +inferTable = underRenaming (snd . analyseTypes) + +fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file + +spec :: Spec +spec = do + describe "Global type inference" $ do + it "types integer returning function" $ do + let entry = inferTable ex1 ! "f1" + entry `shouldBe` IDType (Just TypeInteger) (Just CTFunction) + + it "types multiples program units" $ do + let mapping = inferTable ex2 + mapping ! "f1" `shouldBe` IDType (Just TypeInteger) (Just CTFunction) + mapping ! "s1" `shouldBe` IDType Nothing (Just CTSubroutine) + + it "types ENTRY points within subprograms" $ do + let mapping = inferTable ex3 + mapping ! "e1" `shouldBe` IDType Nothing (Just CTSubroutine) + mapping ! "e2" `shouldBe` IDType Nothing (Just CTSubroutine) + mapping ! "e3" `shouldBe` IDType Nothing (Just CTSubroutine) + + describe "Local type inference" $ do + it "infers from type declarations" $ do + let mapping = inferTable ex4 + mapping ! "x" `shouldBe` IDType (Just TypeInteger) (Just CTVariable) + mapping ! "y" `shouldBe` IDType (Just TypeInteger) (Just CTArray) + mapping ! "c" `shouldBe` IDType (Just TypeCharacter) (Just CTVariable) + mapping ! "log" `shouldBe` IDType (Just TypeLogical) (Just CTVariable) + + it "infers from dimension declarations" $ do + let mapping = inferTable ex5 + mapping ! "x" `shouldBe` IDType Nothing (Just CTArray) + mapping ! "y" `shouldBe` IDType Nothing (Just CTArray) + + it "infers from function statements" $ do + let mapping = inferTable ex6 + mapping ! "a" `shouldBe` IDType (Just TypeInteger) (Just CTArray) + mapping ! "b" `shouldBe` IDType (Just TypeInteger) (Just CTArray) + mapping ! "c" `shouldBe` IDType (Just TypeInteger) (Just CTFunction) + mapping ! "d" `shouldBe` IDType Nothing (Just CTFunction) + + describe "Intrinsics type analysis" $ do + it "disambiguates intrinsics from functions and variables" $ do + let mapping = inferTable intrinsics1 + idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic + idCType (mapping ! "dabs") `shouldBe` Just CTFunction + idCType (mapping ! "cabs") `shouldBe` Just CTArray + +ex1 = ProgramFile mi77 [ ex1pu1 ] +ex1pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) (None () u False) "f1" Nothing Nothing [] Nothing + +ex2 = ProgramFile mi77 [ ex2pu1, ex1pu1 ] +ex2pu1 = PUSubroutine () u (None () u False) "s1" Nothing [] Nothing + +ex3 = ProgramFile mi77 [ ex3pu1 ] +ex3pu1 = PUSubroutine () u (None () u False) "s1" Nothing ex3pu1bs Nothing +ex3pu1bs = + [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing Nothing) ] + +ex4 = ProgramFile mi77 [ ex4pu1 ] +ex4pu1 = PUMain () u Nothing ex4pu1bs Nothing +ex4pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing + (AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing + , DeclArray () u (varGen "y") + (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing + (AList () u [ DeclVariable () u (varGen "c") Nothing Nothing ])) + , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeLogical Nothing) Nothing + (AList () u [ DeclVariable () u (varGen "log") Nothing Nothing ])) ] + +ex5 = ProgramFile mi77 [ ex5pu1 ] +ex5pu1 = PUBlockData () u (Just "bd") ex5pu1bs +ex5pu1bs = + [ BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "x") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclArray () u (varGen "y") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing])) ] + +{- +- program Main +- integer a, b(1), c +- dimension a(1) +- a(1) = 1 +- b(1) = 1 +- c(x) = 1 +- d(x) = 1 +- end +-} +ex6 = ProgramFile mi77 [ ex6pu1 ] +ex6pu1 = PUMain () u (Just "main") ex6pu1bs Nothing +ex6pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclVariable () u (varGen "c") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "a") (fromList () [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "b") (fromList () [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "c") (fromList () [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "d") (fromList () [ ixSinGen 1 ])) (intGen 1)) ] + +ex11 = ProgramFile mi77 [ ex11pu1 ] +ex11pu1 = PUFunction () u (Just (TypeSpec () u TypeInteger Nothing)) (None () u False) "f1" Nothing (Just (varGen "r1")) ex11pu1bs Nothing +ex11pu1bs = + [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing) + , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ] + + +intrinsics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [ + "module intrinsics" + , "contains" + , " subroutine main()" + , " real :: x" + , " integer :: y = 1" + , " real :: cabs(3)" + , " x = dabs(y)" + , " x = cabs(y)" + , " x = abs(y)" + , " print *, x" + , " end subroutine main" + , " real function dabs(a)" + , " integer :: a" + , " dabs = a" + , " end function dabs" + , "end module intrinsics" + ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/AnalysisSpec.hs b/test/Language/Fortran/AnalysisSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/AnalysisSpec.hs @@ -0,0 +1,63 @@ +module Language.Fortran.AnalysisSpec where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Parser.Fortran77 +import Language.Fortran.Lexer.FixedForm (initParseState) +import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.AST +import Language.Fortran.Analysis +import Data.Graph.Inductive +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as B + +pParser :: String -> ProgramFile (Analysis ()) +pParser source = initAnalysis + . fromParseResultUnsafe + $ extended77Parser (B.pack source) "" + +spec :: Spec +spec = + describe "Analysis" $ do + describe "anal1" $ do + it "lhsExprs" $ do + let pf = stripAnalysis $ pParser programAnal1 + lhsExprs pf `shouldMatchList'` programAnal1LhsExprs + +programAnal1LhsExprs = + [ ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 1 ]) + , ExpSubscript () u (ExpValue () u (ValVariable "a")) + (AList () u [ IxSingle () u Nothing $ + ExpSubscript () u (varGen "a") + (AList () u [ ixSinGen 2 ])]) + , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 4 ]) + , ExpValue () u (ValVariable "f") + , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 6 ]) + , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 5 ]) ] + +programAnal1 = unlines $ map (replicate 6 ' '++) [ + "program anal1" + , "integer a, f" + , "dimension a(10)" + , "a(1) = f(a(6))" + , "a(a(2)) = a(10)" + , "call s(1)" + , "call s(a(4))" + , "call s(f(a(5)))" + , "end" + , "subroutine s(x)" + , "integer x" + , "end" + , "function f(x)" + , "integer x, f" + , "f = x" + , "end" + ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Lexer/FixedFormSpec.hs b/test/Language/Fortran/Lexer/FixedFormSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Lexer/FixedFormSpec.hs @@ -0,0 +1,281 @@ +module Language.Fortran.Lexer.FixedFormSpec where + +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FixedForm + +import Test.Hspec +import Test.Hspec.QuickCheck +import TestUtil + +import Control.Monad.State.Lazy +import Control.Exception + +import Data.List (isPrefixOf) +import qualified Data.ByteString.Char8 as B + +lex66 :: String -> Maybe Token +lex66 = collectToLex Fortran66 + +safeLex66 :: String -> Maybe Token +safeLex66 = collectToLexSafe Fortran66 + +lex77 :: String -> Maybe Token +lex77 = collectToLex Fortran77 + +collectToLex :: FortranVersion -> String -> Maybe Token +collectToLex version srcInput = dropUntil2 $ collectFixedTokens version (B.pack srcInput) + where + dropUntil2 [] = Nothing + dropUntil2 [_] = Nothing + dropUntil2 [a,_] = Just a + dropUntil2 (x:xs) = dropUntil2 xs + +collectToLexSafe :: FortranVersion -> String -> Maybe Token +collectToLexSafe version srcInput = dropUntil2 $ collectFixedTokensSafe version (B.pack srcInput) + where + dropUntil2 (Just [a,_]) = Just a + dropUntil2 (Just (x:xs)) = dropUntil2 $ Just xs + dropUntil2 _ = Nothing + +collectFixedTokens' v = collectFixedTokens v . B.pack + +spec :: Spec +spec = + describe "Fortran Fixed Form Lexer" $ do + describe "Fortran 77" $ + describe "String" $ do + it "lexes 'hello'" $ + resetSrcSpan (lex77 " c = 'hello'") `shouldBe` resetSrcSpan (Just $ TString u "hello") + + it "lexes 'he''llo'" $ + resetSrcSpan (lex77 " c = 'he''llo'") `shouldBe` resetSrcSpan (Just $ TString u "he'llo") + + it "lexes 'he''''ll''o'" $ + resetSrcSpan (lex77 " c = 'he''''ll''o'") `shouldBe` resetSrcSpan (Just $ TString u "he''ll'o") + + it "lexes '''hello'''" $ + resetSrcSpan (lex77 " c = '''hello'''") `shouldBe` resetSrcSpan (Just $ TString u "'hello'") + + it "lexes 'hello world'" $ + resetSrcSpan (lex77 " c = 'hello world'") `shouldBe` resetSrcSpan (Just $ TString u "hello world") + + it "lexes 'hello world'" $ + resetSrcSpan (collectFixedTokens' Fortran77 " c = 'x' // 'o'") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "x", TSlash u, TSlash u, TString u "o", TEOF u] + + describe "Fortran 66" $ do + prop "lexes Label, Comment, Newline or EOF in the first six columns or returns Nothing " $ + \x -> isPrefixOf " " x || case safeLex66 x of + Nothing -> True + Just (TLabel _ _) -> True + Just (TComment _ _) -> True + Just (TEOF _) -> True + Just (TNewline _) -> True + _ -> False + + it "lexes alphanumeric identifier" $ + resetSrcSpan (collectFixedTokens' Fortran66 " e42 =") `shouldBe` resetSrcSpan [TId u "e42", TOpAssign u, TEOF u] + + it "lexes exponent" $ + resetSrcSpan (collectFixedTokens' Fortran66 " a = 42 e42") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "42", TExponent u "e42", TEOF u] + + it "lexes 'function foo()'" $ + resetSrcSpan (collectFixedTokens' Fortran66 " function foo()") `shouldBe` resetSrcSpan [TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u] + + it "lexes 'end'" $ + resetSrcSpan (lex66 " end") `shouldBe` resetSrcSpan (Just $ TEnd u) + + it "lexes identifier" $ + resetSrcSpan (lex66 " a = mistr") `shouldBe` resetSrcSpan (Just $ TId u "mistr") + + it "lexes comment if first column is C" $ + resetSrcSpan (lex66 "c this is a comment") `shouldBe` resetSrcSpan (Just $ TComment u " this is a comment") + + it "lexes empty comment" $ + resetSrcSpan (lex66 "c") `shouldBe` resetSrcSpan (Just $ TComment u "") + + it "lexes comment with one char" $ + resetSrcSpan (lex66 "ca") `shouldBe` resetSrcSpan (Just $ TComment u "a") + + it "should not lex from the next line" $ + resetSrcSpan (safeLex66 "cxxx\nselam") `shouldNotBe` resetSrcSpan (Just $ TComment u "xxxselam") + + -- This is commented out as identifiers are longer than what the standard says. + it "lexes three tokens" $ do + pending + resetSrcSpan (collectFixedTokens' Fortran66 " function end format") `shouldBe` resetSrcSpan [TFunction u, TId u "endfor", TId u "mat", TEOF u] + + it "lexes multiple comments in a line" $ + resetSrcSpan (collectFixedTokens' Fortran66 "csomething\ncsomething else\n\nc\ncc\n") `shouldBe` + resetSrcSpan [TComment u "something", TNewline u, TComment u "something else", TNewline u, TNewline u, TComment u "", TNewline u, TComment u "c", TNewline u, TEOF u] + + it "lexes example1" $ + resetSrcSpan (collectFixedTokens' Fortran66 example1) `shouldBe` resetSrcSpan example1Expectation + + it "lexes end of file" $ + resetSrcSpan (lex66 "") `shouldBe` Nothing + + it "lexes '3 + 2'" $ + resetSrcSpan (collectFixedTokens' Fortran66 " a = 3 + 2") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "3", TOpPlus u , TInt u "2", TEOF u] + + it "should lex continuation lines properly" $ + resetSrcSpan (collectFixedTokens' Fortran66 continuationExample) `shouldBe` resetSrcSpan [ TType u "integer", TId u "ix", TNewline u, TId u "ix", TOpAssign u, TInt u "42", TNewline u, TEnd u, TNewline u, TEOF u ] + + it "lexes 'ASSIGN 100 TO FOO'" $ + resetSrcSpan (collectFixedTokens' Fortran66 " ASSIGN 100 TO FOO") `shouldBe` resetSrcSpan [TAssign u, TInt u "100", TTo u, TId u "foo", TEOF u] + + it "lexes 'DO 100 dovar = 1, 10'" $ + resetSrcSpan (collectFixedTokens' Fortran66 " DO 100 dovar = 1, 10") + `shouldBe` + resetSrcSpan [TDo u, TInt u "100", TId u "dovar", TOpAssign u, TInt u "1", TComma u, TInt u "10", TEOF u] + + describe "lexN" $ + it "`lexN 5` parses lexes next five characters" $ + (lexemeMatch . aiLexeme) (evalParse (lexN 5 >> getAlex) (initParseState (B.pack "helloWorld") Fortran66 "")) `shouldBe` reverse "hello" + + describe "lexHollerith" $ do + it "lexes Hollerith '7hmistral'" $ + resetSrcSpan (lex66 " x = 7hmistral") `shouldBe` resetSrcSpan (Just $ THollerith u "mistral") + + it "becomes case sensitive" $ + resetSrcSpan (collectFixedTokens' Fortran66 " format (5h a= 1)") `shouldBe` resetSrcSpan [ TFormat u, TBlob u "(5ha=1)", TEOF u ] + + it "lexes if statement ' IF (IY) 5,6,6'" $ + resetSrcSpan (collectFixedTokens' Fortran66 " IF (IY) 5,6,6") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "iy", TRightPar u, TInt u "5", TComma u, TInt u "6", TComma u, TInt u "6", TEOF u] + + it "lexes if then statement ' if (x) then'" $ + resetSrcSpan (collectFixedTokens' Fortran77 " if (x) then") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "x", TRightPar u, TThen u, TEOF u] + + it "lexes if variable decl ' INTEGER IF'" $ -- yes, really.. + resetSrcSpan (collectFixedTokens' Fortran77 " INTEGER IF") + `shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u] + + describe "Fortran 77 Legacy" $ do + it "lexes inline comments" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer foo ! bar") + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u] + + it "lexes continuation lines separated by comments" $ do + let src = unlines [ " integer foo," + , "C hello" + , " + bar" + ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + let src = unlines [ " integer foo, ! hello" + , " + bar" + ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + let src = unlines [ " integer foo," + , "" + , " + bar" + ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + let src = unlines [ " integer foo," + , " " -- the space is intentional + , " + bar" + ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u] + + it "lexes the older TYPE statement" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " type *, 'hello'") + `shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u] + + it "lexes width-specific type declarations" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer*4 i") + `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TId u "i", TEOF u] + + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer*4 function foo()") + `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u] + + resetSrcSpan (collectFixedTokens' Fortran77Legacy " character*4 s") + `shouldBe` resetSrcSpan [TType u "character", TStar u, TInt u "4", TId u "s", TEOF u] + + resetSrcSpan (collectFixedTokens' Fortran77Legacy " character*(*) s") + `shouldBe` resetSrcSpan [TType u "character", TStar u, TLeftPar u, TStar u, TRightPar u, TId u "s", TEOF u] + + resetSrcSpan (collectFixedTokens' Fortran77Legacy " character s*(*)") + `shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u] + + it "lexes strings case-sensitively" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = 'Hello'") + `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u] + + it "lexes strings delimited by '\"'" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = \"hello\"") + `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u] + + it "lexes Hollerith constants" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " x = 7hmistral") + `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "mistral", TEOF u] + + resetSrcSpan (collectFixedTokens' Fortran77Legacy " x = 7hshort\n") + `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short ", TNewline u, TEOF u] + + it "lexes BOZ constants" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i, j, k / b'0101', o'0755', z'ab01' /") + `shouldBe` resetSrcSpan [ TType u "integer", TId u "i", TComma u, TId u "j", TComma u, TId u"k" + , TSlash u, TBozInt u "b'0101'", TComma u, TBozInt u "o'0755'", TComma u, TBozInt u "z'ab01'", TSlash u + , TEOF u ] + + it "lexes non-standard identifiers" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer _this_is_a_long_identifier$") + `shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u] + + it "lexes ';' as a line-terminator" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i; integer j") + `shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u] + + it "lexes subscripts in assignments" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " x(0,0) = 0") + `shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u] + + it "lexes labeled DO WHILE blocks" $ do + resetSrcSpan (collectFixedTokens' Fortran77Legacy " do 10 while (.true.)") + `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u ".true.", TRightPar u, TEOF u] + + + it "lexes structure/union/map blocks" $ do + let src = unlines [ " structure /foo/" + , " union" + , " map" + , " integer i" + , " real r" + , " end map" + , " end union" + , " end structure"] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) + `shouldBe` resetSrcSpan [ TStructure u, TSlash u, TId u "foo", TSlash u, TNewline u + , TUnion u, TNewline u + , TMap u, TNewline u + , TType u "integer", TId u "i", TNewline u + , TType u "real", TId u "r", TNewline u + , TEndMap u, TNewline u + , TEndUnion u, TNewline u + , TEndStructure u, TNewline u + , TEOF u ] + +example1 = unlines [ + " intEGerix", + "1 iX= 42", + " 200 ix =IX* ix", + " 10 wrITe (*,*), ix", + " EnD" ] + +continuationExample = unlines [ + " inte", + " .ger i", + " .x", + " ix = 4", + " .2", + " end"] + +example1Expectation = [ + TType u "integer", TId u "ix", TNewline u, + TLabel u "1", TId u "ix", TOpAssign u, TInt u "42", TNewline u, + TLabel u "200", TId u "ix", TOpAssign u, TId u "ix", TStar u, TId u "ix", TNewline u, + TLabel u "10", TWrite u, TLeftPar u, TStar u, TComma u, TStar u, TRightPar u, TComma u, TId u "ix", TNewline u, + TEnd u, TNewline u, + TEOF u] diff --git a/test/Language/Fortran/Lexer/FreeFormSpec.hs b/test/Language/Fortran/Lexer/FreeFormSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Lexer/FreeFormSpec.hs @@ -0,0 +1,263 @@ +module Language.Fortran.Lexer.FreeFormSpec where + +import Test.Hspec +import TestUtil + +import Data.Maybe (fromJust) + +import Language.Fortran.ParserMonad (FortranVersion(..)) +import Language.Fortran.Lexer.FreeForm (collectFreeTokens, Token(..)) +import qualified Data.ByteString.Char8 as B + +import Debug.Trace + +collectF90 :: String -> [ Token ] +collectF90 = collectFreeTokens Fortran90 . B.pack + +pseudoAssign token = fmap ($u) [ flip TId "i", TOpAssign, token, TEOF ] + +spec :: Spec +spec = + describe "Fortran Free Form Lexer" $ + describe "Fortran 90" $ do + describe "Character sensitivity" $ do + it "lexes lower case tokens" $ + shouldBe' (collectF90 "integer id") $ + fmap ($u) [ TInteger, flip TId "id", TEOF ] + + it "lexes mixed case tokens" $ + shouldBe' (collectF90 "InTEgeR ID") $ + fmap ($u) [ TInteger, flip TId "id", TEOF ] + + describe "Identifier" $ do + it "lexes long ID names" $ + shouldBe' (collectF90 "program long_id_name") $ + fmap ($u) [ TProgram, flip TId "long_id_name", TEOF ] + + it "treats 'if' as ID if used in assignment" $ + shouldBe' (collectF90 "if = 20") $ + fmap ($u) [ flip TId "if", TOpAssign + , flip TIntegerLiteral "20", TEOF ] + + it "'result' is an identifier in spec. context" $ + shouldBe' (collectF90 "integer :: result") $ + fmap ($u) [ TInteger, TDoubleColon , flip TId "result" + , TEOF ] + + describe "Types" $ do + it "lexes length and kind selectors" $ + shouldBe' (collectF90 "integer (KIND=1, LEN=1) :: kind, len") $ + fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign + , flip TIntegerLiteral "1", TComma, TLen + , TOpAssign, flip TIntegerLiteral "1", TRightPar + , TDoubleColon , flip TId "kind", TComma + , flip TId "len", TEOF ] + + + it "lexes simple type tokens" $ + shouldBe' (collectF90 "character x") $ + fmap ($u) [ TCharacter, flip TId "x", TEOF ] + + it "lexes simple type tokens in function" $ + shouldBe' (collectF90 "character function x") $ + fmap ($u) [ TCharacter, TFunction, flip TId "x", TEOF ] + + it "lexes character type with F77 length syntax (1)" $ + shouldBe' (collectF90 "character * (*) function x") $ + fmap ($u) [ TCharacter, TStar, TLeftPar, TStar, TRightPar, TFunction, flip TId "x", TEOF ] + + it "lexes character type with F77 length syntax (2)" $ + shouldBe' (collectF90 "character * 20 function x") $ + fmap ($u) [ TCharacter, TStar, flip TIntegerLiteral "20", TFunction, flip TId "x", TEOF ] + + it "lexes derived type tokens in function" $ + shouldBe' (collectF90 "type (x) function x") $ + fmap ($u) [ TType, TLeftPar, flip TId "x", TRightPar + , TFunction, flip TId "x", TEOF ] + + it "lexes interleaved type recursive tokens" $ + shouldBe' (collectF90 "integer (KIND=10*2) recursive function x") $ + fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign + , flip TIntegerLiteral "10" , TStar + , flip TIntegerLiteral "2", TRightPar, TRecursive + , TFunction, flip TId "x", TEOF ] + + it "lexes interleaved type recursive tokens (reversed)" $ + shouldBe' (collectF90 "recursive integer (KIND=10*2) function x") $ + fmap ($u) [ TRecursive, TInteger, TLeftPar, TKind, TOpAssign + , flip TIntegerLiteral "10" , TStar + , flip TIntegerLiteral "2", TRightPar, TFunction + , flip TId "x", TEOF ] + + describe "Function" $ do + it "lexes 'function fx ( a, b, c )'" $ + shouldBe' (collectF90 "function fx ( a, b )") $ + fmap ($u) [ TFunction, flip TId "fx", TLeftPar, flip TId "a" + , TComma, flip TId "b", TRightPar, TEOF ] + + it "lexes functions with specific result" $ + shouldBe' (collectF90 "function fx (array) result (c_sum)") $ + fmap ($u) [ TFunction, flip TId "fx", TLeftPar + , flip TId "array", TRightPar, TResult, TLeftPar + , flip TId "c_sum", TRightPar, TEOF ] + + it "lexes recursive functions" $ + shouldBe' (collectF90 "recursive function fx (array)") $ + fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar + , flip TId "array", TRightPar, TEOF ] + + it "lexes recursive functions with result specified" $ + shouldBe' (collectF90 "RECURSIVE FUNCTION FX (ARRAY) RESULT (C_SUM)") $ + fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar + , flip TId "array", TRightPar, TResult, TLeftPar + , flip TId "c_sum", TRightPar, TEOF ] + + describe "Attribute" $ do + it "lexes PARAMETER attribute" $ + shouldBe' (collectF90 "integer, parameter :: x") $ + fmap ($u) [ TInteger, TComma, TParameter, TDoubleColon + , flip TId "x", TEOF ] + + it "lexes INTENT attribute" $ + shouldBe' (collectF90 "integer, intent (inout) :: x") $ + fmap ($u) [ TInteger, TComma, TIntent, TLeftPar, TInOut + , TRightPar, TDoubleColon , flip TId "x", TEOF ] + + it "lexes DIMENSION attribute" $ + shouldBe' (collectF90 "double precision, dimension (3:10) :: x") $ + fmap ($u) [ TDoublePrecision, TComma, TDimension, TLeftPar + , flip TIntegerLiteral "3", TColon + , flip TIntegerLiteral "10" , TRightPar + , TDoubleColon , flip TId "x", TEOF ] + + it "lexes variable declaration with multiple attributes" $ + shouldBe' (collectF90 "double precision, save, dimension(2), allocatable :: y") $ + fmap ($u) [ TDoublePrecision, TComma, TSave, TComma + , TDimension, TLeftPar, flip TIntegerLiteral "2" + , TRightPar, TComma, TAllocatable, TDoubleColon + , flip TId "y", TEOF ] + describe "Character" $ do + it "lexes single quote literal" $ + shouldBe' (collectF90 "character c = 'heL\"Lo ''daRLing'") $ + fmap ($u) [ TCharacter, flip TId "c", TOpAssign + , flip TString "heL\"Lo 'daRLing", TEOF ] + + it "lexes double quote literal" $ + shouldBe' (collectF90 "character c = \"heL'Lo \"\"daRLing\"") $ + fmap ($u) [ TCharacter, flip TId "c", TOpAssign + , flip TString "heL'Lo \"daRLing", TEOF ] + + describe "Module" $ do + it "lexes module statement" $ + shouldBe' (collectF90 "module Hello_mod") $ + fmap ($u) [ TModule, flip TId "hello_mod", TEOF ] + + it "lexes use statement" $ + shouldBe' (collectF90 "use Hello_mod, hello => hi") $ + fmap ($u) [ TUse, flip TId "hello_mod", TComma + , flip TId "hello", TArrow, flip TId "hi", TEOF ] + + it "lexes use statement with only" $ + shouldBe' (collectF90 "use Hello_mod, only: a, b => c") $ + fmap ($u) [ TUse, flip TId "hello_mod", TComma, TOnly + , TColon, flip TId "a", TComma, flip TId "b" + , TArrow, flip TId "c", TEOF ] + + describe "Label" $ + it "lexes simple label" $ + shouldBe' (collectF90 "010 print *, 'hello'") $ + fmap ($u) [ flip TIntegerLiteral "010", TPrint, TStar, TComma + , flip TString "hello", TEOF ] + + describe "Conditional" $ do + it "lexes logical if with array assignment" $ + shouldBe' (collectF90 "if (.true.) a(1) = 42") $ + fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral ".true." + , TRightPar, flip TId "a", TLeftPar + , flip TIntegerLiteral "1", TRightPar, TOpAssign + , flip TIntegerLiteral "42", TEOF ] + + it "lexes block if statement" $ + shouldBe' (collectF90 "if (a > b) then") $ + fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b" + , TRightPar, TThen, TEOF ] + + it "lexes arithmetic if statement" $ + shouldBe' (collectF90 "if (a) 10, 11, 12") $ + fmap ($u) [ TIf, TLeftPar, flip TId "a", TRightPar + , flip TIntegerLiteral "10", TComma + , flip TIntegerLiteral "11", TComma + , flip TIntegerLiteral "12" , TEOF ] + + it "lexes logical if statement" $ + shouldBe' (collectF90 "if (a > b) print *, 'hello'") $ + fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b" + , TRightPar, TPrint, TStar, TComma + , flip TString "hello", TEOF ] + + describe "Lexes numeric values" $ do + it "lexes integer" $ + shouldBe' (collectF90 "i = 42") $ + pseudoAssign $ flip TIntegerLiteral "42" + + describe "Real" $ do + it "lexes real (1)" $ + shouldBe' (collectF90 "i = 10.5e2") $ + pseudoAssign $ flip TRealLiteral "10.5e2" + + it "lexes real (2)" $ + shouldBe' (collectF90 "i = 10.") $ + pseudoAssign $ flip TRealLiteral "10." + + it "lexes real (3)" $ + shouldBe' (collectF90 "i = .42") $ + pseudoAssign $ flip TRealLiteral ".42" + + it "lexes real (3)" $ + shouldBe' (collectF90 "i = 42d-3") $ + pseudoAssign $ flip TRealLiteral "42d-3" + + it "resolves disambiguity when xxx. follows relational operator" $ + shouldBe' (collectF90 "if (10.EQ. 20)") $ + fmap ($u) [ TIf, TLeftPar, flip TIntegerLiteral "10" + , TOpEQ, flip TIntegerLiteral "20" + , TRightPar, TEOF ] + + describe "Continuation" $ do + it "Single continuation char without space" $ + shouldBe' (collectF90 "i = &\n42") $ + pseudoAssign $ flip TIntegerLiteral "42" + + it "Single continuation char with space" $ + shouldBe' (collectF90 "i = & \n \t 42") $ + pseudoAssign $ flip TIntegerLiteral "42" + + it "Double continuation (1)" $ + shouldBe' (collectF90 "i = &\n & 42") $ + pseudoAssign $ flip TIntegerLiteral "42" + + it "Double continuation (2)" $ + shouldBe' (collectF90 "i = 4&\n &2") $ + pseudoAssign $ flip TIntegerLiteral "42" + + it "Continuation with comment" $ + shouldBe' (collectF90 "i = 4&\n ! hello\n &2") $ + pseudoAssign $ flip TIntegerLiteral "42" + + it "Continuation with inline comment" $ + shouldBe' (collectF90 "i = & ! hi \n 42") $ + pseudoAssign $ flip TIntegerLiteral "42" + + describe "Comment" $ do + it "Full line comment" $ + shouldBe' (collectF90 "! = & ! hi \n") $ + ($u) <$> [ flip TComment " = & ! hi ", TNewline , TEOF ] + + it "Inline comment" $ + shouldBe' (collectF90 "i = 10 ! = & ! hi \n") $ + ($u) <$> [ flip TId "i", TOpAssign + , flip TIntegerLiteral "10" + , flip TComment " = & ! hi ", TNewline , TEOF ] + it "Empty comment" $ + shouldBe' (collectF90 "!\n") $ + ($u) <$> [ flip TComment "", TNewline , TEOF ] diff --git a/test/Language/Fortran/Parser/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Fortran2003Spec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran2003Spec.hs @@ -0,0 +1,9 @@ +module Language.Fortran.Parser.Fortran2003Spec where + +import Test.Hspec + +spec :: Spec +spec = + describe "Fortran 2003 Parser" $ do + it "TODO" $ do + pending diff --git a/test/Language/Fortran/Parser/Fortran2008Spec.hs b/test/Language/Fortran/Parser/Fortran2008Spec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran2008Spec.hs @@ -0,0 +1,9 @@ +module Language.Fortran.Parser.Fortran2008Spec where + +import Test.Hspec + +spec :: Spec +spec = + describe "Fortran 2008 Parser" $ do + it "TODO" $ do + pending diff --git a/test/Language/Fortran/Parser/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fortran66Spec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran66Spec.hs @@ -0,0 +1,221 @@ +module Language.Fortran.Parser.Fortran66Spec(spec) where + +import Test.Hspec +import TestUtil + +import Control.Monad.State.Lazy +import Prelude hiding (LT) + +import Language.Fortran.Parser.Fortran66 +import Language.Fortran.Lexer.FixedForm +import Language.Fortran.ParserMonad +import Language.Fortran.AST +import qualified Data.ByteString.Char8 as B + +import Data.Typeable + +eParser :: String -> Expression () +eParser sourceCode = + case evalParse statementParser parseState of + (StExpressionAssign _ _ _ e) -> e + where + paddedSourceCode = B.pack $ " a = " ++ sourceCode + parseState = initParseState paddedSourceCode Fortran66 "" + +sParser :: String -> Statement () +sParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran66 "" + +spec :: Spec +spec = + describe "Fortran 66 Parser" $ do + describe "Expressions" $ do + describe "Arithmetic expressions" $ do + describe "Real numbers" $ do + it "parses 'hello" $ do + let expectedExp = varGen "hello" + eParser "hello" `shouldBe'` expectedExp + + it "parses '3.14" $ do + let expectedExp = ExpValue () u (ValReal "3.14") + eParser "3.14" `shouldBe'` expectedExp + + it "parses '.14" $ do + let expectedExp = ExpValue () u (ValReal ".14") + eParser ".14" `shouldBe'` expectedExp + + it "parses '3." $ do + let expectedExp = ExpValue () u (ValReal "3.") + eParser "3." `shouldBe'` expectedExp + + it "parses '3E12" $ do + let expectedExp = ExpValue () u (ValReal "3e12") + eParser "3E12" `shouldBe'` expectedExp + + it "parses '3.14d12" $ do + let expectedExp = ExpValue () u (ValReal "3.14d12") + eParser "3.14d12" `shouldBe'` expectedExp + + it "parses '.14d+1" $ do + let expectedExp = ExpValue () u (ValReal ".14d+1") + eParser ".14d+1" `shouldBe'` expectedExp + + it "parses '3'" $ do + let expectedExp = intGen 3 + eParser "3" `shouldBe'` expectedExp + + it "parses '-3'" $ do + let expectedExp = ExpUnary () u Minus $ intGen 3 + eParser "-3" `shouldBe'` expectedExp + + it "parses '3 + 2'" $ do + let expectedExp = ExpBinary () u Addition (intGen 3) (intGen 2) + eParser "3 + 2" `shouldBe'` expectedExp + + it "parses '3 + -2'" $ do + let expectedExp = ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2)) + eParser "3 + -2" `shouldBe'` expectedExp + + it "parses '3 + -2 + 42'" $ do + let expectedExp = ExpBinary () u Addition (ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))) (intGen 42) + eParser "3 + -2 + 42" `shouldBe'` expectedExp + + it "parses 'f(y, 24)'" $ do + let subs = [ IxSingle () u Nothing $ varGen "y", ixSinGen 24 ] + let expectedExp = ExpSubscript () u (varGen "f") (fromList () subs) + eParser "f(y, 24)" `shouldBe'` expectedExp + + it "parses '3 + 4 * 12'" $ do + let expectedExp = ExpBinary () u Addition (intGen 3) (ExpBinary () u Multiplication (intGen 4) (intGen 12)) + eParser "3 + 4 * 12" `shouldBe'` expectedExp + + describe "Logical expressions" $ + it "parses '.true. .and. .false.'" $ do + let expectedExp = ExpBinary () u And valTrue valFalse + eParser ".true. .and. .false." `shouldBe'` expectedExp + + describe "Relational expressions" $ + it "parses '(3 * 2) .lt. 42'" $ do + let expectedExp = ExpBinary () u LT (ExpBinary () u Multiplication (intGen 3) (intGen 2)) (intGen 42) + eParser "(3 * 2) .lt. 42" `shouldBe'` expectedExp + + describe "Other expressions" $ + it "parses 'a(2 * x - 3, 10)'" $ do + let firstEl = ExpBinary () u Subtraction (ExpBinary () u Multiplication (intGen 2) (varGen "x")) (intGen 3) + expectedExp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing firstEl, ixSinGen 10]) + eParser "a(2 * x - 3, 10)" `shouldBe'` expectedExp + + describe "Statements" $ do + it "parses 'EXTERNAL f, g, h'" $ do + let procGen s = ExpValue () u (ValVariable s) + let expectedSt = StExternal () u (AList () u [procGen "f", procGen "g", procGen "h"]) + sParser " EXTERNAL f, g, h" `shouldBe'` expectedSt + + it "parses 'COMMON a, b'" $ do + let comGr = CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ]) + let st = StCommon () u (AList () u [ comGr ]) + sParser " COMMON a, b" `shouldBe'` st + + it "parses 'COMMON // a, b /hello/ x, y, z'" $ do + let comGrs = [ CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ]) + , CommonGroup () u (Just $ varGen "hello") (AList () u [ varGen "x", varGen "y", varGen "z" ]) ] + let st = StCommon () u (AList () u comGrs) + sParser " COMMON // a, b /hello/ x, y, z" `shouldBe'` st + + it "parses 'EQUIVALENCE (a,b), (x,y,z)'" $ do + let ls = [ AList () u [varGen "a", varGen "b"] + , AList () u [varGen "x", varGen "y", varGen "z"] ] + let st = StEquivalence () u (AList () u ls) + sParser " EQUIVALENCE (a,b), (x,y,z)" `shouldBe'` st + + it "parses 'DATA a/1,2,3/,x/42/'" $ do + let dGrs = [ DataGroup () u (AList () u [varGen "a"]) (AList () u [intGen 1, intGen 2, intGen 3]) + , DataGroup () u (AList () u [varGen "x"]) (AList () u [intGen 42]) ] + let st = StData () u $ AList () u dGrs + sParser " DATA a/1,2,3/, x/42/" `shouldBe'` st + + describe "FORMAT" $ do + it "parses 'FORMAT ()'" $ do + let expectedSt = StFormatBogus () u "()" + sParser " FORMAT ()" `shouldBe'` expectedSt + + it "parses 'FORMAT (///)'" $ do + let expectedSt = StFormatBogus () u "(///)" + sParser " FORMAT (///)" `shouldBe'` expectedSt + + it "parses 'FORMAT (2i5/5hhello)'" $ do + let expectedSt = StFormatBogus () u "(2i5/5hhello)" + sParser " FORMAT (2i5/5hhello)" `shouldBe'` expectedSt + + it "parses 'FORMAT (/(i5))'" $ do + let expectedSt = StFormatBogus () u "(/(i5))" + sParser " FORMAT (/(i5))" `shouldBe'` expectedSt + + describe "CALL" $ do + it "parses 'CALL me" $ do + let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) Nothing + sParser " CALL me" `shouldBe'` expectedSt + + it "parses 'CALL me(baby)" $ do + let args = AList () u [ Argument () u Nothing $ varGen "baby" ] + let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) $ Just args + sParser " CALL me(baby)" `shouldBe'` expectedSt + + it "parses 'stop'" $ do + let expectedSt = StStop () u Nothing + sParser " stop" `shouldBe'` expectedSt + + it "parses 'integer i, j(2,2), k'" $ do + let dimDecls = replicate 2 $ DimensionDeclarator () u Nothing (Just $ intGen 2) + declarators = [ DeclVariable () u (varGen "i") Nothing Nothing + , DeclArray () u (varGen "j") (AList () u dimDecls) Nothing Nothing + , DeclVariable () u (varGen "k") Nothing Nothing ] + st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ AList () u declarators + sParser " integer i, j(2,2), k" `shouldBe'` st + + let controlPairs = AList () u [ ControlPair () u Nothing (intGen 6), ControlPair () u Nothing (labelGen 10) ] + let writeSt = StWrite () u controlPairs (Just $ AList () u [ varGen "i" ]) + + describe "WRITE" $ do + it "parses 'write (6)'" $ do + let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) Nothing + sParser " write (6)" `shouldBe'` expectedSt + + it "parses 'write (6) i'" $ do + let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) (Just $ AList () u [ varGen "i" ]) + sParser " write (6) i" `shouldBe'` expectedSt + + it "parses 'write (6,10) i'" $ + sParser " write (6,10) i" `shouldBe'` writeSt + + describe "IF" $ do + it "parses 'if (10 .LT. x) write (6,10) i'" $ do + let cond = ExpBinary () u LT (intGen 10) (varGen "x") + let expectedSt = StIfLogical () u cond writeSt + sParser " if (10 .LT. x) write (6,10) i" `shouldBe'` expectedSt + + it "parses 'if (10 - 5) 10, 20, 30'" $ do + let cond = ExpBinary () u Subtraction (intGen 10) (intGen 5) + let expectedSt = StIfArithmetic () u cond (labelGen 10) (labelGen 20) (labelGen 30) + sParser " if (10 - 5) 10, 20, 30" `shouldBe'` expectedSt + + it "parses 'IF (IY) 5,6,6" $ do + let expectedSt = StIfArithmetic () u (varGen "iy") (labelGen 5) (labelGen 6) (labelGen 6) + sParser " IF (IY) 5,6,6" `shouldBe'` expectedSt + + describe "ASSIGNMENT" $ do + it "parses 'f = 1'" $ do + let expectedSt = StExpressionAssign () u (varGen "f") (intGen 1) + sParser " f = 1" `shouldBe'` expectedSt + + it "parses 'f = a(1,2)'" $ do + let indicies = fromList () [ ixSinGen 1, ixSinGen 2 ] + let rhs = ExpSubscript () u (varGen "a") indicies + let expectedSt = StExpressionAssign () u (varGen "f") rhs + sParser " f = a(1,2)" `shouldBe'` expectedSt + + it "parses 'do 42 i = 10, 1, 1'" $ do + let st = StExpressionAssign () u (varGen "i") (intGen 10) + let doSpec = DoSpecification () u st (intGen 1) (Just $ intGen 1) + let expectedSt = StDo () u Nothing (Just $ labelGen 42) (Just doSpec) + sParser " do 42 i = 10, 1, 1" `shouldBe'` expectedSt diff --git a/test/Language/Fortran/Parser/Fortran77Spec.hs b/test/Language/Fortran/Parser/Fortran77Spec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran77Spec.hs @@ -0,0 +1,306 @@ +module Language.Fortran.Parser.Fortran77Spec where + +import Test.Hspec +import TestUtil + +import Language.Fortran.Parser.Fortran77 +import Language.Fortran.Lexer.FixedForm (initParseState) +import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe) +import Language.Fortran.AST +import qualified Data.ByteString.Char8 as B + +eParser :: String -> Expression () +eParser sourceCode = + case evalParse statementParser parseState of + (StExpressionAssign _ _ _ e) -> e + where + paddedSourceCode = B.pack $ " a = " ++ sourceCode + parseState = initParseState paddedSourceCode Fortran77 "" + +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 new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran90Spec.hs @@ -0,0 +1,538 @@ +module Language.Fortran.Parser.Fortran90Spec (spec) where + +import Prelude hiding (GT) + +import TestUtil +import Test.Hspec + +import Language.Fortran.AST +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FreeForm +import Language.Fortran.Parser.Fortran90 +import qualified Data.List as List +import qualified Data.ByteString.Char8 as B + +eParser :: String -> Expression () +eParser sourceCode = + case evalParse statementParser parseState of + (StExpressionAssign _ _ _ e) -> e + where + paddedSourceCode = B.pack $ " a = " ++ sourceCode + parseState = initParseState paddedSourceCode Fortran90 "" + +sParser :: String -> Statement () +sParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran90 "" + +fParser :: String -> ProgramUnit () +fParser sourceCode = + evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "" + +{- Useful for parser debugging; Lexes the given source code. +fTok :: String -> [Token] +fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode +-} + +{- + - Given a list of values, find every combination of those values: + - combination [1,2] = [[], [1], [2], [1,2], [2,1]] + -} +combination :: [a] -> [[a]] +combination = foldr ((++) . List.permutations) [] . List.subsequences + +spec :: Spec +spec = + describe "Fortran 90 Parser" $ do + describe "Function" $ do + let puFunction = PUFunction () u + let fType = Nothing + let fOpt = None () u False + let fName = "f" + let fArgs = Nothing + let fRes = Nothing + let fBody = [] + let fSub = Nothing + + describe "End" $ do + it "parses simple functions ending with \"end function [function name]\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses simple functions ending with \"end\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end" ] + fParser fStr `shouldBe'` expected + + it "parses simple functions ending with \"end function\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end function" ] + fParser fStr `shouldBe'` expected + + + it "parses functions with return type specs" $ do + let fType = Just $ TypeSpec () u TypeInteger Nothing + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["integer function f()" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses recursive functions" $ do + let fOpt = None () u True + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["recursive function f()", "end"] + fParser fStr `shouldBe'` expected + + + it "parses functions with a list of arguments" $ do + let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f(x, y, z)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses functions with a result variable" $ do + let fRes = Just $ varGen "i" + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f() result(i)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses functions with function bodies" $ do + let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + let f2 = StExpressionAssign () u (varGen "i") decrementRHS + let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses complex functions" $ do + let fType = Just $ TypeSpec () u TypeInteger Nothing + let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + let fRes = Just $ varGen "i" + let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + let f2 = StExpressionAssign () u (varGen "i") decrementRHS + let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines [ "integer function f(x, y, z) result(i)" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + describe "Expression" $ do + it "parses logial literals with kind" $ do + let expected = ExpValue () u (ValLogical ".true._kind") + eParser ".true._kind" `shouldBe'` expected + + it "parses array initialisation exp" $ do + let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ] + eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list + + describe "Custom operator" $ do + let unOp = UnCustom ".inverse." + let unExp = ExpUnary () u unOp $ intGen 42 + + it "parses unary custom operator" $ + eParser ".inverse. 42" `shouldBe'` unExp + + let binOp = BinCustom ".xor." + it "parses binary custom operator" $ do + let expected = ExpBinary () u binOp (intGen 24) (intGen 42) + eParser "24 .xor. 42" `shouldBe'` expected + + it "parses mixed unary custom operator" $ do + let binExp = ExpBinary () u binOp unExp (intGen 24) + eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp + + it "parses data ref" $ do + let range = fromList () [ IxSingle () u Nothing $ intGen 10 ] + let sub = ExpSubscript () u (varGen "y") range + let innerRefExp = ExpDataRef () u (varGen "x") sub + let exp = ExpDataRef () u innerRefExp (varGen "z") + eParser "x % y(10) % z" `shouldBe'` exp + + it "parses section subscript" $ do + let range = [ IxSingle () u Nothing $ intGen 10 + , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2) + , IxSingle () u Nothing $ varGen "y" ] + let exp = ExpSubscript () u (varGen "x") (fromList () range) + eParser "x (10, : 1 : 2, y)" `shouldBe'` exp + + describe "Statement" $ do + it "data ref assignment" $ do + let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ] + let subs = ExpSubscript () u (varGen "x") indicies + let lhs = ExpDataRef () u subs (varGen "y") + let st = StExpressionAssign () u lhs (intGen 1) + sParser "x(1) % y = 1" `shouldBe'` st + + it "parses pause statements" $ do + let stPause = StPause () u Nothing + let stStr = "PAUSE" + sParser stStr `shouldBe'` stPause + + it "parses pause statements with expression" $ do + let stPause = StPause () u (Just (strGen "MESSAGE")) + let stStr = "PAUSE \"MESSAGE\"" + sParser stStr `shouldBe'` stPause + + it "parses declaration with attributes" $ do + let typeSpec = TypeSpec () u TypeReal Nothing + let attrs = AList () u [ AttrExternal () u + , AttrIntent () u Out + , AttrDimension () u $ AList () u + [ DimensionDeclarator () u + (Just $ intGen 3) (Just $ intGen 10) + ] + ] + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing + , DeclVariable () u (varGen "y") Nothing Nothing ] + let expected = StDeclaration () u typeSpec (Just attrs) declarators + let stStr = "real, external, intent (out), dimension (3:10) :: x, y" + sParser stStr `shouldBe'` expected + + it "parses declaration with old syntax" $ do + let typeSpec = TypeSpec () u TypeLogical Nothing + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing + , DeclVariable () u (varGen "y") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "logical x, y" + sParser stStr `shouldBe'` expected + + it "parses declaration with initialisation" $ do + let typeSpec = TypeSpec () u TypeComplex Nothing + let init = ExpValue () u (ValComplex (intGen 24) (realGen 42.0)) + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing (Just init) ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "complex :: x = (24, 42.0)" + sParser stStr `shouldBe'` expected + + it "parses declaration of custom type" $ do + let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "type (MeineType) :: x" + sParser stStr `shouldBe'` expected + + it "parses declaration type with kind selector" $ do + let selector = Selector () u Nothing (Just $ varGen "hello") + let typeSpec = TypeSpec () u TypeInteger (Just selector) + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "integer (hello) :: x" + sParser stStr `shouldBe'` expected + + it "parses intent statement" $ do + let stStr = "intent (inout) :: a" + let expected = StIntent () u InOut (fromList () [ varGen "a" ]) + sParser stStr `shouldBe'` expected + + it "parses optional statement" $ do + let stStr = "optional x" + let expected = StOptional () u (fromList () [ varGen "x" ]) + sParser stStr `shouldBe'` expected + + it "parses public statement" $ do + let stStr = "public :: x" + let expected = StPublic () u (Just $ fromList () [ varGen "x" ]) + sParser stStr `shouldBe'` expected + + it "parses public assignment" $ do + let expected = StPublic () u (Just $ fromList () [ assVal ]) + sParser "public :: assignment (=)" `shouldBe'` expected + + it "parses private statement" $ + sParser "private" `shouldBe'` StPrivate () u Nothing + + it "parses private operator" $ do + let expected = StPrivate () u (Just $ fromList () [ opGen "*" ]) + sParser "private operator ( * )" `shouldBe'` expected + + it "parses save statement" $ do + let list = [ varGen "hello", varGen "bye" ] + let expected = StSave () u (Just $ fromList () list) + let stStr = "save /hello/, bye" + sParser stStr `shouldBe'` expected + + it "parses parameter statement" $ do + let ass1 = DeclVariable () u (varGen "x") Nothing (Just $ intGen 10) + let ass2 = DeclVariable () u (varGen "y") Nothing (Just $ intGen 20) + let expected = StParameter () u (fromList () [ ass1, ass2 ]) + sParser "parameter (x = 10, y = 20)" `shouldBe'` expected + + describe "Implicit" $ do + it "parses implicit none" $ do + let st = StImplicit () u Nothing + sParser "implicit none" `shouldBe'` st + + it "parses implicit with single" $ do + let typeSpec = TypeSpec () u TypeCharacter Nothing + let impEls = [ ImpCharacter () u "k" ] + let impLists = [ ImpList () u typeSpec (fromList () impEls) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit character (k)" `shouldBe'` st + + it "parses implicit with range" $ do + let typeSpec = TypeSpec () u TypeLogical Nothing + let impEls = [ ImpRange () u "x" "z" ] + let impLists = [ ImpList () u typeSpec (fromList () impEls) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit logical (x-z)" `shouldBe'` st + + it "parses implicit statement" $ do + let typeSpec1 = TypeSpec () u TypeCharacter Nothing + let typeSpec2 = TypeSpec () u TypeInteger Nothing + let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ] + let impEls2 = [ ImpRange () u "x" "z" ] + let impLists = [ ImpList () u typeSpec1 (fromList () impEls1) + , ImpList () u typeSpec2 (fromList () impEls2) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st + + describe "Data" $ do + it "parses vanilla" $ do + let nlist = fromList () [ varGen "x", varGen "y" ] + let vlist = fromList () [ intGen 1, intGen 2 ] + let list = [ DataGroup () u nlist vlist ] + let expected = StData () u (fromList () list) + let stStr = "data x,y/1,2/" + sParser stStr `shouldBe'` expected + + describe "Delimeter" $ do + let [ nlist1, vlist1 ] = + map (fromList () . return) [ varGen "x", intGen 1 ] + let [ nlist2, vlist2 ] = + map (fromList () . return) [ varGen "y", intGen 2 ] + let list = [ DataGroup () u nlist1 vlist1 + , DataGroup () u nlist2 vlist2 ] + let expected = StData () u (fromList () list) + + it "parses comma delimited init groups" $ + sParser "data x/1/, y/2/" `shouldBe'` expected + + it "parses non-comma delimited init groups" $ + sParser "data x/1/ y/2/" `shouldBe'` expected + + describe "Namelist" $ do + let groupNames = [ ExpValue () u (ValVariable "something") + , ExpValue () u (ValVariable "other") ] + let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + , fromList () [ varGen "y" ] ] + let st = StNamelist () u $ + fromList () [ Namelist () u (head groupNames) (head itemss) + , Namelist () u (last groupNames) (last itemss) ] + + it "parses namelist statement (comma delimited) (1)" $ + sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st + + it "parses namelist statement (2)" $ + sParser "namelist /something/a,b,c/other/y" `shouldBe'` st + + describe "Common" $ do + let commonNames = [ ExpValue () u (ValVariable "something") + , ExpValue () u (ValVariable "other") ] + let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + , fromList () [ varGen "y" ] ] + let st = StCommon () u $ fromList () + [ CommonGroup () u Nothing (fromList () [ varGen "q" ]) + , CommonGroup () u (Just $ head commonNames) (head itemss) + , CommonGroup () u (Just $ last commonNames) (last itemss) ] + + it "parses common statement (comma delimited) (1)" $ + sParser "common q /something/a,b,c, /other/y" `shouldBe'` st + + it "parses common statement (2)" $ + sParser "common q /something/a,b,c /other/y" `shouldBe'` st + + it "parses equivalence statement" $ do + let eqALists = fromList () + [ fromList () + [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ] + in ExpSubscript () u (varGen "a") indicies + , varGen "x" + ] + , fromList () + [ varGen "y" + , varGen "z" + , let indicies = fromList () [ IxRange () u (Just $ intGen 1) + (Just $ intGen 42) + Nothing ] + in ExpSubscript () u (varGen "d") indicies + ] + ] + let st = StEquivalence () u eqALists + sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st + + describe "Dynamic allocation" $ do + it "parses allocate statement" $ do + let controlPair = ControlPair () u (Just "stat") (varGen "a") + let allocs = fromList () + [ varGen "x" + , ExpDataRef () u (varGen "st") (varGen "part") + ] + let s = StAllocate () u allocs (Just controlPair) + sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s + + it "parses deallocate statement" $ do + let allocs = fromList () + [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ] + in ExpSubscript () u (varGen "smt") indicies + ] + let s = StDeallocate () u allocs Nothing + sParser "deallocate (smt ( 20 ))" `shouldBe'` s + + it "parses nullify statement" $ do + let s = StNullify () u (fromList () [ varGen "x" ]) + sParser "nullify (x)" `shouldBe'` s + + it "parses pointer assignment" $ do + let src = ExpDataRef () u (varGen "x") (varGen "y") + let st = StPointerAssign () u src (varGen "exp") + sParser "x % y => exp" `shouldBe'` st + + describe "Where" $ do + it "parses where statement" $ do + let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp") + let pred = ExpBinary () u GT (varGen "temp") (intGen 100) + let assignment = StExpressionAssign () u (varGen "temp") exp + let st = StWhere () u pred assignment + sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st + + describe "Where block" $ do + it "parses where construct statement" $ + sParser "where (.true.)" `shouldBe'` StWhereConstruct () u valTrue + + it "parses elsewhere statement" $ + sParser "elsewhere" `shouldBe'` StElsewhere () u + + it "parses endwhere statement" $ + sParser "endwhere" `shouldBe'` StEndWhere () u + + describe "If" $ do + it "parses if-then statement" $ + sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse + + it "parses if-then statement with construct name" $ do + let st = StIfThen () u (Just "my_if") valFalse + sParser "my_if: if (.false.) then" `shouldBe'` st + + it "parses else statement" $ + sParser "else" `shouldBe'` StElse () u Nothing + + it "parses else-if statement" $ + sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue + + it "parses end if statement" $ + sParser "end if" `shouldBe'` StEndif () u Nothing + + it "parses logical if statement" $ do + let assignment = StExpressionAssign () u (varGen "a") (varGen "b") + let stIf = StIfLogical () u valTrue assignment + sParser "if (.true.) a = b" `shouldBe'` stIf + + it "parses arithmetic if statement" $ do + let stIf = StIfArithmetic () u (varGen "x") (intGen 1) + (intGen 2) + (intGen 3) + sParser "if (x) 1, 2, 3" `shouldBe'` stIf + + describe "Case" $ do + it "parses select case statement" $ do + let st = StSelectCase () u Nothing (varGen "n") + sParser "select case (n)" `shouldBe'` st + + it "parses select case statement with construct name" $ do + let st = StSelectCase () u (Just "case") (varGen "n") + sParser "case: select case (n)" `shouldBe'` st + + it "parses case statement" $ do + let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ] + sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges) + + it "parses case statement" $ + sParser "case default" `shouldBe'` StCase () u Nothing Nothing + + it "parses end select statement" $ do + let st = StEndcase () u (Just "name") + sParser "end select name" `shouldBe'` st + + describe "Do" $ do + it "parses do statement with label" $ do + let assign = StExpressionAssign () u (varGen "i") (intGen 0) + let doSpec = DoSpecification () u assign (intGen 42) Nothing + let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) + sParser "do 24, i = 0, 42" `shouldBe'` st + + it "parses do statement without label" $ do + let assign = StExpressionAssign () u (varGen "i") (intGen 0) + let doSpec = DoSpecification () u assign (intGen 42) Nothing + let st = StDo () u Nothing Nothing (Just doSpec) + sParser "do i = 0, 42" `shouldBe'` st + + it "parses infinite do" $ do + let st = StDo () u Nothing Nothing Nothing + sParser "do" `shouldBe'` st + + it "parses end do statement" $ do + let st = StEnddo () u (Just "constructor") + sParser "end do constructor" `shouldBe'` st + + it "parses end do while statement" $ do + let st = StDoWhile () u (Just "name") Nothing valTrue + sParser "name: do while (.true.)" `shouldBe'` st + + describe "Goto" $ do + it "parses vanilla goto" $ do + let st = StGotoUnconditional () u (intGen 999) + sParser "goto 999" `shouldBe'` st + + it "parses computed goto" $ do + let list = fromList () [ intGen 10, intGen 20, intGen 30 ] + let st = StGotoComputed () u list (intGen 20) + sParser "goto (10, 20, 30) 20" `shouldBe'` st + + it "parses assigned goto" $ do + let list = fromList () [ intGen 10, intGen 20, intGen 30 ] + let st = StGotoAssigned () u (varGen "i") (Just list) + sParser "goto i, (10, 20, 30)" `shouldBe'` st + + it "parses label assignment" $ do + let st = StLabelAssign () u (intGen 20) (varGen "l") + sParser "assign 20 to l" `shouldBe'` st + + describe "IO" $ do + it "parses vanilla print" $ do + let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ]) + sParser "print *, hex" `shouldBe'` st + + it "parses write with implied do" $ do + let cp1 = ControlPair () u Nothing (intGen 10) + let cp2 = ControlPair () u (Just "format") (varGen "x") + let ciList = fromList () [ cp1, cp2 ] + let assign = StExpressionAssign () u (varGen "i") (intGen 1) + let doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) + let alist = fromList () [ varGen "i", varGen "j" ] + let outList = fromList () [ ExpImpliedDo () u alist doSpec ] + let st = StWrite () u ciList (Just outList) + sParser "write (10, FORMAT = x) (i, j, i = 1, 42, 2)" `shouldBe'` st + + it "parses use statement" $ do + let renames = fromList () + [ UseRename () u (varGen "sprod") (varGen "prod") + , UseRename () u (varGen "a") (varGen "b") ] + let st = StUse () u (varGen "stats_lib") Permissive (Just renames) + sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/Fortran95Spec.hs @@ -0,0 +1,584 @@ +module Language.Fortran.Parser.Fortran95Spec (spec) where + +import Prelude hiding (GT, EQ, NE) + +import TestUtil +import Test.Hspec +import Control.Exception (evaluate) + +import Language.Fortran.AST +import Language.Fortran.ParserMonad +import Language.Fortran.Lexer.FreeForm +import Language.Fortran.Parser.Fortran95 +import qualified Data.List as List +import Data.Foldable(forM_) +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 Fortran95 "" + +sParser :: String -> Statement () +sParser sourceCode = + evalParse statementParser $ initParseState (B.pack sourceCode) Fortran95 "" + +fParser :: String -> ProgramUnit () +fParser sourceCode = + evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "" + +{- Useful for parser debugging; Lexes the given source code. +fTok :: String -> [Token] +fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode +-} + +{- + - Given a list of values, find every combination of those values: + - combination [1,2] = [[], [1], [2], [1,2], [2,1]] + -} +combination :: [a] -> [[a]] +combination = foldr ((++) . List.permutations) [] . List.subsequences + +spec :: Spec +spec = + describe "Fortran 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 + + describe "End" $ do + it "parses simple functions ending with \"end function [function name]\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses simple functions ending with \"end\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end" ] + fParser fStr `shouldBe'` expected + + it "parses simple functions ending with \"end function\"" $ do + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , "end function" ] + fParser fStr `shouldBe'` expected + + + it "parses functions with return type specs" $ do + let fType = Just $ TypeSpec () u TypeInteger Nothing + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["integer function f()" + , "end function f" ] + fParser fStr `shouldBe'` expected + + 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) ] + + 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 + ) + + it "parses functions with a list of arguments" $ do + let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f(x, y, z)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses functions with a result variable" $ do + let fRes = Just $ varGen "i" + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f() result(i)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses functions with function bodies" $ do + let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + let f2 = StExpressionAssign () u (varGen "i") decrementRHS + let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines ["function f()" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + it "parses complex functions" $ do + let fType = Just $ TypeSpec () u TypeInteger Nothing + let fArgs = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ] + let fRes = Just $ varGen "i" + let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1) + let f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ]) + let f2 = StExpressionAssign () u (varGen "i") decrementRHS + let fBody = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ] + let expected = puFunction fType fOpt fName fArgs fRes fBody fSub + let fStr = init $ unlines [ "integer function f(x, y, z) result(i)" + , " print *, i" + , " i = (i - 1)" + , "end function f" ] + fParser fStr `shouldBe'` expected + + describe "Expression" $ do + it "parses logial literals with kind" $ do + let expected = ExpValue () u (ValLogical ".true._kind") + eParser ".true._kind" `shouldBe'` expected + + it "parses array initialisation exp" $ do + let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ] + eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list + + describe "Custom operator" $ do + let unOp = UnCustom ".inverse." + let unExp = ExpUnary () u unOp $ intGen 42 + + it "parses unary custom operator" $ + eParser ".inverse. 42" `shouldBe'` unExp + + let binOp = BinCustom ".xor." + it "parses binary custom operator" $ do + let expected = ExpBinary () u binOp (intGen 24) (intGen 42) + eParser "24 .xor. 42" `shouldBe'` expected + + it "parses mixed unary custom operator" $ do + let binExp = ExpBinary () u binOp unExp (intGen 24) + eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp + + it "parses data ref" $ do + let range = fromList () [ IxSingle () u Nothing $ intGen 10 ] + let sub = ExpSubscript () u (varGen "y") range + let innerRefExp = ExpDataRef () u (varGen "x") sub + let exp = ExpDataRef () u innerRefExp (varGen "z") + eParser "x % y(10) % z" `shouldBe'` exp + + it "parses section subscript" $ do + let range = [ IxSingle () u Nothing $ intGen 10 + , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2) + , IxSingle () u Nothing $ varGen "y" ] + let exp = ExpSubscript () u (varGen "x") (fromList () range) + eParser "x (10, : 1 : 2, y)" `shouldBe'` exp + + describe "Statement" $ do + it "data ref assignment" $ do + let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ] + let subs = ExpSubscript () u (varGen "x") indicies + let lhs = ExpDataRef () u subs (varGen "y") + let st = StExpressionAssign () u lhs (intGen 1) + sParser "x(1) % y = 1" `shouldBe'` st + + it "doesn't parse assign statements" $ do + let stStr = "ASSIGN 1 \"LABEL\"" + evaluate (sParser stStr) `shouldThrow` anyIOException + + 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 + , AttrIntent () u Out + , AttrDimension () u $ AList () u + [ DimensionDeclarator () u + (Just $ intGen 3) (Just $ intGen 10) + ] + ] + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing + , DeclVariable () u (varGen "y") Nothing Nothing ] + let expected = StDeclaration () u typeSpec (Just attrs) declarators + let stStr = "real, external, intent (out), dimension (3:10) :: x, y" + sParser stStr `shouldBe'` expected + + it "parses declaration with old syntax" $ do + let typeSpec = TypeSpec () u TypeLogical Nothing + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing + , DeclVariable () u (varGen "y") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "logical x, y" + sParser stStr `shouldBe'` expected + + it "parses declaration with initialisation" $ do + let typeSpec = TypeSpec () u TypeComplex Nothing + let init = ExpValue () u (ValComplex (intGen 24) (realGen 42.0)) + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing (Just init) ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "complex :: x = (24, 42.0)" + sParser stStr `shouldBe'` expected + + it "parses declaration of custom type" $ do + let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "type (MeineType) :: x" + sParser stStr `shouldBe'` expected + + it "parses declaration type with kind selector" $ do + let selector = Selector () u Nothing (Just $ varGen "hello") + let typeSpec = TypeSpec () u TypeInteger (Just selector) + let declarators = AList () u + [ DeclVariable () u (varGen "x") Nothing Nothing ] + let expected = StDeclaration () u typeSpec Nothing declarators + let stStr = "integer (hello) :: x" + sParser stStr `shouldBe'` expected + + it "parses intent statement" $ do + let stStr = "intent (inout) :: a" + let expected = StIntent () u InOut (fromList () [ varGen "a" ]) + sParser stStr `shouldBe'` expected + + it "parses optional statement" $ do + let stStr = "optional x" + let expected = StOptional () u (fromList () [ varGen "x" ]) + sParser stStr `shouldBe'` expected + + it "parses public statement" $ do + let stStr = "public :: x" + let expected = StPublic () u (Just $ fromList () [ varGen "x" ]) + sParser stStr `shouldBe'` expected + + it "parses public assignment" $ do + let expected = StPublic () u (Just $ fromList () [ assVal ]) + sParser "public :: assignment (=)" `shouldBe'` expected + + it "parses private statement" $ + sParser "private" `shouldBe'` StPrivate () u Nothing + + it "parses private operator" $ do + let expected = StPrivate () u (Just $ fromList () [ opGen "*" ]) + sParser "private operator ( * )" `shouldBe'` expected + + it "parses save statement" $ do + let list = [ varGen "hello", varGen "bye" ] + let expected = StSave () u (Just $ fromList () list) + let stStr = "save /hello/, bye" + sParser stStr `shouldBe'` expected + + it "parses parameter statement" $ do + let ass1 = DeclVariable () u (varGen "x") Nothing (Just $ intGen 10) + let ass2 = DeclVariable () u (varGen "y") Nothing (Just $ intGen 20) + let expected = StParameter () u (fromList () [ ass1, ass2 ]) + sParser "parameter (x = 10, y = 20)" `shouldBe'` expected + + describe "FORALL blocks" $ do + let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2) + let 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) + 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 + + 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 + sParser stStr `shouldBe'` expected + + describe "ENDFORALL statements" $ do + it "parses FORALL end statements" $ do + let stStr = "ENDFORALL" + let 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" + sParser stStr `shouldBe'` expected + + describe "Implicit" $ do + it "parses implicit none" $ do + let st = StImplicit () u Nothing + sParser "implicit none" `shouldBe'` st + + it "parses implicit with single" $ do + let typeSpec = TypeSpec () u TypeCharacter Nothing + let impEls = [ ImpCharacter () u "k" ] + let impLists = [ ImpList () u typeSpec (fromList () impEls) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit character (k)" `shouldBe'` st + + it "parses implicit with range" $ do + let typeSpec = TypeSpec () u TypeLogical Nothing + let impEls = [ ImpRange () u "x" "z" ] + let impLists = [ ImpList () u typeSpec (fromList () impEls) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit logical (x-z)" `shouldBe'` st + + it "parses implicit statement" $ do + let typeSpec1 = TypeSpec () u TypeCharacter Nothing + let typeSpec2 = TypeSpec () u TypeInteger Nothing + let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ] + let impEls2 = [ ImpRange () u "x" "z" ] + let impLists = [ ImpList () u typeSpec1 (fromList () impEls1) + , ImpList () u typeSpec2 (fromList () impEls2) ] + let st = StImplicit () u (Just $ fromList () impLists) + sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st + + describe "Data" $ do + it "parses vanilla" $ do + let nlist = fromList () [ varGen "x", varGen "y" ] + let vlist = fromList () [ intGen 1, intGen 2 ] + let list = [ DataGroup () u nlist vlist ] + let expected = StData () u (fromList () list) + let stStr = "data x,y/1,2/" + sParser stStr `shouldBe'` expected + + describe "Delimeter" $ do + let [ nlist1, vlist1 ] = + map (fromList () . return) [ varGen "x", intGen 1 ] + let [ nlist2, vlist2 ] = + map (fromList () . return) [ varGen "y", intGen 2 ] + let list = [ DataGroup () u nlist1 vlist1 + , DataGroup () u nlist2 vlist2 ] + let expected = StData () u (fromList () list) + + it "parses comma delimited init groups" $ + sParser "data x/1/, y/2/" `shouldBe'` expected + + it "parses non-comma delimited init groups" $ + sParser "data x/1/ y/2/" `shouldBe'` expected + + describe "Namelist" $ do + let groupNames = [ ExpValue () u (ValVariable "something") + , ExpValue () u (ValVariable "other") ] + let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + , fromList () [ varGen "y" ] ] + let st = StNamelist () u $ + fromList () [ Namelist () u (head groupNames) (head itemss) + , Namelist () u (last groupNames) (last itemss) ] + + it "parses namelist statement (comma delimited) (1)" $ + sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st + + it "parses namelist statement (2)" $ + sParser "namelist /something/a,b,c/other/y" `shouldBe'` st + + describe "Common" $ do + let commonNames = [ ExpValue () u (ValVariable "something") + , ExpValue () u (ValVariable "other") ] + let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ] + , fromList () [ varGen "y" ] ] + let st = StCommon () u $ fromList () + [ CommonGroup () u Nothing (fromList () [ varGen "q" ]) + , CommonGroup () u (Just $ head commonNames) (head itemss) + , CommonGroup () u (Just $ last commonNames) (last itemss) ] + + it "parses common statement (comma delimited) (1)" $ + sParser "common q /something/a,b,c, /other/y" `shouldBe'` st + + it "parses common statement (2)" $ + sParser "common q /something/a,b,c /other/y" `shouldBe'` st + + it "parses equivalence statement" $ do + let eqALists = fromList () + [ fromList () + [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ] + in ExpSubscript () u (varGen "a") indicies + , varGen "x" + ] + , fromList () + [ varGen "y" + , varGen "z" + , let indicies = fromList () [ IxRange () u (Just $ intGen 1) + (Just $ intGen 42) + Nothing ] + in ExpSubscript () u (varGen "d") indicies + ] + ] + let st = StEquivalence () u eqALists + sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st + + describe "Dynamic allocation" $ do + it "parses allocate statement" $ do + let controlPair = ControlPair () u (Just "stat") (varGen "a") + let allocs = fromList () + [ varGen "x" + , ExpDataRef () u (varGen "st") (varGen "part") + ] + let s = StAllocate () u allocs (Just controlPair) + sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s + + it "parses deallocate statement" $ do + let allocs = fromList () + [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ] + in ExpSubscript () u (varGen "smt") indicies + ] + let s = StDeallocate () u allocs Nothing + sParser "deallocate (smt ( 20 ))" `shouldBe'` s + + it "parses nullify statement" $ do + let s = StNullify () u (fromList () [ varGen "x" ]) + sParser "nullify (x)" `shouldBe'` s + + it "parses pointer assignment" $ do + let src = ExpDataRef () u (varGen "x") (varGen "y") + let st = StPointerAssign () u src (varGen "exp") + sParser "x % y => exp" `shouldBe'` st + + describe "Where" $ do + it "parses where statement" $ do + let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp") + let pred = ExpBinary () u GT (varGen "temp") (intGen 100) + let assignment = StExpressionAssign () u (varGen "temp") exp + let st = StWhere () u pred assignment + sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st + + describe "Where block" $ do + it "parses where construct statement" $ + sParser "where (.true.)" `shouldBe'` StWhereConstruct () u valTrue + + it "parses elsewhere statement" $ + sParser "elsewhere" `shouldBe'` StElsewhere () u + + it "parses endwhere statement" $ + sParser "endwhere" `shouldBe'` StEndWhere () u + + describe "If" $ do + it "parses if-then statement" $ + sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse + + it "parses if-then statement with construct name" $ do + let st = StIfThen () u (Just "my_if") valFalse + sParser "my_if: if (.false.) then" `shouldBe'` st + + it "parses else statement" $ + sParser "else" `shouldBe'` StElse () u Nothing + + it "parses else-if statement" $ + sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue + + it "parses end if statement" $ + sParser "end if" `shouldBe'` StEndif () u Nothing + + it "parses logical if statement" $ do + let assignment = StExpressionAssign () u (varGen "a") (varGen "b") + let stIf = StIfLogical () u valTrue assignment + sParser "if (.true.) a = b" `shouldBe'` stIf + + it "parses arithmetic if statement" $ do + let stIf = StIfArithmetic () u (varGen "x") (intGen 1) + (intGen 2) + (intGen 3) + sParser "if (x) 1, 2, 3" `shouldBe'` stIf + + describe "Case" $ do + it "parses select case statement" $ do + let st = StSelectCase () u Nothing (varGen "n") + sParser "select case (n)" `shouldBe'` st + + it "parses select case statement with construct name" $ do + let st = StSelectCase () u (Just "case") (varGen "n") + sParser "case: select case (n)" `shouldBe'` st + + it "parses case statement" $ do + let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ] + sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges) + + it "parses case statement" $ + sParser "case default" `shouldBe'` StCase () u Nothing Nothing + + it "parses end select statement" $ do + let st = StEndcase () u (Just "name") + sParser "end select name" `shouldBe'` st + + describe "Do" $ do + it "parses do statement with label" $ do + let assign = StExpressionAssign () u (varGen "i") (intGen 0) + let doSpec = DoSpecification () u assign (intGen 42) Nothing + let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) + sParser "do 24, i = 0, 42" `shouldBe'` st + + it "parses do statement without label" $ do + let assign = StExpressionAssign () u (varGen "i") (intGen 0) + let doSpec = DoSpecification () u assign (intGen 42) Nothing + let st = StDo () u Nothing Nothing (Just doSpec) + sParser "do i = 0, 42" `shouldBe'` st + + it "parses infinite do" $ do + let st = StDo () u Nothing Nothing Nothing + sParser "do" `shouldBe'` st + + it "parses end do statement" $ do + let st = StEnddo () u (Just "constructor") + sParser "end do constructor" `shouldBe'` st + + it "parses end do while statement" $ do + let st = StDoWhile () u (Just "name") Nothing valTrue + sParser "name: do while (.true.)" `shouldBe'` st + + describe "Goto" $ do + it "parses vanilla goto" $ do + let st = StGotoUnconditional () u (intGen 999) + sParser "goto 999" `shouldBe'` st + + it "parses computed goto" $ do + let list = fromList () [ intGen 10, intGen 20, intGen 30 ] + let st = StGotoComputed () u list (intGen 20) + sParser "goto (10, 20, 30) 20" `shouldBe'` st + + it "doesn't parse assigned goto" $ do + evaluate (sParser "goto i, (10, 20, 30)") `shouldThrow` anyIOException + + it "doesn't parse label assignment" $ do + evaluate (sParser "assign 20 to l") `shouldThrow` anyIOException + + describe "IO" $ do + it "parses vanilla print" $ do + let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ]) + sParser "print *, hex" `shouldBe'` st + + it "parses write with implied do" $ do + let cp1 = ControlPair () u Nothing (intGen 10) + let cp2 = ControlPair () u (Just "format") (varGen "x") + let ciList = fromList () [ cp1, cp2 ] + let assign = StExpressionAssign () u (varGen "i") (intGen 1) + let doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) + let alist = fromList () [ varGen "i", varGen "j" ] + let outList = fromList () [ ExpImpliedDo () u alist doSpec ] + let st = StWrite () u ciList (Just outList) + sParser "write (10, FORMAT = x) (i, j, i = 1, 42, 2)" `shouldBe'` st + + it "parses use statement" $ do + let renames = fromList () + [ UseRename () u (varGen "sprod") (varGen "prod") + , UseRename () u (varGen "a") (varGen "b") ] + let st = StUse () u (varGen "stats_lib") Permissive (Just renames) + sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/UtilsSpec.hs b/test/Language/Fortran/Parser/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/UtilsSpec.hs @@ -0,0 +1,28 @@ +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 + it "tests" $ do + 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 "-.12" `shouldBe` Just (-0.12) + readReal "1_f" `shouldBe` Just (1) + describe "readInteger" $ do + it "tests" $ do + readInteger "b'101'" `shouldBe` Just 5 + readInteger "o'22'" `shouldBe` Just 18 + readInteger "z'AF'" `shouldBe` Just 175 + readInteger "1_f" `shouldBe` Just 1 + readInteger "+123" `shouldBe` Just 123 + readInteger "-123" `shouldBe` Just (-123) diff --git a/test/Language/Fortran/ParserMonadSpec.hs b/test/Language/Fortran/ParserMonadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/ParserMonadSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +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 +vanillaParseState = ParseState + { psAlexInput = "" + , psVersion = Fortran66 + , psFilename = "" + , psParanthesesCount = ParanthesesCount 0 False + , psContext = [ ConStart ] + } + +instance Loc String where + getPos = error "Never needed" + +instance LastToken String String where + getLastToken = error "Never needed" + +data SomeInput = SomeInput { p :: Position } + +initPos :: Position +initPos = Position 5 1 2 + +initSomeInput :: SomeInput +initSomeInput = SomeInput { p = initPos } + +instance Loc SomeInput where + getPos = p + +instance LastToken SomeInput String where + getLastToken = error "Never needed" + +vanillaSomeInput :: ParseState SomeInput +vanillaSomeInput = ParseState + { psAlexInput = initSomeInput + , psVersion = Fortran66 + , psFilename = "some.f" + , psParanthesesCount = ParanthesesCount 0 False + , psContext = [ ConStart ] + } + +spec :: Spec +spec = + describe "ParserMonad" $ do + describe "Parse" $ do + it "should give out correct version" $ do + evalParse getVersion vanillaParseState `shouldBe` Fortran66 + + it "satisfies read after write equals to what is written" $ do + 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 + _exampleM = do + _ai <- getAlex + putAlex $ _ai { p = _expPosition } + getPosition + _loc = evalParse _exampleM vanillaSomeInput in + _loc `shouldBe` _expPosition + + it "getSrcSpan return correct location span" $ do + let _loc2 = Position 6 2 3 + _exampleM = do + _ai <- getAlex + _loc1 <- getPosition + putAlex $ _ai { p = _loc2 } + getSrcSpan _loc1 + _span = evalParse _exampleM vanillaSomeInput + _expectation = SrcSpan initPos _loc2 in + _span `shouldBe` _expectation + + describe "Lex" $ do + it "reads the state correctly" $ do + evalParse getAlex vanillaParseState `shouldBe` "" + + it "overrides the state correctly" $ do + 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 + ai `shouldBe` "hell" diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/PrettyPrintSpec.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fortran.PrettyPrintSpec where + +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 + +import Test.Hspec +import TestUtil + +checkAll :: forall a b c . (Out c, Data c, Data a, Data b) + => (b -> Maybe c) -> (c -> Spec) -> a -> Spec +checkAll restrict check t = + describe ("Testing on " ++ show (length inputs) ++ " nodes") + $ mapM_ check inputs + where + inputs = catMaybes [ restrict b | b <- universeBi t :: [b] ] + +samplesBase :: FilePath +samplesBase = "test" "Language" "Fortran" "samples" + +spec :: Spec +spec = + describe "Pretty printer tests" $ do + describe "Dimension declarator" $ do + it "Prints left bound dimension declarator" $ do + let dd = DimensionDeclarator () u (Just $ intGen 42) Nothing + pprint Fortran90 dd Nothing `shouldBe` "42:" + + it "Prints right bound dimension declarator" $ do + let dd = DimensionDeclarator () u Nothing (Just $ intGen 42) + pprint Fortran90 dd Nothing `shouldBe` "42" + + it "Prints bounded dimension declarator" $ do + let dd = DimensionDeclarator () u (Just $ intGen 24) (Just $ intGen 42) + pprint Fortran90 dd Nothing `shouldBe` "24:42" + + describe "Selector" $ do + it "prints Fortran 77 selector" $ do + let sel = Selector () u (Just $ intGen 42) Nothing + pprint Fortran77 sel Nothing `shouldBe` "* (42)" + + it "prints Fortran 90 selector" $ do + let sel = Selector () u (Just $ intGen 42) (Just $ intGen 24) + pprint Fortran90 sel Nothing `shouldBe` "(len=42, kind=24)" + + describe "Use" $ + it "prints renaming" $ do + let renaming = UseRename () u (varGen "x") (varGen "y") + pprint Fortran90 renaming Nothing `shouldBe` "x => y" + + describe "Control pair" $ + it "prints named control pair" $ do + let cp = ControlPair () u (Just "errno") (intGen 42) + pprint Fortran77Extended cp Nothing `shouldBe` "errno=42" + + describe "Implicit list" $ + it "prints mixed implicit lists" $ do + let typ = TypeSpec () u TypeInteger Nothing + let impEls = [ ImpCharacter () u "x" + , ImpRange () u "a" "z" + , ImpCharacter () u "o" ] + let impList = ImpList () u typ (AList () u impEls) + pprint Fortran90 impList Nothing `shouldBe` "integer (x, a-z, o)" + + describe "Common group" $ do + let globs = [ varGen "x", varGen "y", varGen "z" ] + + it "prints anonymous common group" $ do + let group = CommonGroup () u Nothing (AList () u globs) + pprint Fortran66 group Nothing `shouldBe` "//x, y, z" + + it "prints named common group" $ do + let group = CommonGroup () u (Just $ varGen "my_g") (AList () u globs) + pprint Fortran66 group Nothing `shouldBe` "/my_g/x, y, z" + + describe "Format item" $ + it "prints hollerith constant" $ do + let ed = FIHollerith () u (ValHollerith "hello darling") + pprint Fortran77 ed Nothing `shouldBe` "13hhello darling" + + 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 attrs = [ AttrIntent () u In , AttrPointer () u ] + let declList = + [ DeclVariable () u (varGen "x") Nothing (Just $ intGen 42) + , DeclVariable () u (varGen "y") (Just $ intGen 3) Nothing ] + let st = StDeclaration () u typeSpec + (Just $ AList () u attrs) + (AList () u declList) + let expect = "character (len=3), intent(in), pointer :: x = 42, y*3" + pprint Fortran90 st Nothing `shouldBe` expect + + it "prints 77 style" $ do + let typeSpec = TypeSpec () u TypeInteger Nothing + let dds = [ DimensionDeclarator () u Nothing (Just $ intGen 10) ] + let declList = + [ DeclArray () u (varGen "x") (AList () u dds) Nothing Nothing ] + let st = StDeclaration () u typeSpec Nothing (AList () u declList) + pprint Fortran77 st Nothing `shouldBe` "integer x(10)" + + describe "Intent" $ + it "prints intent statement" $ do + let exps = [ varGen "x", varGen "y" ] + let st = StIntent () u In (AList () u exps) + pprint Fortran90 st Nothing `shouldBe` "intent (in) :: x, y" + + describe "Save" $ do + it "prints lone save statement" $ do + let st = StSave () u Nothing + pprint Fortran90 st Nothing `shouldBe` "save" + + let st = StSave () u (Just $ AList () u [ varGen "x", varGen "y" ]) + + it "prints 90 style save statement with vars" $ + pprint Fortran90 st Nothing `shouldBe` "save :: x, y" + + it "prints 77 style save statement with vars" $ + pprint Fortran77Extended st Nothing `shouldBe` "save x, y" + + describe "Data" $ do + let groups = + [ DataGroup () u (AList () u [ varGen "x"]) + (AList () u [ intGen 42 ]) + , DataGroup () u (AList () u [ varGen "y"]) + (AList () u [ intGen 24 ]) ] + let st = StData () u (AList () u groups) + + it "prints 90 style data statement with multiple groups" $ + pprint Fortran90 st Nothing `shouldBe` "data x/42/, y/24/" + + it "prints 77 style data statement with multiple groups" $ + pprint Fortran77Extended st Nothing `shouldBe` "data x/42/ y/24/" + + describe "Parameter" $ + it "prints vanilla statement" $ do + let decls = [ DeclVariable () u (varGen "x") Nothing (Just $ intGen 42) + , DeclVariable () u (varGen "y") Nothing (Just $ intGen 24) + ] + let st = StParameter () u (AList () u decls) + pprint Fortran90 st Nothing `shouldBe` "parameter (x = 42, y = 24)" + + describe "Equivalence" $ + it "prints multiple equivalence groups" $ do + let equivGroups = [ AList () u [ varGen "x", varGen "y" ] + , AList () u [ varGen "z" ] ] + let st = StEquivalence () u (AList () u equivGroups) + pprint Fortran90 st Nothing `shouldBe` "equivalence (x, y), (z)" + + describe "Equivalence" $ + it "prints entry point with arguments and result specified" $ do + let aargs = AList () u [ varGen "x", varGen "y" ] + let result = varGen "z" + let entry = StEntry () u (varGen "func") (Just aargs) (Just result) + pprint Fortran90 entry Nothing `shouldBe` "entry func (x, y) result (z)" + + describe "Do" $ do + it "prints infinity do" $ do + let stDo = StDo () u Nothing Nothing Nothing + pprint Fortran90 stDo Nothing `shouldBe` "do" + + let doInit = StExpressionAssign () u (varGen "i") (intGen (-1)) + let doSpec = DoSpecification () u doInit (intGen 5) Nothing + + it "prints labeled do" $ do + let stDo = StDo () u Nothing (Just $ intGen 42) (Just doSpec) + pprint Fortran90 stDo Nothing `shouldBe` "do 42 i = -1, 5" + + it "prints named do" $ do + let stDo = StDo () u (Just "mistral") Nothing (Just doSpec) + pprint Fortran90 stDo Nothing `shouldBe` "mistral: do i = -1, 5" + + describe "If" $ do + it "prints arithmetic if" $ do + let arIf = StIfArithmetic () u (intGen 0) + (intGen 10) (intGen 20) (intGen 30) + pprint Fortran66 arIf Nothing `shouldBe` "if (0) 10, 20, 30" + + it "prints logical if" $ do + let as = StExpressionAssign () u (varGen "x") (intGen 42) + let logIf = StIfLogical () u valFalse as + pprint Fortran90 logIf Nothing `shouldBe` "if (.false.) x = 42" + + it "prints named if-then" $ do + let ifThen = StIfThen () u (Just "mistral") valTrue + pprint Fortran90 ifThen Nothing `shouldBe` "mistral: if (.true.) then" + + describe "Case" $ do + it "prints select case" $ do + let sc = StSelectCase () u Nothing (varGen "x") + pprint Fortran90 sc Nothing `shouldBe` "select case (x)" + + it "prints filled case" $ do + let caseRanges = + [ IxRange () u (Just $ intGen 0) (Just $ intGen 100) Nothing + , IxSingle () u Nothing (intGen 10) ] + let casee = StCase () u Nothing (Just $ AList () u caseRanges) + pprint Fortran90 casee Nothing `shouldBe` "case (0:100, 10)" + + it "prints named default case" $ do + let casee = StCase () u (Just "mistral") Nothing + pprint Fortran90 casee Nothing `shouldBe` "case default mistral" + + describe "Function statement" $ + it "prints function statement" $ do + let args = [ varGen "x", varGen "y" ] + let fSt = StFunction () u (varGen "pi") (AList () u args) (varGen "x") + pprint Fortran90 fSt Nothing `shouldBe` "pi(x, y) = x" + + describe "Stop" $ + it "prints stop with code" $ + pprint Fortran66 (StStop () u (Just $ intGen 1)) Nothing `shouldBe` "stop 1" + + describe "IO" $ + describe "Print" $ + it "prints vanilla print statement" $ do + let st = StPrint () u starVal (Just $ AList () u [ intGen 42 ]) + pprint Fortran90 st Nothing `shouldBe` "print *, 42" + + describe "Allocation" $ + describe "Allocate" $ + it "prints allocate statement" $ do + let pair = ControlPair () u (Just "stat") (varGen "s") + let st = StAllocate () u (AList () u [ varGen "x" ]) (Just pair) + pprint Fortran90 st Nothing `shouldBe` "allocate (x, stat=s)" + + describe "Where" $ + it "prints statement" $ do + let stAssign = StExpressionAssign () u (varGen "x") (intGen 42) + let stWhere = StWhere () u valTrue stAssign + pprint Fortran90 stWhere Nothing `shouldBe` "where (.true.) x = 42" + + describe "Use" $ + it "prints exlusive use statement" $ do + let aRenames = AList () u [ UseRename () u (varGen "x") (varGen "y") ] + let st = StUse () u (varGen "my_mod") Exclusive (Just aRenames) + pprint Fortran90 st Nothing `shouldBe` "use 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 + let body = [ BlStatement () u Nothing st1 , BlStatement () u Nothing st2 ] + + describe "Blocks" $ do + describe "Comment" $ do + let blComment = BlComment () u (Comment " si vis pacem para bellum") + + it "prints 90 style comment" $ + pprint Fortran90 blComment Nothing `shouldBe` "! si vis pacem para bellum\n" + + it "prints 66 style comment" $ + pprint Fortran66 blComment Nothing `shouldBe` "c si vis pacem para bellum\n" + + describe "Statement" $ + it "prints vanilla print" $ do + let st = StPrint () u starVal Nothing + let bl = BlStatement () u (Just $ intGen 42) st + pprint Fortran90 bl Nothing `shouldBe` "42 print *\n" + + describe "Interface" $ + it "prints interface block" pending + + describe "Do While" $ do + it "prints simple do while loop" $ do + let cond = ExpBinary () u LFA.GT (varGen "i") (intGen 42) + let bl = BlDoWhile () u Nothing (Just "my_block") Nothing cond body Nothing + let expect = unlines [ "my_block: do while ((i > 42))" + , "print *, i" + , "i = (i - 1)" + , "end do my_block" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + it "prints a labelled do while loop" $ do + let cond = ExpBinary () u LFA.GT (varGen "i") (intGen 42) + let bl = BlDoWhile () u Nothing Nothing (Just (intGen 10)) cond body Nothing + let expect = unlines [ "do 10 while ((i > 42))" + , "print *, i" + , "i = (i - 1)" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + describe "Do" $ do + let iAssign = StExpressionAssign () u (varGen "i") (intGen 1) + let doSpec = DoSpecification () u iAssign (intGen 9) (Just (intGen 2)) + + it "prints 90 style do loop" $ do + let bl = BlDo () u Nothing Nothing Nothing (Just doSpec) body Nothing + let expect = unlines [ "do i = 1, 9, 2" + , "print *, i" + , "i = (i - 1)" + , "end do" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + it "prints named infinite do loop" $ do + let bl = BlDo () u Nothing (Just "joker") Nothing Nothing body Nothing + let expect = unlines [ "joker: do" + , "print *, i" + , "i = (i - 1)" + , "end do joker" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + it "prints named labeled do loop" $ do + let bl = BlDo () u Nothing (Just "joker") (Just $ intGen 42) (Just doSpec) body (Just $ intGen 42) + let expect = unlines [ "joker: do 42 i = 1, 9, 2" + , "print *, i" + , "i = (i - 1)" + , "42 end do joker" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + it "prints vanilla labeled do loop" $ do + let body2 = body ++ [ BlStatement () u (Just $ intGen 42) (StContinue () u) ] + let bl = BlDo () u Nothing Nothing (Just $ intGen 42) (Just doSpec) body2 (Just $ intGen 42) + let expect = unlines [ " do 42 i = 1, 9, 2" + , " print *, i" + , " i = (i - 1)" + , "42 continue" ] + pprint Fortran77 bl (Just 6) `shouldBe` text expect + + describe "If" $ do + it "prints vanilla structured if" $ do + let bl = BlIf () u Nothing Nothing [ Just valTrue ] [ body ] Nothing + let expect = unlines [ "if (.true.) then" + , "print *, i" + , "i = (i - 1)" + , "end if" ] + pprint Fortran90 bl Nothing `shouldBe` text expect + + it "prints multiple condition named structured if" $ do + let conds = [ Just valTrue, Just valFalse, Just valTrue, Nothing ] + let bodies = replicate 4 body + let bl = BlIf () u Nothing (Just "mistral") conds bodies Nothing + let expect = unlines [ "mistral: if (.true.) then" + , " print *, i" + , " i = (i - 1)" + , "else if (.false.) then" + , " print *, i" + , " i = (i - 1)" + , "else if (.true.) then" + , " print *, i" + , " i = (i - 1)" + , "else" + , " print *, i" + , " i = (i - 1)" + , "end if mistral" ] + pprint Fortran90 bl (Just 0) `shouldBe` text expect + + describe "Case" $ + it "prints complicated structured if" $ do + let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing + let cases = [ Just (AList () u [range]) + , Just (AList () u [ IxSingle () u Nothing (intGen 7) ]) + , Nothing ] + let bodies = replicate 3 body + let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42)) + let expect = unlines [ "select case (x)" + , " case (2:4)" + , " print *, i" + , " i = (i - 1)" + , " case (7)" + , " print *, i" + , " i = (i - 1)" + , " case default" + , " print *, i" + , " i = (i - 1)" + , "42 end select" ] + pprint Fortran90 bl (Just 0) `shouldBe` text expect + + describe "Program units" $ do + describe "Main" $ do + it "prints 90 style main without sub programs" $ do + let main = PUMain () u (Just "main") body Nothing + let expect = unlines [ "program main" + , "print *, i" + , "i = (i - 1)" + , "end program main" ] + pprint Fortran90 main Nothing `shouldBe` text expect + + it "prints 66 style main" $ do + let main = PUMain () u Nothing body Nothing + let expect = unlines [ " print *, i" + , " i = (i - 1)" + , " end" ] + pprint Fortran66 main (Just 0) `shouldBe` text expect + + describe "Module" $ do + it "prints module without sub programs" $ do + let mod = PUModule () u "my_mod" body Nothing + let expect = unlines [ "module my_mod" + , " print *, i" + , " i = (i - 1)" + , "end module my_mod" ] + 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 mod = PUModule () u "my_mod" body (Just [ sub ]) + let expect = unlines [ " module my_mod" + , " print *, i" + , " i = (i - 1)" + , "" + , " contains" + , "" + , " subroutine sub" + , " print *, i" + , " i = (i - 1)" + , " end subroutine sub" + , " end module my_mod" ] + pprint Fortran90 mod (Just 3) `shouldBe` text expect + + 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 expect = unlines [ "recursive subroutine sub(x, y, z)" + , "print *, i" + , "i = (i - 1)" + , "end subroutine sub" ] + 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 expect = unlines [ " subroutine sub" + , " print *, i" + , " i = (i - 1)" + , " end" ] + pprint Fortran66 mod Nothing `shouldBe` text expect + + describe "Function" $ do + let tSpec = Just $ TypeSpec () u TypeInteger Nothing + + 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 expect = unlines [ " integer function f(x, y, z) result(i)" + , " print *, i" + , " i = (i - 1)" + , " end function f" ] + pprint Fortran90 fun (Just 2) `shouldBe` text expect + + 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 com = PUComment () u (Comment "hello!") + let pf = ProgramFile mi77 [com, pu, com, pu, com, com] + let expect = unlines [ "!hello!" + , "module my_mod" + , " continue" + , "end module my_mod" + , "!hello!" + , "module my_mod" + , " continue" + , "end module my_mod" + , "!hello!" + , "!hello!" ] + pprint Fortran90 pf (Just 0) `shouldBe` text expect + +valueExpressions :: Expression () -> Maybe (Expression ()) +valueExpressions e@ExpValue{} = Just e +valueExpressions _ = Nothing + +flexReadFile :: String -> IO B.ByteString +flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile diff --git a/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs @@ -0,0 +1,158 @@ +module Language.Fortran.Transformation.Disambiguation.FunctionSpec (spec) where + +import Test.Hspec +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 ] + +spec :: Spec +spec = do + describe "Function statement disambiguation" $ + it "disambiguates function statements in example 1" $ do + let pf = disambiguateFunction $ resetSrcSpan ex1 + pf `shouldBe'` expectedEx1 + + describe "Function call disambiguation" $ + it "disambiguates function calls in example 2" $ do + let pf = disambiguateFunction $ resetSrcSpan ex2 + pf `shouldBe'` expectedEx2 + + describe "Function call / Intrinsic disambiguation" $ + it "disambiguates function calls / intrinsics in example 3" $ do + let pf = disambiguateFunction $ resetSrcSpan ex3 + pf `shouldBe'` expectedEx3 + +{- +- program Main +- integer a, b(1), c +- dimension a(1) +- a(1) = 1 +- b(1) = 1 +- c(x) = 1 +- d(x) = 1 +- end +-} +ex1 = ProgramFile mi77 [ ex1pu1 ] +ex1pu1 = PUMain () u (Just "main") ex1pu1bs Nothing +ex1pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclVariable () u (varGen "c") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "c") (AList () u [ 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)) ] + +expectedEx1 = ProgramFile mi77 [ expectedEx1pu1 ] +expectedEx1pu1 = PUMain () u (Just "main") expectedEx1pu1bs Nothing +expectedEx1pu1bs = + [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u + [ DeclVariable () u (varGen "a") Nothing Nothing + , DeclArray () u (varGen "b") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1) ]) Nothing Nothing + , DeclVariable () u (varGen "c") Nothing Nothing ])) + , BlStatement () u Nothing (StDimension () u (AList () u + [ DeclArray () u (varGen "a") (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 1 ) ]) Nothing Nothing ])) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "a") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , BlStatement () u Nothing (StExpressionAssign () u + (ExpSubscript () u (varGen "b") (AList () u [ ixSinGen 1 ])) (intGen 1)) + , 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)) ] + +{- +- program +- integer k(1) +- f(x) = 1 +- i = 1 + f(1) +- l = k(1) +- j = y(1,1) + a +- end +- +- function y(i,j) +- end +-} +ex2 = ProgramFile mi77 [ ex2pu1, ex2pu2 ] +ex2pu1 = PUMain () u Nothing ex2pu1bs Nothing +ex2pu2 = PUFunction () u Nothing (None () u False) "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex2pu1bs = + [ BlStatement () u Nothing + (StFunction () u + (ExpValue () u (ValVariable "f")) + (AList () u [ varGen "x" ]) + (intGen 1)) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "i") + (ExpBinary () u Addition + (intGen 1) + (ExpSubscript () u + (varGen "f") + (AList () u [ ixSinGen 1 ])))) ] + +expectedEx2 = ProgramFile mi77 [ expectedEx2pu1, ex2pu2 ] +expectedEx2pu1 = PUMain () u Nothing expectedEx2pu1bs Nothing +expectedEx2pu1bs = + [ BlStatement () u Nothing + (StFunction () u + (ExpValue () u (ValVariable "f")) + (AList () u [ varGen "x" ]) + (intGen 1)) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "i") + (ExpBinary () u Addition + (intGen 1) + (ExpFunctionCall () u + (ExpValue () u $ ValVariable "f") + (Just $ AList () u [ Argument () u Nothing (intGen 1) ])))) ] + + +ex3 = ProgramFile mi77 [ ex3pu1, ex3pu2 ] +ex3pu1 = PUMain () u Nothing ex3pu1bs Nothing +ex3pu2 = PUFunction () u Nothing (None () u False) "y" (Just $ AList () u [ varGen "i", varGen "j" ]) Nothing [ ] Nothing +ex3pu1bs = + [ BlStatement () u Nothing + (StFunction () u + (ExpValue () u (ValVariable "f")) + (AList () u [ varGen "x" ]) + (intGen 1)) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "i") + (ExpSubscript () u (varGen "abs") + (AList () u [ + (IxSingle () u Nothing (ExpSubscript () u (varGen "f") (AList () u [ ixSinGen 1 ])))]))) ] + +expectedEx3 = ProgramFile mi77 [ expectedEx3pu1, ex3pu2 ] +expectedEx3pu1 = PUMain () u Nothing expectedEx3pu1bs Nothing +expectedEx3pu1bs = + [ BlStatement () u Nothing + (StFunction () u + (ExpValue () u (ValVariable "f")) + (AList () u [ varGen "x" ]) + (intGen 1)) + , BlStatement () u Nothing + (StExpressionAssign () u (varGen "i") + (ExpFunctionCall () u (ExpValue () u $ ValIntrinsic "abs") + (Just $ AList () u [ Argument () u Nothing + (ExpFunctionCall () u (ExpValue () u $ ValVariable "f") + (Just $ AList () u [ Argument () u Nothing (intGen 1) ])) ]))) ] + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Transformation/GroupingSpec.hs @@ -0,0 +1,176 @@ +module Language.Fortran.Transformation.GroupingSpec where + +import Test.Hspec hiding (Selector) +import TestUtil +import Control.Exception (evaluate) +import Control.DeepSeq (force, ($!!), NFData) + +import Language.Fortran.Transformer +import Language.Fortran.AST +import Language.Fortran.Util.Position +import Language.Fortran.ParserMonad + +groupIf = transform [ GroupIf ] +groupDo = transform [ GroupLabeledDo ] +groupForall = transform [ GroupForall ] + +instance NFData MetaInfo +instance NFData FortranVersion +instance NFData SrcSpan +instance NFData Position +instance NFData BaseType +instance NFData UnaryOp +instance NFData BinaryOp +instance NFData Only +instance NFData Intent +instance (NFData a, NFData (t a)) => NFData (AList t a) +instance NFData a => NFData (ProgramFile a) +instance NFData a => NFData (ProgramUnit a) +instance NFData a => NFData (Block a) +instance NFData a => NFData (Expression a) +instance NFData a => NFData (TypeSpec a) +instance NFData a => NFData (Index a) +instance NFData a => NFData (Value a) +instance NFData a => NFData (Comment a) +instance NFData a => NFData (Statement a) +instance NFData a => NFData (DoSpecification a) +instance NFData a => NFData (Selector a) +instance NFData a => NFData (ForallHeader a) +instance NFData a => NFData (Argument a) +instance NFData a => NFData (Use a) +instance NFData a => NFData (Attribute a) +instance NFData a => NFData (CommonGroup a) +instance NFData a => NFData (ControlPair 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 (ImpElement a) +instance NFData a => NFData (ImpList a) +instance NFData a => NFData (Namelist a) +instance NFData a => NFData (PUFunctionOpt a) +instance NFData a => NFData (StructureItem a) +instance NFData a => NFData (UnionMap a) + +spec :: Spec +spec = do + let name = Just "name" + let endName = Just "endName" + describe "Block FORALL statements" $ do + it "groups unlabelled FORALL blocks" $ do + groupForall (exampleForall Nothing Nothing) `shouldBe'` expectedForall Nothing + it "groups unlabelled FORALL blocks" $ do + groupForall (exampleForall name name) `shouldBe'` expectedForall name + it "groups unlabelled FORALL blocks" $ do + let lhs = (evaluate . force) (groupForall $ exampleForall name endName) + lhs `shouldThrow` anyErrorCall + describe "Block IF-THEN and related statements" $ do + it "groups example1" $ + groupIf example1 `shouldBe'` expectedExample1 + + it "groups example2" $ + groupIf example2 `shouldBe'` expectedExample2 + + describe "Block DO statements" $ do + it "do group example1" $ + groupDo example1do `shouldBe` expectedExample1do + + it "do group example2 with common end-point" $ + groupDo example2do `shouldBe` expectedExample2do + +buildExampleProgram name blocks = ProgramFile mi77 [ PUMain () u (Just name) blocks Nothing ] + +exampleComment = BlComment () u $ Comment "comment" +exampleHeader = ForallHeader [] Nothing +exampleForall name nameEnd = buildExampleProgram "forall" $ + [ BlStatement () u Nothing $ StForall () u name exampleHeader + , exampleComment + , BlStatement () u Nothing $ StEndForall () u nameEnd + ] + +expectedForall name = buildExampleProgram "forall" $ + [BlForall () u Nothing name exampleHeader [exampleComment] Nothing] + + +-- if (.true.) then +-- end if +example1 = ProgramFile mi77 [ PUMain () u (Just "example1") example1Blocks Nothing ] +example1Blocks = + [ BlStatement () u Nothing (StIfThen () u Nothing valTrue) + , BlStatement () u Nothing (StEndif () u Nothing) ] + +expectedExample1 = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1Blocks Nothing ] +expectedExample1Blocks = [ BlIf () u Nothing Nothing [ Just valTrue ] [ [ ] ] Nothing ] + +-- if (.true.) then +-- integer x +-- if (.false.) then +-- endif +-- else if (.true.) then +-- else +-- if (.false.) then +-- endif +-- end if +example2 = ProgramFile mi77 [ PUMain () u (Just "example2") example2Blocks Nothing ] +example2Blocks = + [ BlStatement () u Nothing (StIfThen () u Nothing valTrue) + , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ])) + , BlStatement () u Nothing (StIfThen () u Nothing valFalse) + , BlStatement () u Nothing (StEndif () u Nothing) + , BlStatement () u Nothing (StElsif () u Nothing valTrue) + , BlStatement () u Nothing (StElse () u Nothing) + , BlStatement () u Nothing (StIfThen () u Nothing valFalse) + , BlStatement () u Nothing (StEndif () u Nothing) + , BlStatement () u Nothing (StEndif () u Nothing) ] + +expectedExample2 = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2Blocks Nothing ] +expectedExample2Blocks = [ BlIf () u Nothing Nothing [ Just valTrue, Just valTrue, Nothing ] blockGroups Nothing ] +blockGroups = + [ [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ])) + , innerIf ] + , [ ] + , [ innerIf ] ] +innerIf = BlIf () u Nothing Nothing [ Just valFalse ] [ [ ] ] Nothing + + +-- do 10 i = 0, 10 +-- 10 continue +label10 = Just (ExpValue () u (ValInteger "10")) +example1do = ProgramFile mi77 [ PUMain () u (Just "example1") example1doblocks Nothing ] +example1doblocks = + [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) + , BlStatement () u label10 (StContinue () u) ] +dospec = Just (DoSpecification () u + (StExpressionAssign () u (ExpValue () u (ValVariable "i")) + (ExpValue () u (ValInteger "0"))) + (ExpValue () u (ValInteger "10")) Nothing) + +expectedExample1do = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1doBlocks Nothing ] +expectedExample1doBlocks = + [ BlDo () u Nothing Nothing label10 dospec + [BlStatement () u label10 (StContinue () u)] label10 ] + +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 mi77 [ PUMain () u (Just "example2") example2doblocks Nothing ] +example2doblocks = + [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) + , BlStatement () u Nothing (StDo () u Nothing label10 dospec) + , BlStatement () u label10 (StContinue () u) + , BlStatement () u Nothing (StDo () u Nothing label20 dospec) + , BlStatement () u label20 (StContinue () u) + ] + +expectedExample2do = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2doBlocks Nothing ] +expectedExample2doBlocks = + [ BlDo () u Nothing Nothing label10 dospec + [ BlDo () u Nothing Nothing label10 dospec + [ BlStatement () u label10 (StContinue () u) ] label10 + ] label10 + , BlDo () u Nothing Nothing label20 dospec + [ BlStatement () u label20 (StContinue () u) ] label20 + ] diff --git a/test/Language/Fortran/Util/FirstParameterSpec.hs b/test/Language/Fortran/Util/FirstParameterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Util/FirstParameterSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Fortran.Util.FirstParameterSpec(spec) where + +import Test.Hspec + +import GHC.Generics (Generic(..)) + +import Language.Fortran.Util.FirstParameter + +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 D = DA () | DB () | DC () | DD () | DE () deriving (Generic, Eq, Show) + +instance FirstParameter A Int +instance FirstParameter B Char +instance FirstParameter C ([Int]) +instance FirstParameter D () + +spec :: Spec +spec = + describe "First parameter accessor type class" $ do + describe "data A" $ do + it "retrieves first parameter from 'A 42'" $ do + getFirstParameter (A 42) `shouldBe` 42 + + it "sets first parameter in 'A 42' to 24" $ do + setFirstParameter 24 (A 42) `shouldBe` A 24 + + describe "data B" $ do + it "retrieves first parameter from \"B 'x' 'y' 42 'z'\"" $ do + 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') + + describe "data C" $ do + it "retrieves first parameter from 'CA [1,2,3] 'a''" $ do + getFirstParameter (CA [1,2,3] 'a') `shouldBe` [1,2,3] + + it "retrieves first parameter from \"CB [1,2,3] 'a'\"" $ do + 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') + + describe "data D" $ do + it "retrieves first parameter from 'DB ()" $ do + getFirstParameter (DB ()) `shouldBe` () + + it "retrieves first parameter from 'DD ()" $ do + getFirstParameter (DD ()) `shouldBe` () + + it "retrieves first parameter from 'DE ()" $ do + getFirstParameter (DE ()) `shouldBe` () diff --git a/test/Language/Fortran/Util/SecondParameterSpec.hs b/test/Language/Fortran/Util/SecondParameterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Util/SecondParameterSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Fortran.Util.SecondParameterSpec(spec) where + +import Test.Hspec + +import GHC.Generics (Generic(..)) + +import Language.Fortran.Util.SecondParameter + +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 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 D () + +spec :: Spec +spec = + describe "Second parameter retrieving type class" $ do + describe "data A" $ do + it "retrieves second parameter from 'A 'a' 42'" $ do + getSecondParameter (A 'x' 42) `shouldBe` 42 + + it "sets second parameter in \"A 'a' 42\" to 24" $ do + setSecondParameter 24 (A 'x' 42) `shouldBe` A 'x' 24 + + describe "data B" $ do + it "retrieves second parameter from 'B 41 42 43 44'" $ do + getSecondParameter (B 41 42 43 44) `shouldBe` 42 + + it "sets second parameter in \"B 41 42 43 44\" to 24" $ do + 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 + getSecondParameter (CA "hello" ['x', 'y']) `shouldBe` ['x', 'y'] + + it "retrieves second parameter from 'CB 42 [] ()'" $ do + getSecondParameter (CB 42 [] ()) `shouldBe` [] + + it "sets second parameter in \"CB 42 []\" to ['x','x','x']" $ do + 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 + getSecondParameter (DB 42 () 42 42 42 42 42 42 42) `shouldBe` () + + it "retrieves second parameter from 'DD () () 'a'" $ do + getSecondParameter (DD () () 'a') `shouldBe` () diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/TestUtil.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module TestUtil where + +import Test.Hspec +import Data.Data +import Data.Generics.Uniplate.Data + +import Language.Fortran.AST +import Language.Fortran.ParserMonad +import Language.Fortran.Util.Position + +import Language.Fortran.Analysis +import Language.Fortran.Analysis.Renaming hiding (extractNameMap, underRenaming) +import qualified Data.Map as M +import Data.Maybe + +u = initSrcSpan + +mi77 = MetaInfo { miVersion = Fortran77, miFilename = "" } +mi90 = MetaInfo { miVersion = Fortran90, miFilename = "" } + +valTrue = ExpValue () u $ ValLogical ".true." +valFalse = ExpValue () u $ ValLogical ".false." + +varGen :: String -> Expression () +varGen str = ExpValue () u $ ValVariable str + +intGen :: (Show a, Integral a) => a -> Expression () +intGen i = ExpValue () u $ ValInteger $ show i + +realGen :: (Fractional a, Show a) => a -> Expression () +realGen i = ExpValue () u $ ValReal $ show i + +strGen :: String -> Expression () +strGen str = ExpValue () u $ ValString str + +labelGen :: Integer -> Expression () +labelGen i = ExpValue () u $ ValInteger $ show i + +starVal :: Expression () +starVal = ExpValue () u ValStar + +opGen :: String -> Expression () +opGen s = ExpValue () u (ValOperator s) + +assVal :: Expression () +assVal = ExpValue () u ValAssignment + +ixSinGen i = IxSingle () u Nothing (intGen i) +ixRanGen i j = IxRange () u (Just $ intGen i) (Just $ intGen j) Nothing + +shouldBe' a b = resetSrcSpan a `shouldBe` resetSrcSpan b + +shouldMatchList' a b = resetSrcSpan a `shouldMatchList` resetSrcSpan b + +-- To be used in testing it reverts the SrcSpans in AST to dummy initial +-- SrcSpan value. +resetSrcSpan :: Data a => a -> a +resetSrcSpan = transformBi f + where + f x = case cast x :: Maybe SrcSpan of + Just _ -> initSrcSpan + Nothing -> x + +-------------------------------------------------- +-- These functions do not work on modules with use-renaming so are +-- only for testing purposes... +underRenaming :: (Data a, Data b) => (ProgramFile (Analysis a) -> b) -> ProgramFile a -> b +underRenaming f pf = tryUnrename `descendBi` f pf' + where + pf' = rename . analyseRenames . initAnalysis $ pf + renameMap = extractNameMap pf' + tryUnrename n = n `fromMaybe` M.lookup n renameMap + +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] ] + uniE :: Data a => ProgramFile a -> [Expression a] + uniE = universeBi + uniPU :: Data a => ProgramFile a -> [ProgramUnit a] + uniPU = universeBi +--------------------------------------------------