Merged JK's version from Monticello
Name: PetitParser-JanKurs.260
Author: JanKurs
Time: 17-11-2014, 12:09:05.490 PM
UUID: 07411cef-ef69-40db-9d93-d4018a9b34ef
Name: PetitTests-JanKurs.65
Author: JanKurs
Time: 17-11-2014, 12:09:04.530 PM
UUID: f98d613f-f4ce-4e0e-a7e9-310ee7c7e7a6
Name: PetitSmalltalk-JanKurs.78
Author: JanKurs
Time: 14-11-2014, 05:05:07.765 PM
UUID: 3d68330d-44d5-46c3-9705-97f627b3edbc
Name: PetitCompiler-JanKurs.71
Author: JanKurs
Time: 18-11-2014, 09:48:35.425 AM
UUID: 06352c33-3c76-4382-8536-0cc48e225117
Name: PetitCompiler-Tests-JanKurs.21
Author: JanKurs
Time: 17-11-2014, 05:51:53.134 PM
UUID: 8d6c0799-14e7-4871-8d91-8b0f9886db83
Name: PetitCompiler-Benchmarks-JanKurs.2
Author: JanKurs
Time: 17-11-2014, 05:51:07.887 PM
UUID: d5e3a980-7871-487a-a232-e3ca93fc2483
"{ 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
| 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
| 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 ]
!
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
! !