Portability - test if RPackageOrganizer is present...
...if not, do not register new package using it. RPackage is Pharo specific
thing not present in other Smalltalks.
"{ Package: 'stx:goodies/petitparser/compiler' }"
Object subclass:#PPCCompiler
instanceVariableNames:'compilerStack compiledParser cache inlining debug profile
currentMethod lastMethod guards ids updateContextMethod tokenMode'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Core'
!
!PPCCompiler class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initialize.
! !
!PPCCompiler methodsFor:'accessing'!
fastMode
^ tokenMode
!
inlining
^ inlining
!
inlining: value
inlining := value
!
lastMethod
^ lastMethod
!
parameters: associations
| key value |
associations do: [ :ass |
key := ass key.
value := ass value.
(key = #profile) ifTrue: [ profile := value ].
(key = #inline) ifTrue: [ inlining := value ].
(key = #guards) ifTrue: [ guards := value ].
]
!
profile
^ profile
!
profile: aBoolean
profile := aBoolean
!
startInline: id
self push.
currentMethod := PPCInlinedMethod new.
currentMethod id: id.
currentMethod profile: self profile.
! !
!PPCCompiler methodsFor:'cleaning'!
clean: class
" Transcript crShow: 'Cleaning time: ',
[
" self cleanGeneratedMethods: class.
self cleanInstVars: class.
self cleanParsers: class.
self cleanConstants: class.
" ] timeToRun asMilliSeconds asString, 'ms'."
!
cleanConstants: class
class constants removeAll.
!
cleanGeneratedMethods: class
(class allSelectorsInProtocol: #generated) do: [ :selector |
class removeSelectorSilently: selector ].
!
cleanInstVars: class
class class instanceVariableNames: ''.
!
cleanParsers: class
class parsers removeAll.
! !
!PPCCompiler methodsFor:'code generation'!
add: string
currentMethod add: string.
!
addConstant: value as: name
compiledParser addConstant: value as: name.
!
addOnLine: string
currentMethod addOnLine: string.
!
addVariable: name
currentMethod addVariable: name.
!
allowInline
currentMethod allowInline
!
cache: id as: value
cache at: id put: value.
!
cachedValue: id
^ cache at: id ifAbsent: [ nil ]
!
call: anotherMethod
currentMethod add: anotherMethod call.
!
callOnLine: anotherMethod
currentMethod addOnLine: anotherMethod call.
!
checkCache: id
| method value |
"Check if method is already compiled/hand written"
method := compiledParser compiledMethodAt: id ifAbsent: [ nil ].
method ifNotNil: [ ^ lastMethod := PPCCompiledMethod new id: id; yourself ].
^ (value := self cachedValue: id) ifNotNil: [ lastMethod := value ].
!
dedent
currentMethod dedent
!
indent
currentMethod indent
!
nl
currentMethod nl
!
pop
| array |
array := compilerStack pop.
currentMethod := array first
!
push
| array |
array := { currentMethod }.
compilerStack push: array.
(compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
!
smartRemember: parser
^ self smartRemember: parser to: #memento
!
smartRemember: parser to: variableName
parser isContextFree ifTrue: [
^ variableName, ' := context lwRemember.'.
].
^ variableName, ':= context remember.'
!
smartRestore: parser
^ self smartRestore: parser from: #memento
!
smartRestore: parser from: mementoName
parser isContextFree ifTrue: [
^ 'context lwRestore: ', mementoName, '.'.
].
^ 'context restore: ', mementoName, '.'.
!
startMethod: id
| sender |
(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
self push.
currentMethod := PPCMethod new.
currentMethod id: id.
currentMethod profile: self profile.
self cache: id as: currentMethod.
sender := thisContext sender receiver.
self add: '"Method generated from ', sender asString, '"'.
!
startTokenMode
tokenMode := true
!
stopInline
| sender |
sender := thisContext sender receiver.
self add: '"Inlined by ', sender asString, '"'.
lastMethod := currentMethod.
currentMethod := nil.
self pop.
!
stopMethod
self cache: currentMethod methodName as: currentMethod.
lastMethod := currentMethod.
currentMethod := nil.
self pop.
!
stopTokenMode
tokenMode := false
! !
!PPCCompiler methodsFor:'code generation - ids'!
idFor: object prefixed: prefix
^ self idFor: object prefixed: prefix effect: #none
!
idFor: object prefixed: prefix effect: effect
| body suffix |
^ ids at: object ifAbsentPut: [
suffix := self fastMode ifTrue: [ '_fast' ] ifFalse: [ '' ].
((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [
(object name, suffix) asSymbol
] ifFalse: [
body := ids size asString.
(prefix asString, '_', body, suffix) asSymbol
]
]
!
idFor: object prefixed: prefix suffixed: suffix effect: effect
| body |
^ ids at: object ifAbsentPut: [
((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [
(object name, suffix) asSymbol
] ifFalse: [
body := ids size asString.
(prefix asString, '_', body, suffix) asSymbol
]
]
! !
!PPCCompiler methodsFor:'compiling'!
compile: aPPParser as: name
^ self compile: aPPParser as: name params: #()
!
compile: aPPParser as: name params: params
| parser |
parser := self copy: aPPParser.
parser := self toCompilerTree: parser.
parser := self optimize: parser params: params.
parser := self compileTree: parser as: name parser: aPPParser params: params.
^ parser
!
compileTree: compilerTree as: name parser: parser params: params
| rPackageOrganizer |
params do: [ :p |
(p key = #guards) ifTrue: [ self guards: p value ].
].
"
To create a new Package so that a new classes are not in PetitCompiler package.
TODO JK: This is HACK, needs some more interoperable approach
"
rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
rPackageOrganizer notNil ifTrue:[
rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
].
compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
compiledParser ifNil: [
PPCompiledParser subclass: name
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Generated'.
compiledParser := Smalltalk at: name.
] ifNotNil: [
self clean: compiledParser
].
compiledParser constants removeAll.
self startMethod: #start.
self add: '^ '.
self callOnLine: (compilerTree compileWith: self).
self stopMethod.
self installMethodsAndVariables: compiledParser.
compiledParser referringParser: parser.
^ compiledParser
"Modified: / 26-10-2014 / 22:04:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
copy: parser
^ parser transform: [ :p | p copy ].
!
installMethods: class
cache keysAndValuesDo: [ :key :method |
class compileSilently: method code classified: 'generated'.
]
!
installMethodsAndVariables: class
self installVariables: class.
self installMethods: class.
!
installVariables: class
| string |
string := class constants keys inject: '' into: [:r :e | r, ' ', e ].
PPCompiledParser subclass: class name instanceVariableNames: string classVariableNames: '' poolDictionaries:'' category: 'PetitCompiler-Generated'.
"Modified: / 26-10-2014 / 22:01:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
optimize: parser params: params
| retval |
retval := parser optimizeTree: params.
retval checkTree.
^ retval
!
toCompilerTree: parser
^ parser asCompilerTree
! !
!PPCCompiler methodsFor:'guard'!
addSequenceGuard: parser
| firsts guardSet guardSetId |
(self guards not or: [(guardSet := self guardCharSet: parser) isNil]) ifTrue: [ ^ self].
firsts := (parser firstSetSuchThat: [ :e | (e isKindOf: PPTokenParser) or: [ e isTerminal ] ]).
"If we start with PPTokenParser, we should invoke the whitespace parser"
(firsts allSatisfy: [ :e | e isKindOf: PPTokenParser ]) ifTrue: [
guardSetId := (self idFor: guardSet prefixed: #guard).
self addConstant: guardSet as: guardSetId.
self add: 'wsParser parseOn: context.'.
self add: 'context atEnd ifTrue: [ ^ self error ].'.
self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
].
(firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [
guardSetId := (self idFor: guardSet prefixed: #guard).
self addConstant: guardSet as: guardSetId.
self add: 'context atEnd ifTrue: [ ^ self error ].'.
self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
].
!
guardCharSet: parser
| fs charSet |
"No Guards fro trimming parser so far"
(parser firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty ifFalse: [ ^ nil ].
"Makes no sense to do guard for epsilon parse"
(parser acceptsEpsilon) ifTrue: [ ^ nil ].
fs := parser firstSet.
fs do: [ :p |
"If we can accept epsilon guard does not make sense"
p isNullable ifTrue: [ ^ nil ].
].
charSet := PPCharSetPredicate on: [:char | fs anySatisfy: [:e | (e firstCharParser parse: char asString) isPetitFailure not ]].
^ charSet
!
guards
^ guards
!
guards: aBoolean
guards := aBoolean
! !
!PPCCompiler methodsFor:'initialization'!
initialize
super initialize.
compilerStack := Stack new.
cache := IdentityDictionary new.
ids := IdentityDictionary new.
tokenMode := false.
inlining := true.
profile := false.
guards := true.
! !
!PPCCompiler methodsFor:'ppcmethod protocol'!
bridge
^ PPCBridge on: lastMethod methodName.
!
call
^ lastMethod call
!
canInline
^ lastMethod canInline
! !
!PPCCompiler class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !