Skip to content

Commit e2a4ebe

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

File tree

16 files changed

+94
-117
lines changed

16 files changed

+94
-117
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: 15 additions & 5 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 (StDo _ _ _ _ (Just dospec)) = lhsOfStmt $ dospecAsStmt dospec
244245
lhsOfStmt s = onExprs s
245246

246247
onExprs :: (Data a, Data (c a)) => c a -> [Expression a]
@@ -285,10 +286,17 @@ allLhsVars :: Data a => Block (Analysis a) -> [Name]
285286
allLhsVars = allLhsVarsAnn . getAnnotation
286287

287288
allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name]
288-
allLhsVarsDoSpec = computeAllLhsVars
289+
allLhsVarsDoSpec = computeAllLhsVars . dospecAsStmt
290+
291+
dospecAsStmt :: DoSpecification a -> Statement a
292+
dospecAsStmt (DoSpecification a ss lhs rhs _e1 _me2) =
293+
StExpressionAssign a ss lhs rhs
289294

290295
-- | Set of names found in the parts of an AST that are the target of
291296
-- an assignment statement.
297+
--
298+
-- TODO now that dospecs don't store a Statement explicitly, they won't get
299+
-- caught here. urgh
292300
computeAllLhsVars :: forall a b . (Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name]
293301
computeAllLhsVars = concatMap lhsOfStmt . universeBi
294302
where
@@ -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 (StDo _ _ _ _ (Just dospec)) = lhsOfStmt $ dospecAsStmt dospec
301310
lhsOfStmt s = onExprs s
302311

303312
lhsOfDecls (Declarator _ _ e _ _ (Just e')) = match' e : onExprs e'
@@ -308,6 +317,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
308317

309318
lhsOfExp :: Expression (Analysis a) -> [Name]
310319
lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = concatMap (match . argExtractExpr) (aStrip aexps)
320+
-- TODO do I need to handle ExpImpliedDo here? (shouldn't do, right)
311321
lhsOfExp _ = []
312322

313323
-- Match and give the varname for LHS of statement
@@ -331,7 +341,7 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
331341
-- | Set of expressions used -- not defined -- by an AST-block.
332342
blockRhsExprs :: Data a => Block a -> [Expression a]
333343
blockRhsExprs (BlStatement _ _ _ s) = statementRhsExprs s
334-
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
344+
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ lhs rhs e1 e2)) _ _)
335345
| ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs
336346
| otherwise = universeBi (rhs, e1, e2)
337347
blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2)
@@ -346,8 +356,8 @@ statementRhsExprs (StExpressionAssign _ _ lhs rhs)
346356
statementRhsExprs StDeclaration{} = []
347357
statementRhsExprs (StIfLogical _ _ _ s) = statementRhsExprs s
348358
statementRhsExprs (StDo _ _ _ l s') = universeBi l ++ doSpecRhsExprs s'
349-
where doSpecRhsExprs (Just (DoSpecification _ _ s e1 e2)) =
350-
(e1 : universeBi e2) ++ statementRhsExprs s
359+
where doSpecRhsExprs (Just dospec@(DoSpecification _ _ _lhs _rhs e1 e2)) =
360+
(e1 : universeBi e2) ++ statementRhsExprs (dospecAsStmt dospec)
351361
doSpecRhsExprs Nothing = []
352362
statementRhsExprs s = universeBi s
353363

@@ -356,7 +366,7 @@ blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name]
356366
blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))
357367
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs)
358368
| otherwise = allVars rhs
359-
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
369+
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ lhs rhs e1 e2)) _ _)
360370
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs)
361371
| otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2
362372
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)