refactor DoSpec to not use Statement

This removes `Expression`'s mutual recursion with `Statement`.
camfort · May 11, 2022 · 24de15f · 24de15f
1 parent 3bee475
commit 24de15f
Show file tree

Hide file tree

Showing 16 changed files with 95 additions and 119 deletions.
diff --git 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
@@ -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
@@ -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 = "<unhandled block: " ++ show (toConstr (fmap (const ()) b)) ++ ">"

diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -53,17 +53,15 @@ 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 ]
             expectedSt = StRead2 () u starVal (Just iolist)
         sParser "      read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt
 
     it "parses '(x, y(i), i = 1, 10, 2)'" $ do
-      let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)
-          doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)
+      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
@@ -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
@@ -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
@@ -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
@@ -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