"{ Package: 'stx:goodies/petitparser/compiler' }"

Object subclass:#PPCNode

	instanceVariableNames:'contextFree name firstFollowCache firstCharSet properties'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Nodes'

!

!PPCNode class methodsFor:'as yet unclassified'!

new

	^ self basicNew initialize

! !

!PPCNode methodsFor:'accessing'!

children

	^ #()

!

name: anObject

	name := anObject

!

prefix

	self subclassResponsibility 

!

suffix

	^ ''

! !

!PPCNode methodsFor:'accessing-properties'!

hasProperty: aKey

	"Test if the property aKey is present."

	^ properties notNil and: [ properties includesKey: aKey ]

!

properties: aDictionary

	properties := aDictionary 

!

propertyAt: aKey ifAbsent: aBlock

	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."

	^ properties isNil

		ifTrue: [ aBlock value ]

		ifFalse: [ properties at: aKey ifAbsent: aBlock ]

! !

!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

!

firstCharSetCached

	firstCharSet ifNil: [ 

 		firstCharSet := self firstCharSet.

	].

	^ firstCharSet

!

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'!

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.

!

hash

	"TODO JK: IMO not a good hashing function bacause of children size, 

		but at least it is not recursive, which would be worse :)

	"

	^ self class hash bitXor: (name hash bitXor: self children size hash)

! !

!PPCNode methodsFor:'compiling'!

compileWith: compiler

	|  |

	^ self compileWith: compiler effect: #none

!

compileWith: compiler effect: effect

	| id method |

	id := (compiler idFor: self prefixed: (self prefix) suffixed: (self suffix) effect: effect).

	(method := compiler checkCache: id) ifNotNil: [ ^ method ].

	^ self compileWith: compiler effect: effect id: id.

!

compileWith: compiler effect: effect id: id

	self subclassResponsibility 

!

initialize

	super initialize.

	firstFollowCache := IdentityDictionary new.

! !

!PPCNode methodsFor:'first follow next'!

firstSet

	^ firstFollowCache at: #firstSet ifAbsentPut: [

		self firstSets at: self

	]

!

firstSet: set

	firstFollowCache at: #firstSet put: set

!

firstSets

	^ self firstSetsSuchThat: [ :e | e isFirstSetTerminal ]

!

firstSets: aFirstDictionary into: aSet suchThat: aBlock

	"PRIVATE: Try to add additional elements to the first-set aSet of the receiver, use the incomplete aFirstDictionary."

	(aBlock value: self) ifFalse: [ 

		self children do: [ :node | aSet addAll: (aFirstDictionary at: node) ]

	]

!

firstSetsSuchThat: block

	| firstSets |

	firstSets := IdentityDictionary new.

	self allParsersDo: [ :each |

		firstSets at: each put: ((block value: each)

			ifTrue: [ IdentitySet with: each ]

			ifFalse: [ IdentitySet new ]).

		each isNullable

			ifTrue: [ (firstSets at: each) add: PPCSentinelNode instance ] ].

	[	| changed tally |

		changed := false.

		firstSets keysAndValuesDo: [ :node :first |

			tally := first size.

			node firstSets: firstSets into: first suchThat: block.

			changed := changed or: [ tally ~= first size ] ].

		changed ] whileTrue.

	^ firstSets

!

followSet

	^ firstFollowCache at: #followSet ifAbsent: [ self error: 'no follow set cached' ]

!

followSet: aSet

	^ firstFollowCache at: #followSet put: aSet

!

followSetIn: rootNode

	^ rootNode followSets at: self

!

followSetWithTokens

	^ firstFollowCache at: #followSetWithTokens ifAbsent: [ self error: 'no follow with tokens cached' ]

!

followSetWithTokens: aSet

	^ firstFollowCache at: #followSetWithTokens put: aSet

!

followSets

	^ self followSetsSuchThat: [ :e | e isFirstSetTerminal ]

!

followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet suchThat: aBlock

	"PRIVATE: Try to add additional elements to the follow-set aSet of the receiver, use the incomplete aFollowDictionary and the complete aFirstDictionary."

	self children do: [ :node | (aFollowDictionary at: node) addAll: aSet ]

!

followSetsSuchThat: aBlock

	"Answer a dictionary with all the parsers reachable from the receiver as key and their follow-set as value. The follow-set of a parser is the list of terminal parsers that can appear immediately to the right of that parser."

	| current previous continue firstSets followSets |

	current := previous := 0.

	firstSets := self firstSetsSuchThat: aBlock.

	followSets := IdentityDictionary new.

	self allNodesDo: [ :each | followSets at: each put: IdentitySet new ].

	(followSets at: self) add: PPCSentinelNode instance.

	[	followSets keysAndValuesDo: [ :node :follow |

			node 

				followSets: followSets

				firstSets: firstSets

				into: follow

				suchThat: aBlock ].

		current := followSets

			inject: 0

			into: [ :result :each | result + each size ].

		continue := previous < current.

		previous := current.

		continue ] whileTrue.

	^ followSets

!

nextSetIn: rootNode

	^ rootNode nextSets at: self

!

nextSets

		| nextSets |

	nextSets := IdentityDictionary new.

	self allNodesDo: [ :each | nextSets at: each put: IdentitySet new ].

	(nextSets at: self) add: PPCSentinelNode instance.

	[ 	| changed |

		changed := false.

		nextSets keysAndValuesDo: [:node :next |

			changed := (node 

				nextSets: nextSets

				into: next) or: [ changed ].

		].

		changed ] whileTrue.

	^ nextSets

!

nextSets: aNextDictionary into: aSet

	"return true/false, if something has changed or not...."

	| childSet change tally |

	change := false.

	self children do: [:each | 

		childSet := aNextDictionary at: each.

		tally := childSet size.

		childSet addAll: aSet.

		change := change or: [ tally ~= childSet size ].

	].

	^ change

! !

!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

!

inline: changeStatus

	"nothing to do"

!

inline: params status: changeStatus

	(params at: #inline) ifTrue: [ 

		^ self inline: changeStatus

	]

!

optimize: params status: changeStatus

	| retval |

	retval := self.

	retval := retval rewrite: params status: changeStatus.

	retval := retval inline: params status: changeStatus.

	^ retval

!

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 ]

! !

!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

! !