Merge pull request #31 from janvrany/pr/misc-improvements-08

Misc improvements 8
janvrany · Oct 17, 2023 · effa1a0 · effa1a0
2 parents e313019 + cb9d8bb
commit effa1a0
Show file tree

Hide file tree

Showing 7 changed files with 105 additions and 4 deletions.
diff --git a/src/BaselineOfTinyrossa/BaselineOfTinyrossa.class.st b/src/BaselineOfTinyrossa/BaselineOfTinyrossa.class.st
@@ -25,6 +25,10 @@ BaselineOfTinyrossa >> baseline: spec [
 			spec baseline: 'LibUnix' with: [
 				spec repository: 'github://janvrany/pharo-hacks'.
 			].
+
+			spec baseline: 'Roassal3' with: [
+				spec repository: 'github://ObjectProfile/Roassal3:v0.9.2'
+			].
 
 			spec
 				package: #'Tinyrossa' with:[
@@ -49,7 +53,8 @@ BaselineOfTinyrossa >> baseline: spec [
 					spec requires: 'Tinyrossa-Tests'
 				];
 				package: #'Tinyrossa-Tools-Pharo' with: [
-					spec requires: 'Tinyrossa'
+					spec requires: 'Tinyrossa'.
+					spec requires: 'Roassal3'.
 				];
 				yourself.
 		]

diff --git a/src/Tinyrossa-Tools-Pharo/TRCFG.extension.st b/src/Tinyrossa-Tools-Pharo/TRCFG.extension.st
@@ -0,0 +1,39 @@
+Extension { #name : #TRCFG }
+
+{ #category : #'*Tinyrossa-Tools-Pharo' }
+TRCFG >> gtInspectorCFGIn: composite [
+	<gtInspectorPresentationOrder: -10>
+ 	composite roassal3 title: 'CFG'; initializeCanvas: [ 
+		| canvas blocksG edges |
+
+		canvas := RSCanvas new.
+		blocksG := RSGroup new.
+		self preorderDo:[:block | 
+			| box label node |
+
+			label := RSLabel new text: block name.
+			box := RSShapeFactory box
+							border: (RSBorder new width: 2; color: Color black);
+							cornerRadius: 5;
+							color: (Color gray: 0.9);
+							width: label encompassingRectangle width + 16;
+							height: label encompassingRectangle height + 16.	
+			RSLocation new center; outer; stick: label on: box.
+			node := (RSComposite new model: block; shapes: { box . label }) @ RSDraggable.
+
+			blocksG add: node. 
+			canvas add: node
+		].
+
+		edges := RSEdgeBuilder arrowedLine
+							attachPoint: RSBorderAttachPoint new;
+							yourself. 
+
+		edges
+			canvas: canvas; "moveBehind;" width: 2;
+		 	shapes: blocksG; connectToAll: #successors.
+
+		RSVerticalLineLayout on: blocksG. 
+		canvas @ RSCanvasController 
+	]
+]
diff --git a/src/Tinyrossa-Tools-Pharo/TRCompilation.extension.st b/src/Tinyrossa-Tools-Pharo/TRCompilation.extension.st
@@ -29,6 +29,13 @@ TRCompilation >> gtInspectorANFIn: composite [
 
 ]
 
+{ #category : #'*Tinyrossa-Tools-Pharo' }
+TRCompilation >> gtInspectorCFGIn: composite [
+	<gtInspectorPresentationOrder: 80>
+
+	cfg gtInspectorCFGIn: composite.
+]
+
 { #category : #'*Tinyrossa-Tools-Pharo' }
 TRCompilation >> gtInspectorInstructionsIn: composite [
 	<gtInspectorPresentationOrder: 60>

diff --git a/src/Tinyrossa-Tools-Pharo/TRILBlock.extension.st b/src/Tinyrossa-Tools-Pharo/TRILBlock.extension.st
@@ -0,0 +1,36 @@
+Extension { #name : #TRILBlock }
+
+{ #category : #'*Tinyrossa-Tools-Pharo' }
+TRILBlock >> gtInspectorTRILIn: composite [
+	<gtInspectorPresentationOrder: 35>
+
+	| printer builder |
+
+	builder := [ :node | 
+		| printed |
+
+		printed := printer hasPrinted: node.
+		{ node. 
+			printer print: node.
+			printed ifTrue:[ #() ] ifFalse: [ node children collect: builder ] }
+	].
+
+	composite fastTreeTable 
+		title: 'TRIL';
+		rootsExpanded;
+		display: [ :comp | printer := TRILNodePrinter new. treetops collect: builder ];
+		children: [ :item | item third ];		
+		column: 'Node' evaluated: [ :item | item second ];
+		column: 'ID' evaluated: [ :item | printer printId: item first ];
+		column: 'Location' evaluated: [ :item |
+			| node |
+
+			node := item first.
+			node location notNil ifTrue:[
+				node	location gtDisplayString 
+			] ifFalse:[
+				''
+			]];
+		yourself.
+
+]
diff --git a/src/Tinyrossa/TRCFG.class.st b/src/Tinyrossa/TRCFG.class.st
@@ -4,7 +4,8 @@ Class {
 	#instVars : [
 		'compilation',
 		'blocks',
-		'entry'
+		'entry',
+		'nextBlockId'
 	],
 	#pools : [
 		'TRILOpcodes'
@@ -34,8 +35,9 @@ TRCFG >> addBlockNamed: aStringOrNil [
 	aStringOrNil notNil ifTrue: [ 
 		name := aStringOrNil.
 	] ifFalse: [ 
-		name := 'BB_' , (blocks size printLeftPaddedWith: $0 to: 3 base: 10)
+		name := 'BB_' , (nextBlockId printLeftPaddedWith: $0 to: 3 base: 10)
 	].
+	nextBlockId := nextBlockId + 1.
 
 	self assert: (blocks contains: [:e | e name = name ]) not.
 
@@ -87,6 +89,7 @@ TRCFG >> initializeWithCompilation: aTRCompilation [
 	compilation := aTRCompilation.
 	blocks := Set new.
 	entry := nil.
+	nextBlockId := 0.
 ]
 
 { #category : #enumerating }

diff --git a/src/Tinyrossa/TRILBlock.class.st b/src/Tinyrossa/TRILBlock.class.st
@@ -278,6 +278,17 @@ TRILBlock >> successor2 [
 	^ successor2
 ]
 
+{ #category : #accessing }
+TRILBlock >> successors [
+	successor2 isNil ifTrue:[
+		successor1 isNil ifTrue:[ ^#() ].
+		^ { successor1 }
+	].
+
+	successor1 isNil ifTrue:[ ^ { successor2 } ].
+	^ { successor1 . successor2 }
+]
+
 { #category : #accessing }
 TRILBlock >> treetops [
 	^ { bbstartNode } , treetops , { bbendNode }

diff --git a/src/Tinyrossa/TRILOpcode.class.st b/src/Tinyrossa/TRILOpcode.class.st
@@ -260,7 +260,7 @@ TRILOpcode >> name [
 TRILOpcode >> printOn:aStream [
 	"append a printed representation of the receiver to the argument, aStream"
 
-	self class name printOn: aStream.
+	aStream nextPutAll: self class name.
 	aStream nextPutAll:' named: '.
 	name storeOn:aStream.
 ]