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

Object subclass:#PPCNode

	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:'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.

! !

!PPCNode methodsFor:'compiling'!

compileWith: compiler

	|  |

	^ self compileWith: compiler effect: #none

!

compileWith: compiler effect: effect

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

	^ 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.

                                        changeStatus change]

                ]].

                changed 

        ] whileTrue.

        ^ root

    "Modified: / 26-10-2014 / 01:14:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

inline: changeStatus

	"nothing to do"

!

inline: params status: changeStatus

	(params at: #inline) ifTrue: [ 

		^ self inline: changeStatus

	]

!

optimize: params status: changeStatus

!

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.