--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCNode.st	Sun Oct 26 01:03:31 2014 +0000
@@ -0,0 +1,326 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+Object subclass:#PPCNode
+	instanceVariableNames:'contextFree name'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'PetitCompiler-Nodes'
+!
+
+PPCNode comment:''
+!
+
+!PPCNode methodsFor:'accessing'!
+
+children
+	^ #()
+!
+
+name: anObject
+	
+	name := anObject
+!
+
+prefix
+	self subclassResponsibility 
+!
+
+suffix
+	^ ''
+! !
+
+!PPCNode methodsFor:'analysis'!
+
+acceptsEpsilon
+	"return true, if parser can accept epsilon without failure"
+	^ self subclassResponsibility
+!
+
+acceptsEpsilonOpenSet: set
+	"private helper for acceptsEmpsilon that makes sure to avoid cycles (using open set)"
+	self children isEmpty ifTrue: [ ^ self acceptsEpsilon ].
+	
+	self shouldBeImplemented .
+!
+
+allNodes
+	| result |
+	result := OrderedCollection new.
+	self allParsersDo: [ :parser | result add: parser ].
+	^ result
+!
+
+allNodesDo: aBlock
+	"Iterate over all the parse nodes of the receiver."
+
+	self allNodesDo: aBlock seen: IdentitySet new
+!
+
+allNodesDo: aBlock seen: aSet
+	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."
+
+	(aSet includes: self)
+		ifTrue: [ ^ self ].
+	aSet add: self.
+	aBlock value: self.
+	self children
+		do: [ :each | each allNodesDo: aBlock seen: aSet ]
+!
+
+check
+	"nothing to do"
+	^ nil
+!
+
+firstSetSuchThat: block
+	^ self firstSetSuchThat: block into: (OrderedCollection new) openSet: IdentitySet new.
+!
+
+firstSetSuchThat: block into: aCollection openSet: aSet
+	(aSet includes: self) ifTrue: [ ^ aCollection ].
+	aSet add: self.
+	
+	(block value: self) ifTrue: [aCollection add: self. ^ aCollection ].
+	self children do: [ :child | 
+		child firstSetSuchThat: block into: aCollection openSet: aSet 
+	].
+	^ aCollection
+!
+
+isContextFree
+	^ contextFree ifNil: [ contextFree := self allNodes allSatisfy: [ :n | n isContextFreePrim  ] ]
+!
+
+isContextFreePrim
+	^ true
+!
+
+isFirstSetTerminal
+	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."
+
+	^ self isTerminal
+!
+
+isNullable
+	"Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."
+	
+	^ false
+!
+
+isTerminal
+	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."
+
+	^ self children isEmpty
+! !
+
+!PPCNode methodsFor:'as yet unclassified'!
+
+firstSet
+	^ self firstSetSuchThat: [ :e | e isFirstSetTerminal ]
+!
+
+name
+	^ name
+! !
+
+!PPCNode methodsFor:'comparison'!
+
+= anotherNode
+	(self == anotherNode) ifTrue: [ ^ true ].
+	(anotherNode class = self class) ifFalse: [ ^ false ].
+	
+	(anotherNode name = name) ifFalse: [ ^ false ].
+	^ anotherNode children = self children.
+! !
+
+!PPCNode methodsFor:'compiling'!
+
+compileWith: compiler
+	|  |
+	^ self compileWith: compiler effect: #none
+!
+
+compileWith: compiler effect: effect
+	| id |
+	id := (compiler idFor: self prefixed: (self prefix) suffixed: (self suffix) effect: effect).
+	(compiler checkCache: id) ifNotNil: [ ^ compiler ].
+
+	^ self compileWith: compiler effect: effect id: id.
+!
+
+compileWith: compiler effect: effect id: id
+	self subclassResponsibility 
+! !
+
+!PPCNode methodsFor:'gt'!
+
+gtTreeViewIn: composite
+	<gtInspectorPresentationOrder: 40>
+
+	composite tree
+			title: 'Tree';
+			children: [:n | n children ];
+			format: [:n| n name ifNil: [ n asString ] ifNotNil: [n name] ];
+			shouldExpandToLevel: 6
+! !
+
+!PPCNode methodsFor:'optimizing'!
+
+asFast
+	^ self
+!
+
+asInlined
+	^ self
+!
+
+checkTree
+	| message |
+	self allNodes do: [ :node | (message := node check) ifNotNil: [ self error: message ]  ].
+!
+
+defaultOptimizationParameters
+	| parameters |
+	parameters := IdentityDictionary new.
+	parameters at: #inline put: true.
+	parameters at: #rewrite put: true.
+
+	^ parameters
+!
+
+doOptimizationLoop: params status: changeStatus
+	| mapping optimized root |
+	mapping := IdentityDictionary new.
+	self allNodes do: [ :node |
+		optimized := (node optimize: params status: changeStatus).
+		(optimized ~= node) ifTrue: [  
+			mapping at: node put: optimized.
+		].
+	].
+	
+	root := mapping at: self ifAbsent: [ self ].
+	[  | changed |
+		changed := false.
+		root allNodes do: [ :node |
+			node children do: [ :child | 
+				mapping at: child ifPresent: [:newChild | 
+					node replace: child with: newChild.
+					changed := true ]
+		]].
+		changed 
+	] whileTrue.
+	^ root
+!
+
+inline: changeStatus
+	"nothing to do"
+!
+
+inline: params status: changeStatus
+	(params at: #inline) ifTrue: [ 
+		^ self inline: changeStatus
+	]
+!
+
+optimize: params status: changeStatus
+	" nothing to do "
+!
+
+optimizeTree
+	^ self optimizeTree: #()
+!
+
+optimizeTree: params
+	|  node newNode parameters status |
+	
+	parameters := self defaultOptimizationParameters.
+	
+	params do: [ :p | parameters at: p key put: p value ].
+	
+	node := self.
+	[ 
+		status := PPCOptimizationResult new.
+		newNode := node doOptimizationLoop: parameters status: status.
+		status isChange.
+	] whileTrue: [ node := newNode ].
+	^ node
+!
+
+rewrite: changeStatus
+	"nothing to do"
+!
+
+rewrite: params status: changeStatus
+	(params at: #rewrite) ifTrue: [  
+		^ self rewrite: changeStatus.
+	].
+! !
+
+!PPCNode methodsFor:'printing'!
+
+printNameOn: aStream
+	self name isNil
+		ifTrue: [ aStream print: self hash ]
+		ifFalse: [ aStream nextPutAll: self name. aStream nextPut: $-. aStream print: self hash. ]
+!
+
+printOn: aStream
+	super printOn: aStream.
+	aStream nextPut: $(.
+	self printNameOn: aStream.
+	aStream nextPut: $)
+! !
+
+!PPCNode methodsFor:'todel'!
+
+allParsersDo: aBlock
+	"Iterate over all the parse nodes of the receiver."
+
+	self allParsersDo: aBlock seen: IdentitySet new
+!
+
+allParsersDo: aBlock seen: aSet
+	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."
+
+	(aSet includes: self)
+		ifTrue: [ ^ self ].
+	aSet add: self.
+	aBlock value: self.
+	self children
+		do: [ :each | each allParsersDo: aBlock seen: aSet ]
+!
+
+firstSets: aFirstDictionary into: aSet
+	self children do: [ :child | aSet addAll: (aFirstDictionary at: child) ]
+! !
+
+!PPCNode methodsFor:'transformation'!
+
+asCompilerNode
+	^ self
+!
+
+replace: node with: anotherNode
+!
+
+transform: aBlock
+	"Answer a copy of all parsers reachable from the receiver transformed using aBlock."
+
+	| mapping root |
+	mapping := IdentityDictionary new.
+	self allParsersDo: [ :each |
+		mapping
+			at: each
+			put: (aBlock value: each copy) ].
+	root := mapping at: self.
+	[	| changed |
+		changed := false.
+		root allParsersDo: [ :each |
+			each children do: [ :old |
+				mapping at: old ifPresent: [ :new |
+					each replace: old with: new.
+					changed := true ] ] ].
+		changed ] whileTrue.
+	^ root
+! !
+