From c1b1265d7793c472033f26704eeb8137b5f8dafa Mon Sep 17 00:00:00 2001 From: Romain Date: Mon, 19 Jan 2026 11:30:24 +0100 Subject: [PATCH] adding generic classes for FAST CFGs --- src/FAST-Core-Model/FASTTCFGVisitor.trait.st | 21 +++ .../FASTAbstractBasicBlock.class.st | 106 +++++++++++++ src/FAST-Core-Tools/FASTBasicBlock.class.st | 59 +++++++ .../FASTConditionalBasicBlock.class.st | 91 +++++++++++ .../FASTGenericCFGBuilder.class.st | 150 ++++++++++++++++++ src/FAST-Core-Tools/FASTNullBlock.class.st | 42 +++++ .../FASTTryBasicBlock.class.st | 23 +++ 7 files changed, 492 insertions(+) create mode 100644 src/FAST-Core-Model/FASTTCFGVisitor.trait.st create mode 100644 src/FAST-Core-Tools/FASTAbstractBasicBlock.class.st create mode 100644 src/FAST-Core-Tools/FASTBasicBlock.class.st create mode 100644 src/FAST-Core-Tools/FASTConditionalBasicBlock.class.st create mode 100644 src/FAST-Core-Tools/FASTGenericCFGBuilder.class.st create mode 100644 src/FAST-Core-Tools/FASTNullBlock.class.st create mode 100644 src/FAST-Core-Tools/FASTTryBasicBlock.class.st diff --git a/src/FAST-Core-Model/FASTTCFGVisitor.trait.st b/src/FAST-Core-Model/FASTTCFGVisitor.trait.st new file mode 100644 index 0000000..c6d3197 --- /dev/null +++ b/src/FAST-Core-Model/FASTTCFGVisitor.trait.st @@ -0,0 +1,21 @@ +Trait { + #name : 'FASTTCFGVisitor', + #instVars : [ + '#cfgBuilder => FMProperty' + ], + #category : 'FAST-Core-Model-Traits', + #package : 'FAST-Core-Model', + #tag : 'Traits' +} + +{ #category : 'accessing' } +FASTTCFGVisitor >> cfgBuilder [ + + ^ cfgBuilder +] + +{ #category : 'accessing' } +FASTTCFGVisitor >> cfgBuilder: anObject [ + + cfgBuilder := anObject +] diff --git a/src/FAST-Core-Tools/FASTAbstractBasicBlock.class.st b/src/FAST-Core-Tools/FASTAbstractBasicBlock.class.st new file mode 100644 index 0000000..064d882 --- /dev/null +++ b/src/FAST-Core-Tools/FASTAbstractBasicBlock.class.st @@ -0,0 +1,106 @@ +" +Represent a block in the control flow graph + +a block has +- #statements in a FAST ast that it contains +- properties + - #start: for starting block in the CFG + - #final for final blocks in the CFG +- #nextBlocks that come after it in the CFG +" +Class { + #name : 'FASTAbstractBasicBlock', + #superclass : 'Object', + #instVars : [ + 'isStart', + 'statements' + ], + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'adding' } +FASTAbstractBasicBlock >> addStatement: aFASTStatement [ + + self statements add: aFASTStatement +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> firstStatement [ + + ^self isEmpty + ifTrue: [ nil ] + ifFalse: [ self statements first ] +] + +{ #category : 'initialization' } +FASTAbstractBasicBlock >> initialize [ + + super initialize. + + isStart := false. + statements := OrderedCollection new +] + +{ #category : 'initialization' } +FASTAbstractBasicBlock >> isConditional [ + + ^false +] + +{ #category : 'testing' } +FASTAbstractBasicBlock >> isEmpty [ + + ^self statements isEmpty +] + +{ #category : 'initialization' } +FASTAbstractBasicBlock >> isFinal [ + "The block last statement is also the last executed one in the CFG" + + ^(self nextBlocks isEmpty) or: + [ self nextBlocks anySatisfy: [ :block | block isNil or: [ block isNullBlock]] ] +] + +{ #category : 'testing' } +FASTAbstractBasicBlock >> isNullBlock [ + + ^false +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> isStart [ + + ^ isStart +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> isStart: anObject [ + + isStart := anObject +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> lastStatement [ + + ^ self statements last +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> nextBlocks [ + + self subclassResponsibility +] + +{ #category : 'printing' } +FASTAbstractBasicBlock >> sourceCode [ + + self subclassResponsibility +] + +{ #category : 'accessing' } +FASTAbstractBasicBlock >> statements [ + + ^ statements +] diff --git a/src/FAST-Core-Tools/FASTBasicBlock.class.st b/src/FAST-Core-Tools/FASTBasicBlock.class.st new file mode 100644 index 0000000..400ada3 --- /dev/null +++ b/src/FAST-Core-Tools/FASTBasicBlock.class.st @@ -0,0 +1,59 @@ +" +A ""normal"" basic block in the CFG + +it contains a list of statement (without branching) and have a successor block (#nextBlock) +" +Class { + #name : 'FASTBasicBlock', + #superclass : 'FASTAbstractBasicBlock', + #instVars : [ + 'nextBlock' + ], + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'accessing' } +FASTBasicBlock >> nextBlock [ + + ^ nextBlock +] + +{ #category : 'accessing' } +FASTBasicBlock >> nextBlock: anObject [ + "puts aBlock in #nextBlock unless it already contains aNullBlock" + (nextBlock isNotNil and: [ nextBlock isNullBlock ]) + ifTrue: [ ^self ]. + + nextBlock := anObject +] + +{ #category : 'accessing' } +FASTBasicBlock >> nextBlockForValues [ + + ^{ #next -> self nextBlock } +] + +{ #category : 'accessing' } +FASTBasicBlock >> nextBlocks [ + + ^nextBlock + ifNil: [ #() ] + ifNotNil: [ { nextBlock } ] +] + +{ #category : 'printing' } +FASTBasicBlock >> sourceCode [ + + | exporter | + exporter := self firstStatement exporterForCFG. + ^ String streamContents: [ :s | + self statements do: [ :stmt | + s nextPutAll: (exporter export: stmt) ] ] + + "^ self firstStatement exporterForCFG export: + (self firstStatement newStatementBlockForCFG + statements: self statements; + yourself)" +] diff --git a/src/FAST-Core-Tools/FASTConditionalBasicBlock.class.st b/src/FAST-Core-Tools/FASTConditionalBasicBlock.class.st new file mode 100644 index 0000000..8d93670 --- /dev/null +++ b/src/FAST-Core-Tools/FASTConditionalBasicBlock.class.st @@ -0,0 +1,91 @@ +" +A conditional or branching block in the CFG + +It contains one statement which is a conditional or branching statement + +It has several successors, each associated to a value +For example an if-statement will be represented has a ConditionalBasicBlock and will have two succesors associated respectively to the `true` and `false` values +" +Class { + #name : 'FASTConditionalBasicBlock', + #superclass : 'FASTAbstractBasicBlock', + #instVars : [ + 'nextBlocks' + ], + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'adding' } +FASTConditionalBasicBlock >> addStatement: aStatement [ + + self isEmpty ifFalse: [ AssertionFailure signal: 'ConditionalBasicBlocks can have only one statement' ]. + + super addStatement: aStatement +] + +{ #category : 'initialization' } +FASTConditionalBasicBlock >> initialize [ + + super initialize. + + nextBlocks := Dictionary new: 2 +] + +{ #category : 'initialization' } +FASTConditionalBasicBlock >> isConditional [ + + ^true +] + +{ #category : 'initialization' } +FASTConditionalBasicBlock >> isFinal [ + + super isFinal ifTrue: [ ^true ]. + nextBlocks valuesDo: [ :nextBlock | nextBlock ifNil: [ ^true ] ]. + ^false +] + +{ #category : 'accessing' } +FASTConditionalBasicBlock >> nextBlock: aBlock onValue: aValue [ + "if the next block for aValue is not a NullBlock, then set it to aBlock, otherwise leave the NullBlock" + | currentNext | + + currentNext := nextBlocks at: aValue ifAbsent: [ self ]. + currentNext ifNil: [ currentNext := self ]. + + currentNext isNullBlock ifTrue: [ ^self ]. + + nextBlocks at: aValue put: aBlock +] + +{ #category : 'accessing' } +FASTConditionalBasicBlock >> nextBlockForValue: aValue [ + + ^nextBlocks at: aValue ifAbsent: [ nil ] +] + +{ #category : 'accessing' } +FASTConditionalBasicBlock >> nextBlockForValues [ + + ^nextBlocks associations +] + +{ #category : 'accessing' } +FASTConditionalBasicBlock >> nextBlocks [ + + ^nextBlocks values +] + +{ #category : 'printing' } +FASTConditionalBasicBlock >> sourceCode [ + + ^self firstStatement exportForCFG +] + +{ #category : 'printing' } +FASTConditionalBasicBlock >> statement: aFASTFortranStatement [ + + self addStatement: aFASTFortranStatement +] diff --git a/src/FAST-Core-Tools/FASTGenericCFGBuilder.class.st b/src/FAST-Core-Tools/FASTGenericCFGBuilder.class.st new file mode 100644 index 0000000..a61aaae --- /dev/null +++ b/src/FAST-Core-Tools/FASTGenericCFGBuilder.class.st @@ -0,0 +1,150 @@ +Class { + #name : 'FASTGenericCFGBuilder', + #superclass : 'Object', + #instVars : [ + 'basicBlocks', + 'currentBlock', + 'parentLoopBlocks', + 'pendingNextBlock', + 'cfgVisitor' + ], + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> addPendingNextBlockAction: settingAction [ + "settingAction is a pharo block with one argument (a BasicBlock) and is used to set the successor of another block + when we will know it + For now, sets the nextBlock to nil and register the settingAction for future use" + + settingAction value: nil. + pendingNextBlock add: settingAction +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> basicBlocks [ + + ^ basicBlocks +] + +{ #category : 'as yet unclassified' } +FASTGenericCFGBuilder >> buildCFGForModel: aFASTModel [ + + aFASTModel accept: cfgVisitor. + ^ self basicBlocks detect: [ :block | block isStart ] +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> cfgVisitor [ + + ^ cfgVisitor +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> cfgVisitor: anObject [ + + cfgVisitor := anObject. + "setting the variable for double dispatch" + cfgVisitor cfgBuilder: self +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> chainPendingBlocksTo: newBlock [ + + pendingNextBlock copy do: [ :settingAction | + self runChainAction: settingAction with: newBlock ]. +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> closeCurrentBlock [ + + currentBlock := nil +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> currentBlock [ + + ^ currentBlock +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> findParentLoopBlock: aLabel [ + "if there is no label to the EXIT, take the first loop block in the stack + otherwise, search for the loop with the right label" + + aLabel ifNil: [ ^parentLoopBlocks top ]. + ^nil +] + +{ #category : 'initialization' } +FASTGenericCFGBuilder >> initialize [ + + super initialize. + + basicBlocks := OrderedCollection new. + parentLoopBlocks := Stack new. + pendingNextBlock := OrderedCollection new +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> newBasicBlock: aBasicBlockClass [ + "creates a new BasicBlock and set it to currentBlock + typically called inside: `currentBlock nextBlock: (self newBasicBlock:)` to chain the new block + to the previous currentBlock" + + | newBlock | + newBlock := aBasicBlockClass new. + basicBlocks add: newBlock. + currentBlock := newBlock. + + self chainPendingBlocksTo: newBlock. + + ^ newBlock +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> newConditionalBlock: aFASTConditionalStatement [ + + ^(self newBasicBlock: FASTConditionalBasicBlock) + statement: aFASTConditionalStatement; + yourself +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> parentLoopBlocks [ + + ^ parentLoopBlocks +] + +{ #category : 'accessing' } +FASTGenericCFGBuilder >> pendingNextBlock [ + + ^ pendingNextBlock +] + +{ #category : 'removing' } +FASTGenericCFGBuilder >> removeLastPendingNextBlockAction [ + + pendingNextBlock removeLast +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> removePendingActionFor: aBlock [ + "pending action are pharo blocks with no clear link to the BasicBlock they modify + We use #copiedValueAt: to get this information from the pharo block + This is an ugly hack" + + pendingNextBlock copy do: [ :action | + ((action copiedValueAt: 1) = aBlock) + ifTrue: [pendingNextBlock remove: action] + ] +] + +{ #category : 'basicBlocks' } +FASTGenericCFGBuilder >> runChainAction: settingAction with: aBasicBlock [ + + settingAction value: aBasicBlock. + pendingNextBlock remove: settingAction +] diff --git a/src/FAST-Core-Tools/FASTNullBlock.class.st b/src/FAST-Core-Tools/FASTNullBlock.class.st new file mode 100644 index 0000000..b14baf2 --- /dev/null +++ b/src/FAST-Core-Tools/FASTNullBlock.class.st @@ -0,0 +1,42 @@ +" +A ""virtual"" block representing a forced end of the control flow. + +NullBlock are not added in the list of blocks of the CFG, they appear only as #nextBlock of a final block +" +Class { + #name : 'FASTNullBlock', + #superclass : 'FASTAbstractBasicBlock', + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'testing' } +FASTNullBlock >> isEmpty [ + + ^false +] + +{ #category : 'testing' } +FASTNullBlock >> isFinal [ + + ^false +] + +{ #category : 'testing' } +FASTNullBlock >> isNullBlock [ + + ^true +] + +{ #category : 'testing' } +FASTNullBlock >> nextBlocks [ + + ^#() +] + +{ #category : 'testing' } +FASTNullBlock >> sourceCode [ + + ^'' +] diff --git a/src/FAST-Core-Tools/FASTTryBasicBlock.class.st b/src/FAST-Core-Tools/FASTTryBasicBlock.class.st new file mode 100644 index 0000000..2687fd2 --- /dev/null +++ b/src/FAST-Core-Tools/FASTTryBasicBlock.class.st @@ -0,0 +1,23 @@ +Class { + #name : 'FASTTryBasicBlock', + #superclass : 'FASTConditionalBasicBlock', + #category : 'FAST-Core-Tools-CFG', + #package : 'FAST-Core-Tools', + #tag : 'CFG' +} + +{ #category : 'adding' } +FASTTryBasicBlock >> addStatement: aFASTStatement [ + + self statements add: aFASTStatement +] + +{ #category : 'printing' } +FASTTryBasicBlock >> sourceCode [ + + | exporter | + exporter := self firstStatement exporterForCFG. + ^ String streamContents: [ :s | + self statements do: [ :stmt | + s nextPutAll: (exporter export: stmt) ] ] +]