Skip to content

Commit 24de15f

Browse files
raehikraehik
committed
refactor DoSpec to not use Statement
This removes `Expression`'s mutual recursion with `Statement`.
1 parent 3bee475 commit 24de15f

File tree

16 files changed

+95
-119
lines changed

16 files changed

+95
-119
lines changed

‎src/Language/Fortran/AST.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -588,7 +588,7 @@ data FlushSpec a =
588588
deriving (Eq, Show, Data, Typeable, Generic, Functor)
589589

590590
data DoSpecification a =
591-
DoSpecification a SrcSpan (Statement a) (Expression a) (Maybe (Expression a))
591+
DoSpecification a SrcSpan (Expression a) (Expression a) (Expression a) (Maybe (Expression a))
592592
deriving (Eq, Show, Data, Typeable, Generic, Functor)
593593

594594
data Expression a =

‎src/Language/Fortran/Analysis.hs‎

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -241,6 +241,7 @@ lhsExprs x = concatMap lhsOfStmt (universeBi x)
241241
lhsOfStmt (StExpressionAssign _ _ e e') = e : onExprs e'
242242
lhsOfStmt (StCall _ _ _ (Just aexps)) = filter isLExpr argExps ++ concatMap onExprs argExps
243243
where argExps = map argExtractExpr . aStrip $ aexps
244+
lhsOfStmt s@(StDo _ _ _ _ (Just dospec)) = lhsOfStmt (dospecAsStmt dospec) ++ onExprs s
244245
lhsOfStmt s = onExprs s
245246

246247
onExprs :: (Data a, Data (c a)) => c a -> [Expression a]
@@ -273,19 +274,26 @@ allVars b = [ varName v | v@(ExpValue _ _ (ValVariable _)) <- uniBi b ]
273274
analyseAllLhsVars :: forall a . Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
274275
analyseAllLhsVars = (transformBi :: TransFunc Block ProgramFile a) analyseAllLhsVars1 .
275276
(transformBi :: TransFunc Statement ProgramFile a) analyseAllLhsVars1 .
276-
(transformBi :: TransFunc DoSpecification ProgramFile a) analyseAllLhsVars1
277+
(transformBi :: TransFunc DoSpecification ProgramFile a) analyseAllLhsVarsDoSpec
277278

278279
analyseAllLhsVars1 :: (Annotated f, Data (f (Analysis a)), Data a) => f (Analysis a) -> f (Analysis a)
279280
analyseAllLhsVars1 x = modifyAnnotation (\ a -> a { allLhsVarsAnn = computeAllLhsVars x }) x
280281

282+
analyseAllLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> DoSpecification (Analysis a)
283+
analyseAllLhsVarsDoSpec x = modifyAnnotation (\ a -> a { allLhsVarsAnn = allLhsVarsDoSpec x }) x
284+
285+
allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name]
286+
allLhsVarsDoSpec = computeAllLhsVars . dospecAsStmt
287+
281288
-- | Set of names found in the parts of an AST that are the target of
282289
-- an assignment statement.
283290
-- allLhsVars :: (Annotated b, Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name]
284291
allLhsVars :: Data a => Block (Analysis a) -> [Name]
285292
allLhsVars = allLhsVarsAnn . getAnnotation
286293

287-
allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name]
288-
allLhsVarsDoSpec = computeAllLhsVars
294+
dospecAsStmt :: DoSpecification a -> Statement a
295+
dospecAsStmt (DoSpecification a ss lhs rhs _e1 _me2) =
296+
StExpressionAssign a ss lhs rhs
289297

290298
-- | Set of names found in the parts of an AST that are the target of
291299
-- an assignment statement.
@@ -298,6 +306,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
298306
lhsOfStmt (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)
299307
| Just defs <- intrinsicDefs f = defs
300308
lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . argExtractExpr) (aStrip aexps)
309+
lhsOfStmt s@(StDo _ _ _ _ (Just dospec)) = lhsOfStmt (dospecAsStmt dospec) ++ onExprs s
301310
lhsOfStmt s = onExprs s
302311

303312
lhsOfDecls (Declarator _ _ e _ _ (Just e')) = match' e : onExprs e'
@@ -331,7 +340,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
331340
-- | Set of expressions used -- not defined -- by an AST-block.
332341
blockRhsExprs :: Data a => Block a -> [Expression a]
333342
blockRhsExprs (BlStatement _ _ _ s) = statementRhsExprs s
334-
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
343+
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ lhs rhs e1 e2)) _ _)
335344
| ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs
336345
| otherwise = universeBi (rhs, e1, e2)
337346
blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2)
@@ -346,8 +355,8 @@ statementRhsExprs (StExpressionAssign _ _ lhs rhs)
346355
statementRhsExprs StDeclaration{} = []
347356
statementRhsExprs (StIfLogical _ _ _ s) = statementRhsExprs s
348357
statementRhsExprs (StDo _ _ _ l s') = universeBi l ++ doSpecRhsExprs s'
349-
where doSpecRhsExprs (Just (DoSpecification _ _ s e1 e2)) =
350-
(e1 : universeBi e2) ++ statementRhsExprs s
358+
where doSpecRhsExprs (Just dospec@(DoSpecification _ _ _lhs _rhs e1 e2)) =
359+
(e1 : universeBi e2) ++ statementRhsExprs (dospecAsStmt dospec)
351360
doSpecRhsExprs Nothing = []
352361
statementRhsExprs s = universeBi s
353362

@@ -356,7 +365,7 @@ blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name]
356365
blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))
357366
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs)
358367
| otherwise = allVars rhs
359-
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
368+
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ lhs rhs e1 e2)) _ _)
360369
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs)
361370
| otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2
362371
blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ]

‎src/Language/Fortran/Analysis/BBlocks.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -411,7 +411,7 @@ perBlock b@(BlStatement _ _ _ StIfArithmetic{}) =
411411
-- Treat an arithmetic if similarly to a goto
412412
processLabel b >> addToBBlock b >> closeBBlock_
413413
perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do
414-
let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec
414+
let DoSpecification _ _ _ e1 e2 me3 = spec
415415
_ <- processFunctionCalls e1
416416
_ <- processFunctionCalls e2
417417
_ <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing
@@ -791,7 +791,7 @@ showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) =
791791
showExpr e2 ++ ", " ++
792792
showExpr e3 ++ ", " ++
793793
maybe "1" showExpr me4 ++ "\\l"
794-
where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec
794+
where DoSpecification _ _ e1 e2 e3 me4 = spec
795795
showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do"
796796
showBlock (BlComment{}) = ""
797797
showBlock b = "<unhandled block: " ++ show (toConstr (fmap (const ()) b)) ++ ">"

‎src/Language/Fortran/Parser/Fixed/Fortran66.y‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -171,10 +171,10 @@ DO_STATEMENT :: { Statement A0 }
171171
{ StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }
172172

173173
DO_SPECIFICATION :: { DoSpecification A0 }
174-
: EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR ',' INT_OR_VAR
175-
{ DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
176-
| EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR
177-
{ DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
174+
: ELEMENT '=' EXPRESSION ',' INT_OR_VAR ',' INT_OR_VAR
175+
{ DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) }
176+
| ELEMENT '=' EXPRESSION ',' INT_OR_VAR
177+
{ DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing }
178178

179179
INT_OR_VAR :: { Expression A0 }
180180
: INTEGER_LITERAL { $1 }

‎src/Language/Fortran/Parser/Fixed/Fortran77.y‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -289,8 +289,10 @@ DO_STATEMENT :: { Statement A0 }
289289
| do { StDo () (getSpan $1) Nothing Nothing Nothing }
290290

291291
DO_SPECIFICATION :: { DoSpecification A0 }
292-
: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
293-
| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
292+
: ELEMENT '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION
293+
{ DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) }
294+
| ELEMENT '=' EXPRESSION ',' EXPRESSION
295+
{ DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing }
294296

295297
EXECUTABLE_STATEMENT :: { Statement A0 }
296298
: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }

‎src/Language/Fortran/Parser/Free/Fortran2003.y‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1287,10 +1287,10 @@ RANGE :: { Index A0 }
12871287
{ IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }
12881288

12891289
DO_SPECIFICATION :: { DoSpecification A0 }
1290-
: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION
1291-
{ DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
1292-
| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION
1293-
{ DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
1290+
: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION
1291+
{ DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) }
1292+
| DATA_REF '=' EXPRESSION ',' EXPRESSION
1293+
{ DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing }
12941294

12951295
IMPLIED_DO :: { Expression A0 }
12961296
: '(' EXPRESSION ',' DO_SPECIFICATION ')'

‎src/Language/Fortran/Parser/Free/Fortran90.y‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1079,10 +1079,10 @@ RANGE :: { Index A0 }
10791079
{ IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }
10801080

10811081
DO_SPECIFICATION :: { DoSpecification A0 }
1082-
: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION
1083-
{ DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
1084-
| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION
1085-
{ DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
1082+
: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION
1083+
{ DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) }
1084+
| DATA_REF '=' EXPRESSION ',' EXPRESSION
1085+
{ DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing }
10861086

10871087
IMPLIED_DO :: { Expression A0 }
10881088
: '(' EXPRESSION ',' DO_SPECIFICATION ')'

‎src/Language/Fortran/Parser/Free/Fortran95.y‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1094,10 +1094,10 @@ RANGE :: { Index A0 }
10941094
{ IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }
10951095

10961096
DO_SPECIFICATION :: { DoSpecification A0 }
1097-
: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION
1098-
{ DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
1099-
| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION
1100-
{ DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
1097+
: DATA_REF '=' EXPRESSION ',' EXPRESSION ',' EXPRESSION
1098+
{ DoSpecification () (getTransSpan $1 $7) $1 $3 $5 (Just $7) }
1099+
| DATA_REF '=' EXPRESSION ',' EXPRESSION
1100+
{ DoSpecification () (getTransSpan $1 $5) $1 $3 $5 Nothing }
11011101

11021102
IMPLIED_DO :: { Expression A0 }
11031103
: '(' EXPRESSION ',' DO_SPECIFICATION ')'

‎src/Language/Fortran/PrettyPrint.hs‎

Lines changed: 3 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -870,16 +870,11 @@ instance Pretty (FlushSpec a) where
870870
pprint' v (FSErr _ _ e) = "err=" <> pprint' v e
871871

872872
instance Pretty (DoSpecification a) where
873-
pprint' v (DoSpecification _ _ s@StExpressionAssign{} limit mStride) =
874-
pprint' v s <> comma
875-
<+> pprint' v limit
873+
pprint' v (DoSpecification _ _ lhs rhs limit mStride) =
874+
(pprint' v lhs <+> equals <+> pprint' v rhs)
875+
<> comma <+> pprint' v limit
876876
<> comma <?+> pprint' v mStride
877877

878-
-- Given DoSpec. has a single constructor, the only way for pattern
879-
-- match above to fail is to have the wrong type of statement embedded
880-
-- in it.
881-
pprint' _ _ = error "Incorrect initialisation in DO specification."
882-
883878
instance Pretty (ControlPair a) where
884879
pprint' v (ControlPair _ _ mStr exp)
885880
| v >= Fortran77

‎test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -183,7 +183,6 @@ spec =
183183
sParser " f = a(1,2)" `shouldBe'` expectedSt
184184

185185
it "parses 'do 42 i = 10, 1, 1'" $ do
186-
let st = StExpressionAssign () u (varGen "i") (intGen 10)
187-
let doSpec = DoSpecification () u st (intGen 1) (Just $ intGen 1)
186+
let doSpec = DoSpecification () u (varGen "i") (intGen 10) (intGen 1) (Just $ intGen 1)
188187
let expectedSt = StDo () u Nothing (Just $ labelGen 42) (Just doSpec)
189188
sParser " do 42 i = 10, 1, 1" `shouldBe'` expectedSt

0 commit comments

Comments
 (0)