Skip to content

Commit f8ec3e2

Browse files
raehikraehik
committed
start block node refactor
1 parent 606048d commit f8ec3e2

File tree

5 files changed

+61
-39
lines changed

5 files changed

+61
-39
lines changed

‎src/Language/Fortran/AST.hs‎

Lines changed: 27 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,7 @@ module Language.Fortran.AST
8686
, DoSpecification(..)
8787
, ProgramUnitName(..)
8888
, Kind
89+
, BlockConstructStart(..)
8990

9091
-- * Node annotations & related typeclasses
9192
, A0
@@ -301,6 +302,13 @@ programUnitSubprograms PUComment{} = Nothing
301302
newtype Comment a = Comment String
302303
deriving (Eq, Show, Data, Typeable, Generic, Functor)
303304

305+
data BlockConstructStart a =
306+
BlockConstructStart a SrcSpan
307+
(Maybe (Expression a))
308+
(Maybe String)
309+
(Maybe (Comment a))
310+
deriving (Eq, Show, Data, Typeable, Generic, Functor)
311+
304312
data Block a =
305313
BlStatement a SrcSpan
306314
(Maybe (Expression a)) -- ^ Label
@@ -329,16 +337,14 @@ data Block a =
329337
(Maybe (Expression a)) -- ^ Label to END SELECT
330338

331339
| BlDo a SrcSpan
332-
(Maybe (Expression a)) -- ^ Label
333-
(Maybe String) -- ^ Construct name
340+
(BlockConstructStart a)
334341
(Maybe (Expression a)) -- ^ Target label
335342
(Maybe (DoSpecification a)) -- ^ Do Specification
336343
[ Block a ] -- ^ Body
337344
(Maybe (Expression a)) -- ^ Label to END DO
338345

339346
| BlDoWhile a SrcSpan
340-
(Maybe (Expression a)) -- ^ Label
341-
(Maybe String) -- ^ Construct name
347+
(BlockConstructStart a)
342348
(Maybe (Expression a)) -- ^ Target label
343349
(Expression a) -- ^ Condition
344350
[ Block a ] -- ^ Body
@@ -754,6 +760,7 @@ instance FirstParameter (Declarator a) a
754760
instance FirstParameter (DimensionDeclarator a) a
755761
instance FirstParameter (ControlPair a) a
756762
instance FirstParameter (AllocOpt a) a
763+
instance FirstParameter (BlockConstructStart a) a
757764

758765
instance SecondParameter (ProgramUnit a) SrcSpan
759766
instance SecondParameter (Prefix a) SrcSpan
@@ -783,6 +790,7 @@ instance SecondParameter (Declarator a) SrcSpan
783790
instance SecondParameter (DimensionDeclarator a) SrcSpan
784791
instance SecondParameter (ControlPair a) SrcSpan
785792
instance SecondParameter (AllocOpt a) SrcSpan
793+
instance SecondParameter (BlockConstructStart a) SrcSpan
786794

787795
instance Annotated (AList t)
788796
instance Annotated ProgramUnit
@@ -811,6 +819,7 @@ instance Annotated Declarator
811819
instance Annotated DimensionDeclarator
812820
instance Annotated ControlPair
813821
instance Annotated AllocOpt
822+
instance Annotated BlockConstructStart
814823

815824
instance Spanned (ProgramUnit a)
816825
instance Spanned (Prefix a)
@@ -840,6 +849,7 @@ instance Spanned (Declarator a)
840849
instance Spanned (DimensionDeclarator a)
841850
instance Spanned (ControlPair a)
842851
instance Spanned (AllocOpt a)
852+
instance Spanned (BlockConstructStart a)
843853

844854
instance Spanned (ProgramFile a) where
845855
getSpan (ProgramFile _ pus) =
@@ -854,25 +864,30 @@ class Labeled f where
854864
getLastLabel :: f a -> Maybe (Expression a)
855865
setLabel :: f a -> Expression a -> f a
856866

867+
instance Labeled BlockConstructStart where
868+
getLabel (BlockConstructStart _ _ l _ _) = l
869+
getLastLabel = const Nothing
870+
setLabel (BlockConstructStart a ss _ s c) l = BlockConstructStart a ss (Just l) s c
871+
857872
instance Labeled Block where
858873
getLabel (BlStatement _ _ l _) = l
859874
getLabel (BlIf _ _ l _ _ _ _) = l
860875
getLabel (BlCase _ _ l _ _ _ _ _) = l
861-
getLabel (BlDo _ _ l _ _ _ _ _) = l
862-
getLabel (BlDoWhile _ _ l _ _ _ _ _) = l
876+
getLabel (BlDo _ _ x _ _ _ _) = getLabel x
877+
getLabel (BlDoWhile _ _ x _ _ _ _) = getLabel x
863878
getLabel _ = Nothing
864879

865880
getLastLabel b@BlStatement{} = getLabel b
866881
getLastLabel (BlIf _ _ _ _ _ _ l) = l
867882
getLastLabel (BlCase _ _ _ _ _ _ _ l) = l
868-
getLastLabel (BlDo _ _ _ _ _ _ _ l) = l
869-
getLastLabel (BlDoWhile _ _ _ _ _ _ _ l) = l
883+
getLastLabel (BlDo _ _ _ _ _ _ l) = l
884+
getLastLabel (BlDoWhile _ _ _ _ _ _ l) = l
870885
getLastLabel _ = Nothing
871886

872887
setLabel (BlStatement a s _ st) l = BlStatement a s (Just l) st
873888
setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el
874-
setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el
875-
setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el
889+
setLabel (BlDo a s st tl spec bs el) l = BlDo a s (setLabel st l) tl spec bs el
890+
setLabel (BlDoWhile a s st tl spec bs el) l = BlDoWhile a s (setLabel st l) tl spec bs el
876891
setLabel b _ = b
877892

878893
data ProgramUnitName =
@@ -949,6 +964,7 @@ instance Out a => Out (AllocOpt a)
949964
instance Out UnaryOp
950965
instance Out BinaryOp
951966
instance Out a => Out (ForallHeader a)
967+
instance Out a => Out (BlockConstructStart a)
952968

953969
-- Classifiers on statement and blocks ASTs
954970

@@ -1042,3 +1058,4 @@ instance NFData BinaryOp
10421058
instance NFData Only
10431059
instance NFData ModuleNature
10441060
instance NFData Intent
1061+
instance NFData a => NFData (BlockConstructStart a)

‎src/Language/Fortran/Analysis.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -335,10 +335,10 @@ computeAllLhsVars = concatMap lhsOfStmt . universeBi
335335
-- | Set of expressions used -- not defined -- by an AST-block.
336336
blockRhsExprs :: Data a => Block a -> [Expression a]
337337
blockRhsExprs (BlStatement _ _ _ s) = statementRhsExprs s
338-
blockRhsExprs (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
338+
blockRhsExprs (BlDo _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
339339
| ExpSubscript _ _ _ subs <- lhs = universeBi (rhs, e1, e2) ++ universeBi subs
340340
| otherwise = universeBi (rhs, e1, e2)
341-
blockRhsExprs (BlDoWhile _ _ e1 _ _ e2 _ _) = universeBi (e1, e2)
341+
blockRhsExprs (BlDoWhile _ _ e1 _ e2 _ _) = universeBi (e1, e2)
342342
blockRhsExprs (BlIf _ _ e1 _ e2 _ _) = universeBi (e1, e2)
343343
blockRhsExprs b = universeBi b
344344

@@ -360,7 +360,7 @@ blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name]
360360
blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))
361361
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs)
362362
| otherwise = allVars rhs
363-
blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
363+
blockVarUses (BlDo _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)
364364
| ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs)
365365
| otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2
366366
blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ]
@@ -372,14 +372,14 @@ blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d
372372
blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))
373373
| Just uses <- intrinsicUses f = uses
374374
blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps
375-
blockVarUses (BlDoWhile _ _ e1 _ _ e2 _ _) = maybe [] allVars e1 ++ allVars e2
375+
blockVarUses (BlDoWhile _ _ e1 _ e2 _ _) = maybe [] allVars (Just e1) ++ allVars e2
376376
blockVarUses (BlIf _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2
377377
blockVarUses b = allVars b
378378

379379
-- | Set of names defined by an AST-block.
380380
blockVarDefs :: Data a => Block (Analysis a) -> [Name]
381381
blockVarDefs b@BlStatement{} = allLhsVars b
382-
blockVarDefs (BlDo _ _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec
382+
blockVarDefs (BlDo _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec
383383
blockVarDefs _ = []
384384

385385
-- form name: n[i]

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

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -91,6 +91,7 @@ labelWithinBlocks = perBlock'
9191
perBlock' :: Block (Analysis a) -> Block (Analysis a)
9292
perBlock' b =
9393
case b of
94+
-- TODO
9495
BlStatement a s e st -> BlStatement a s (mfill i e) (fill i st)
9596
BlIf a s e1 mn e2 bss el -> BlIf a s (mfill i e1) mn (mmfill i e2) bss el
9697
BlCase a s e1 mn e2 is bss el -> BlCase a s (mfill i e1) mn (fill i e2) (mmfill i is) bss el
@@ -407,14 +408,14 @@ perBlock b@(BlStatement a ss _ (StIfLogical _ _ exp stm)) = do
407408
perBlock b@(BlStatement _ _ _ StIfArithmetic{}) =
408409
-- Treat an arithmetic if similarly to a goto
409410
processLabel b >> addToBBlock b >> closeBBlock_
410-
perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do
411+
perBlock b@(BlDo _ _ _ _ (Just spec) bs _) = do
411412
let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec
412413
_ <- processFunctionCalls e1
413414
_ <- processFunctionCalls e2
414415
_ <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing
415416
perDoBlock Nothing b bs
416-
perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs
417-
perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs
417+
perBlock b@(BlDo _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs
418+
perBlock b@(BlDoWhile _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs
418419
perBlock b@(BlStatement _ _ _ StReturn{}) =
419420
processLabel b >> addToBBlock b >> closeBBlock_
420421
perBlock b@(BlStatement _ _ _ StGotoUnconditional{}) =
@@ -555,8 +556,8 @@ genTemp str = do
555556
-- Strip nested code not necessary since it is duplicated in another
556557
-- basic block.
557558
stripNestedBlocks :: Block a -> Block a
558-
stripNestedBlocks (BlDo a s l mn tl ds _ el) = BlDo a s l mn tl ds [] el
559-
stripNestedBlocks (BlDoWhile a s l tl n e _ el) = BlDoWhile a s l tl n e [] el
559+
stripNestedBlocks (BlDo a s x tl ds _ el) = BlDo a s x tl ds [] el
560+
stripNestedBlocks (BlDoWhile a s x n e _ el) = BlDoWhile a s x n e [] el
560561
stripNestedBlocks (BlIf a s l mn exps _ el) = BlIf a s l mn exps [] el
561562
stripNestedBlocks (BlCase a s l mn sc inds _ el) = BlCase a s l mn sc inds [] el
562563
stripNestedBlocks b = b
@@ -784,13 +785,13 @@ showBlock (BlStatement _ _ mlab st)
784785
StExit{} -> "exit"
785786
_ -> "<unhandled statement: " ++ show (toConstr (fmap (const ()) st)) ++ ">"
786787
showBlock (BlIf _ _ mlab _ (Just e1:_) _ _) = showLab mlab ++ "if " ++ showExpr e1 ++ "\\l"
787-
showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) =
788-
showLab mlab ++ "do " ++ showExpr e1 ++ " <- " ++
788+
showBlock (BlDo _ _ x _ (Just spec) _ _) =
789+
showLab (getLabel x) ++ "do " ++ showExpr e1 ++ " <- " ++
789790
showExpr e2 ++ ", " ++
790791
showExpr e3 ++ ", " ++
791792
maybe "1" showExpr me4 ++ "\\l"
792793
where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec
793-
showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do"
794+
showBlock (BlDo _ _ _ _ Nothing _ _) = "do"
794795
showBlock (BlComment{}) = ""
795796
showBlock b = "<unhandled block: " ++ show (toConstr (fmap (const ()) b)) ++ ">"
796797

‎src/Language/Fortran/PrettyPrint.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -286,7 +286,7 @@ instance IndentablePretty (Block a) where
286286
abstract | v >= Fortran2003 && abstractp = "abstract "
287287
| otherwise = empty
288288

289-
pprint v (BlDo _ _ mLabel mn tl doSpec body el) i
289+
pprint v (BlDo _ _ (BlockConstructStart _ _ mLabel mn _) tl doSpec body el) i
290290
| v >= Fortran77Extended =
291291
labeledIndent mLabel
292292
(pprint' v mn <?> colon <+>
@@ -310,7 +310,7 @@ instance IndentablePretty (Block a) where
310310
then indent i (pprint' v label <+> stDoc)
311311
else pprint' v mLabel `overlay` indent i stDoc
312312

313-
pprint v (BlDoWhile _ _ mLabel mName mTarget cond body el) i
313+
pprint v (BlDoWhile _ _ (BlockConstructStart _ _ mLabel mName _) mTarget cond body el) i
314314
| v >= Fortran77Extended =
315315
labeledIndent mLabel
316316
(pprint' v mName <?> colon <+>

‎src/Language/Fortran/Transformation/Grouping.hs‎

Lines changed: 18 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -85,17 +85,19 @@ groupDo' (b:bs) = b' : bs'
8585
(b', bs') = case b of
8686
BlStatement a s label st
8787
-- Do While statement
88-
| StDoWhile _ _ mTarget Nothing condition <- st ->
88+
| StDoWhile a ss mName Nothing condition <- st ->
8989
let ( blocks, leftOverBlocks, endLabel, stEnd ) =
90-
collectNonDoBlocks groupedBlocks mTarget
91-
in ( BlDoWhile a (getTransSpan s stEnd) label mTarget Nothing condition blocks endLabel
90+
collectNonDoBlocks groupedBlocks mName
91+
blStartStmt = BlockConstructStart a ss Nothing mName Nothing
92+
in ( BlDoWhile a (getTransSpan s stEnd) blStartStmt Nothing condition blocks endLabel
9293
, leftOverBlocks)
9394
-- Vanilla do statement
94-
| StDo _ _ mName Nothing doSpec <- st ->
95+
| StDo a ss mName Nothing doSpec <- st ->
9596
let ( blocks, leftOverBlocks, endLabel, stEnd ) =
9697
collectNonDoBlocks groupedBlocks mName
97-
in ( BlDo a (getTransSpan s stEnd) label mName Nothing doSpec blocks endLabel
98-
, leftOverBlocks)
98+
blStartStmt = BlockConstructStart a ss Nothing mName Nothing
99+
in ( BlDo a (getTransSpan s stEnd) blStartStmt Nothing doSpec blocks endLabel
100+
, leftOverBlocks)
99101
b'' | containsGroups b'' ->
100102
( applyGroupingToSubblocks groupDo' b'', groupedBlocks )
101103
_ -> ( b, groupedBlocks )
@@ -137,16 +139,18 @@ groupLabeledDo' (b:bs) = b' : bs'
137139
where
138140
(b', bs') = case b of
139141
BlStatement a s label
140-
(StDo _ _ mn tl@Just{} doSpec) ->
142+
(StDo a' ss' mn tl@Just{} doSpec) ->
141143
let ( blocks, leftOverBlocks, lastLabel ) =
142144
collectNonLabeledDoBlocks tl groupedBlocks
143-
in ( BlDo a (getTransSpan s blocks) label mn tl doSpec blocks lastLabel
145+
blStartStmt = BlockConstructStart a' ss' label mn Nothing
146+
in ( BlDo a (getTransSpan s blocks) blStartStmt tl doSpec blocks lastLabel
144147
, leftOverBlocks )
145148
BlStatement a s label
146-
(StDoWhile _ _ mn tl@Just{} cond) ->
149+
(StDoWhile a' ss' mn tl@Just{} cond) ->
147150
let ( blocks, leftOverBlocks, lastLabel ) =
148151
collectNonLabeledDoBlocks tl groupedBlocks
149-
in ( BlDoWhile a (getTransSpan s blocks) label mn tl cond blocks lastLabel
152+
blStartStmt = BlockConstructStart a' ss' label mn Nothing
153+
in ( BlDoWhile a (getTransSpan s blocks) blStartStmt tl cond blocks lastLabel
150154
, leftOverBlocks )
151155
b'' | containsGroups b'' ->
152156
( applyGroupingToSubblocks groupLabeledDo' b'', groupedBlocks )
@@ -210,10 +214,10 @@ applyGroupingToSubblocks f b
210214
BlIf a s l mn conds (map f blocks) el
211215
| BlCase a s l mn scrutinee conds blocks el <- b =
212216
BlCase a s l mn scrutinee conds (map f blocks) el
213-
| BlDo a s l n tl doSpec blocks el <- b =
214-
BlDo a s l n tl doSpec (f blocks) el
215-
| BlDoWhile a s l n tl doSpec blocks el <- b =
216-
BlDoWhile a s l n tl doSpec (f blocks) el
217+
| BlDo a s x tl doSpec blocks el <- b =
218+
BlDo a s x tl doSpec (f blocks) el
219+
| BlDoWhile a s x tl doSpec blocks el <- b =
220+
BlDoWhile a s x tl doSpec (f blocks) el
217221
| BlInterface{} <- b =
218222
error "Interface blocks do not have groupable subblocks. Must not occur."
219223
| BlComment{} <- b =

0 commit comments

Comments
 (0)