From 24de15fbdfa54fd20978a653d481cc216df562a8 Mon Sep 17 00:00:00 2001 From: Ben Orchard Date: Tue, 10 May 2022 17:54:09 +0100 Subject: [PATCH] refactor DoSpec to not use Statement This removes `Expression`'s mutual recursion with `Statement`. --- src/Language/Fortran/AST.hs | 2 +- src/Language/Fortran/Analysis.hs | 23 +++++++--- src/Language/Fortran/Analysis/BBlocks.hs | 4 +- src/Language/Fortran/Parser/Fixed/Fortran66.y | 8 ++-- src/Language/Fortran/Parser/Fixed/Fortran77.y | 6 ++- .../Fortran/Parser/Free/Fortran2003.y | 8 ++-- src/Language/Fortran/Parser/Free/Fortran90.y | 8 ++-- src/Language/Fortran/Parser/Free/Fortran95.y | 8 ++-- src/Language/Fortran/PrettyPrint.hs | 11 ++--- .../Fortran/Parser/Fixed/Fortran66Spec.hs | 3 +- .../Parser/Fixed/Fortran77/ParserSpec.hs | 6 +-- test/Language/Fortran/Parser/Free/Common.hs | 44 +++++++++++++++++++ .../Fortran/Parser/Free/Fortran90Spec.hs | 37 +--------------- .../Fortran/Parser/Free/Fortran95Spec.hs | 37 +--------------- test/Language/Fortran/PrettyPrintSpec.hs | 6 +-- .../Fortran/Transformation/GroupingSpec.hs | 3 +- 16 files changed, 95 insertions(+), 119 deletions(-) diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs index 38e18204..2b7c9a4e 100644 --- a/src/Language/Fortran/AST.hs +++ b/src/Language/Fortran/AST.hs @@ -588,7 +588,7 @@ data FlushSpec a = deriving (Eq, Show, Data, Typeable, Generic, Functor) data DoSpecification a = - DoSpecification a SrcSpan (Statement a) (Expression a) (Maybe (Expression a)) + DoSpecification a SrcSpan (Expression a) (Expression a) (Expression a) (Maybe (Expression a)) deriving (Eq, Show, Data, Typeable, Generic, Functor) data Expression a = diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs index 3a6c4f08..d50390ad 100644 --- a/src/Language/Fortran/Analysis.hs +++ b/src/Language/Fortran/Analysis.hs @@ -241,6 +241,7 @@ lhsExprs x = concatMap lhsOfStmt (universeBi x) lhsOfStmt (StExpressionAssign _ _ e e') = e : onExprs e' lhsOfStmt (StCall _ _ _ (Just aexps)) = filter isLExpr argExps ++ concatMap onExprs argExps where argExps = map argExtractExpr . aStrip $ aexps + lhsOfStmt s@(StDo _ _ _ _ (Just dospec)) = lhsOfStmt (dospecAsStmt dospec) ++ onExprs s lhsOfStmt s = onExprs s onExprs :: (Data a, Data (c a)) => c a -> [Expression a] @@ -273,19 +274,26 @@ allVars b = [ varName v | v@(ExpValue _ _ (ValVariable _)) <- uniBi b ] analyseAllLhsVars :: forall a . Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a) analyseAllLhsVars = (transformBi :: TransFunc Block ProgramFile a) analyseAllLhsVars1 . (transformBi :: TransFunc Statement ProgramFile a) analyseAllLhsVars1 . - (transformBi :: TransFunc DoSpecification ProgramFile a) analyseAllLhsVars1 + (transformBi :: TransFunc DoSpecification ProgramFile a) analyseAllLhsVarsDoSpec analyseAllLhsVars1 :: (Annotated f, Data (f (Analysis a)), Data a) => f (Analysis a) -> f (Analysis a) analyseAllLhsVars1 x = modifyAnnotation (\ a -> a { allLhsVarsAnn = computeAllLhsVars x }) x +analyseAllLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> DoSpecification (Analysis a) +analyseAllLhsVarsDoSpec x = modifyAnnotation (\ a -> a { allLhsVarsAnn = allLhsVarsDoSpec x }) x + +allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name] +allLhsVarsDoSpec = computeAllLhsVars . dospecAsStmt + -- | Set of names found in the parts of an AST that are the target of -- an assignment statement. -- allLhsVars :: (Annotated b, Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name] allLhsVars :: Data a => Block (Analysis a) -> [Name] allLhsVars = allLhsVarsAnn . getAnnotation -allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name] -allLhsVarsDoSpec = computeAllLhsVars +dospecAsStmt :: DoSpecification a -> Statement a +dospecAsStmt (DoSpecification a ss lhs rhs _e1 _me2) = + StExpressionAssign a ss lhs rhs -- | Set of names found in the parts of an AST that are the target of -- an assignment statement. @@ -298,6 +306,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi lhsOfStmt (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _) | Just defs <- intrinsicDefs f = defs lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . argExtractExpr) (aStrip aexps) + lhsOfStmt s@(StDo _ _ _ _ (Just dospec)) = lhsOfStmt (dospecAsStmt dospec) ++ onExprs s lhsOfStmt s = onExprs s lhsOfDecls (Declarator _ _ e _ _ (Just e')) = match' e : onExprs e' @@ -331,7 +340,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi -- | Set of expressions used -- not defined -- by an AST-block. blockRhsExprs :: Data a => Block a -> [Expression a] blockRhsExprs (BlStatement _ _ _ s) = statementRhsExprs s -blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _) +blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ 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) @@ -346,8 +355,8 @@ statementRhsExprs (StExpressionAssign _ _ lhs rhs) statementRhsExprs StDeclaration{} = [] statementRhsExprs (StIfLogical _ _ _ s) = statementRhsExprs s statementRhsExprs (StDo _ _ _ l s') = universeBi l ++ doSpecRhsExprs s' - where doSpecRhsExprs (Just (DoSpecification _ _ s e1 e2)) = - (e1 : universeBi e2) ++ statementRhsExprs s + where doSpecRhsExprs (Just dospec@(DoSpecification _ _ _lhs _rhs e1 e2)) = + (e1 : universeBi e2) ++ statementRhsExprs (dospecAsStmt dospec) doSpecRhsExprs Nothing = [] statementRhsExprs s = universeBi s @@ -356,7 +365,7 @@ blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name] blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs)) | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs) | otherwise = allVars rhs -blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _) +blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ lhs rhs e1 e2)) _ _) | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs) | otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ] diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs index 72c065a1..97532daa 100644 --- a/src/Language/Fortran/Analysis/BBlocks.hs +++ b/src/Language/Fortran/Analysis/BBlocks.hs @@ -411,7 +411,7 @@ perBlock b@(BlStatement _ _ _ StIfArithmetic{}) = -- Treat an arithmetic if similarly to a goto processLabel b >> addToBBlock b >> closeBBlock_ perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do - let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec + let DoSpecification _ _ _ e1 e2 me3 = spec _ <- processFunctionCalls e1 _ <- processFunctionCalls e2 _ <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing @@ -791,7 +791,7 @@ showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) = showExpr e2 ++ ", " ++ showExpr e3 ++ ", " ++ maybe "1" showExpr me4 ++ "\\l" - where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec + where DoSpecification _ _ e1 e2 e3 me4 = spec showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do" showBlock (BlComment{}) = "" showBlock b = "" diff --git a/src/Language/Fortran/Parser/Fixed/Fortran66.y b/src/Language/Fortran/Parser/Fixed/Fortran66.y index 75c55e41..de0ceaca 100644 --- a/src/Language/Fortran/Parser/Fixed/Fortran66.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran66.y @@ -171,10 +171,10 @@ DO_STATEMENT :: { Statement A0 } { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) } DO_SPECIFICATION :: { DoSpecification A0 } -: EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR ',' INT_OR_VAR - { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) } -| EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR - { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing } +: ELEMENT '=' EXPRESSION ',' INT_OR_VAR ',' INT_OR_VAR + { DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) } +| ELEMENT '=' EXPRESSION ',' INT_OR_VAR + { DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing } INT_OR_VAR :: { Expression A0 } : INTEGER_LITERAL { $1 } diff --git a/src/Language/Fortran/Parser/Fixed/Fortran77.y b/src/Language/Fortran/Parser/Fixed/Fortran77.y index 1abca141..a525f118 100644 --- a/src/Language/Fortran/Parser/Fixed/Fortran77.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran77.y @@ -289,8 +289,10 @@ DO_STATEMENT :: { Statement A0 } | do { StDo () (getSpan $1) Nothing Nothing 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 } +: ELEMENT '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) } +| ELEMENT '=' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing } EXECUTABLE_STATEMENT :: { Statement A0 } : EXPRESSION_ASSIGNMENT_STATEMENT { $1 } diff --git a/src/Language/Fortran/Parser/Free/Fortran2003.y b/src/Language/Fortran/Parser/Free/Fortran2003.y index ff48d16c..39941227 100644 --- a/src/Language/Fortran/Parser/Free/Fortran2003.y +++ b/src/Language/Fortran/Parser/Free/Fortran2003.y @@ -1287,10 +1287,10 @@ RANGE :: { Index A0 } { 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 } +: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) } +| DATA_REF '=' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing } IMPLIED_DO :: { Expression A0 } : '(' EXPRESSION ',' DO_SPECIFICATION ')' diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y index cd8b813c..da84541b 100644 --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -1079,10 +1079,10 @@ RANGE :: { Index A0 } { 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 } +: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) } +| DATA_REF '=' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing } IMPLIED_DO :: { Expression A0 } : '(' EXPRESSION ',' DO_SPECIFICATION ')' diff --git a/src/Language/Fortran/Parser/Free/Fortran95.y b/src/Language/Fortran/Parser/Free/Fortran95.y index 6e0094ad..7365bf4b 100644 --- a/src/Language/Fortran/Parser/Free/Fortran95.y +++ b/src/Language/Fortran/Parser/Free/Fortran95.y @@ -1094,10 +1094,10 @@ RANGE :: { Index A0 } { 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 } +: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) } +| DATA_REF '=' EXPRESSION ',' EXPRESSION + { DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing } IMPLIED_DO :: { Expression A0 } : '(' EXPRESSION ',' DO_SPECIFICATION ')' diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs index 55766b62..b7bbbeba 100644 --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -870,16 +870,11 @@ instance Pretty (FlushSpec a) where pprint' v (FSErr _ _ e) = "err=" <> pprint' v e instance Pretty (DoSpecification a) where - pprint' v (DoSpecification _ _ s@StExpressionAssign{} limit mStride) = - pprint' v s <> comma - <+> pprint' v limit + pprint' v (DoSpecification _ _ lhs rhs limit mStride) = + (pprint' v lhs <+> equals <+> pprint' v rhs) + <> comma <+> pprint' v limit <> comma pprint' v mStride - -- Given DoSpec. has a single constructor, the only way for pattern - -- match above to fail is to have the wrong type of statement embedded - -- in it. - pprint' _ _ = error "Incorrect initialisation in DO specification." - instance Pretty (ControlPair a) where pprint' v (ControlPair _ _ mStr exp) | v >= Fortran77 diff --git a/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs index 1bcb2f9e..3ec7c4e0 100644 --- a/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs @@ -183,7 +183,6 @@ spec = 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 doSpec = DoSpecification () u (varGen "i") (intGen 10) (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/Fixed/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs index 0e709a2d..8d51697f 100644 --- a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs @@ -53,8 +53,7 @@ spec = sParser " endfile i" `shouldBe'` StEndfile2 () u (varGen "i") it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do - let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) - doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) + let doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 10) (Just $ intGen 2) impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] impliedDo = ExpImpliedDo () u impliedDoVars doSpec iolist = AList () u [ impliedDo ] @@ -62,8 +61,7 @@ spec = sParser " read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt it "parses '(x, y(i), i = 1, 10, 2)'" $ do - let stAssign = StExpressionAssign () u (varGen "i") (intGen 1) - doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2) + let doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 10) (Just $ intGen 2) impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])] impliedDo = ExpImpliedDo () u impliedDoVars doSpec eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo diff --git a/test/Language/Fortran/Parser/Free/Common.hs b/test/Language/Fortran/Parser/Free/Common.hs index a01e2567..3d2040f5 100644 --- a/test/Language/Fortran/Parser/Free/Common.hs +++ b/test/Language/Fortran/Parser/Free/Common.hs @@ -124,3 +124,47 @@ specFreeCommon sParser eParser = , genArg (ArgExpr (varGen "i")) ] genArg = Argument () u Nothing sParser stStr `shouldBe'` expected + + describe "Do" $ do + it "parses do statement with label" $ do + let doSpec = DoSpecification () u (varGen "i") (intGen 0) (intGen 42) Nothing + st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) + sParser "do 24, i = 0, 42" `shouldBe'` st + + it "parses do statement without label" $ do + let doSpec = DoSpecification () u (varGen "i") (intGen 0) (intGen 42) Nothing + 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 + + describe "DO WHILE" $ do + it "parses unnamed do while statement" $ do + let st = StDoWhile () u Nothing Nothing valTrue + sParser "do while (.true.)" `shouldBe'` st + + it "parses named do while statement" $ do + let st = StDoWhile () u (Just "name") Nothing valTrue + sParser "name: do while (.true.)" `shouldBe'` st + + it "parses unnamed labelled do while statement" $ do + let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue + sParser "do 999 while (.true.)" `shouldBe'` st + + describe "Expression" $ do + describe "Implied DO loop" $ do + it "parses write with implied do" $ do + let cp1 = ControlPair () u Nothing (intGen 10) + cp2 = ControlPair () u (Just "format") (varGen "x") + ciList = fromList () [ cp1, cp2 ] + doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 42) (Just $ intGen 2) + alist = fromList () [ varGen "i", varGen "j" ] + outList = fromList () [ ExpImpliedDo () u alist doSpec ] + st = StWrite () u ciList (Just outList) + sParser "write (10, FORMAT = x) (i, j, i = 1, 42, 2)" `shouldBe'` st diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs index 4ed33bcd..15ded680 100644 --- a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs @@ -493,40 +493,6 @@ spec = (Just $ intGen 80) bParser src `shouldBe'` block - describe "Do" $ do - it "parses do statement with label" $ do - let assign = StExpressionAssign () u (varGen "i") (intGen 0) - doSpec = DoSpecification () u assign (intGen 42) Nothing - st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) - sParser "do 24, i = 0, 42" `shouldBe'` st - - it "parses do statement without label" $ do - let assign = StExpressionAssign () u (varGen "i") (intGen 0) - doSpec = DoSpecification () u assign (intGen 42) Nothing - st = StDo () u Nothing Nothing (Just doSpec) - sParser "do i = 0, 42" `shouldBe'` st - - it "parses infinite do" $ do - 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 - - describe "DO WHILE" $ do - it "parses unnamed do while statement" $ do - let st = StDoWhile () u Nothing Nothing valTrue - sParser "do while (.true.)" `shouldBe'` st - - it "parses named do while statement" $ do - let st = StDoWhile () u (Just "name") Nothing valTrue - sParser "name: do while (.true.)" `shouldBe'` st - - it "parses unnamed labelled do while statement" $ do - let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue - sParser "do 999 while (.true.)" `shouldBe'` st - describe "Goto" $ do it "parses vanilla goto" $ do let st = StGotoUnconditional () u (intGen 999) @@ -555,8 +521,7 @@ spec = let cp1 = ControlPair () u Nothing (intGen 10) cp2 = ControlPair () u (Just "format") (varGen "x") ciList = fromList () [ cp1, cp2 ] - assign = StExpressionAssign () u (varGen "i") (intGen 1) - doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) + doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 42) (Just $ intGen 2) alist = fromList () [ varGen "i", varGen "j" ] outList = fromList () [ ExpImpliedDo () u alist doSpec ] st = StWrite () u ciList (Just outList) diff --git a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs index 596aa62d..b16d0064 100644 --- a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs @@ -548,40 +548,6 @@ spec = (Just $ intGen 80) bParser src `shouldBe'` block - describe "Do" $ do - it "parses do statement with label" $ do - let assign = StExpressionAssign () u (varGen "i") (intGen 0) - doSpec = DoSpecification () u assign (intGen 42) Nothing - st = StDo () u Nothing (Just $ intGen 24) (Just doSpec) - sParser "do 24, i = 0, 42" `shouldBe'` st - - it "parses do statement without label" $ do - let assign = StExpressionAssign () u (varGen "i") (intGen 0) - doSpec = DoSpecification () u assign (intGen 42) Nothing - st = StDo () u Nothing Nothing (Just doSpec) - sParser "do i = 0, 42" `shouldBe'` st - - it "parses infinite do" $ do - 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 - - describe "DO WHILE" $ do - it "parses unnamed do while statement" $ do - let st = StDoWhile () u Nothing Nothing valTrue - sParser "do while (.true.)" `shouldBe'` st - - it "parses named do while statement" $ do - let st = StDoWhile () u (Just "name") Nothing valTrue - sParser "name: do while (.true.)" `shouldBe'` st - - it "parses unnamed labelled do while statement" $ do - let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue - sParser "do 999 while (.true.)" `shouldBe'` st - describe "Goto" $ do it "parses vanilla goto" $ do let st = StGotoUnconditional () u (intGen 999) @@ -607,8 +573,7 @@ spec = let cp1 = ControlPair () u Nothing (intGen 10) cp2 = ControlPair () u (Just "format") (varGen "x") ciList = fromList () [ cp1, cp2 ] - assign = StExpressionAssign () u (varGen "i") (intGen 1) - doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2) + doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 42) (Just $ intGen 2) alist = fromList () [ varGen "i", varGen "j" ] outList = fromList () [ ExpImpliedDo () u alist doSpec ] st = StWrite () u ciList (Just outList) diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs index ac4f22f0..db53baa7 100644 --- a/test/Language/Fortran/PrettyPrintSpec.hs +++ b/test/Language/Fortran/PrettyPrintSpec.hs @@ -206,8 +206,7 @@ spec = 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 + let doSpec = DoSpecification () u (varGen "i") (intGen (-1)) (intGen 5) Nothing it "prints labeled do" $ do let stDo = StDo () u Nothing (Just $ intGen 42) (Just doSpec) @@ -338,8 +337,7 @@ spec = 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)) + let doSpec = DoSpecification () u (varGen "i") (intGen 1) (intGen 9) (Just (intGen 2)) it "prints 90 style do loop" $ do let bl = BlDo () u Nothing Nothing Nothing (Just doSpec) body Nothing diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs index e93f15cc..8ae00475 100644 --- a/test/Language/Fortran/Transformation/GroupingSpec.hs +++ b/test/Language/Fortran/Transformation/GroupingSpec.hs @@ -89,7 +89,8 @@ dospec = Just $ DoSpecification () u - (StExpressionAssign () u (varGen "i") (intGen 0)) + (varGen "i") + (intGen 0) (intGen 10) Nothing