Merged JK's work on PetitCompiler
Name: PetitCompiler-JanKurs.57
Author: JanKurs
Time: 05-11-2014, 05:10:47 AM
UUID: 4c625efe-77fd-465d-bd63-72ead0b5d3ba
Name: PetitCompiler-Tests-JanVrany.13
Author: JanVrany
Time: 05-11-2014, 09:31:07 AM
UUID: 189ae287-6bc1-40ba-8458-b8392c4260a0
"{ Package: 'stx:goodies/petitparser/compiler' }"
Object subclass:#PPCNode
instanceVariableNames:'contextFree name firstSet firstCharSet'
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'!
firstSet
firstSet ifNil: [
firstSet := self firstSetSuchThat: [ :e | e isFirstSetTerminal ].
].
^ firstSet
!
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.
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
" 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
! !