"{ Package: 'stx:goodies/petitparser/compiler' }"
"{ NameSpace: Smalltalk }"
Object subclass:#PPCCompiler
instanceVariableNames:'compilerStack compiledParser cache currentMethod ids constants
compiledParserName compiledParserSuperclass returnVariable
arguments'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Core'
!
!PPCCompiler class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initializeForCompiledClassName: 'PPGeneratedParser'
!
newForCompiledClassName: aString
"return an initialized instance"
self halt: 'deprecated'.
^ self basicNew initializeForCompiledClassName: aString
!
on: aPPCArguments
"return an initialized instance"
^ self basicNew
arguments: aPPCArguments;
initializeForCompiledClassName: aPPCArguments name
! !
!PPCCompiler methodsFor:'accessing'!
arguments: args
arguments := args
!
compiledParser
^ compiledParser
!
compiledParserSuperclass
^ compiledParserSuperclass ifNil: [ PPCompiledParser ]
!
currentMethod
^ currentMethod
!
currentNonInlineMethod
^ compilerStack
detect:[:m | m isInline not ]
ifNone:[ self error: 'No non-inlined method']
"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
currentReturnVariable
^ currentMethod returnVariable
!
ids
^ ids
! !
!PPCCompiler methodsFor:'cleaning'!
clean: class
" Transcript show: ('Cleaning time: ',
[
" self cleanGeneratedMethods: class.
self cleanInstVars: class.
self cleanConstants: class.
" ] timeToRun asMilliSeconds asString, 'ms'); cr. "
!
cleanConstants: class
class constants removeAll.
!
cleanGeneratedMethods: class
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
class methodsDo: [ :mthd |
(mthd category beginsWith: 'generated') ifTrue:[
class removeSelector: mthd selector.
]
]
] ifFalse: [
(class allProtocolsUpTo: class) do: [ :protocol |
(protocol beginsWith: 'generated') ifTrue: [
class removeProtocol: protocol.
]
]
]
!
cleanInstVars: class
class class instanceVariableNames: ''.
!
cleanParsers: class
class parsers removeAll.
! !
!PPCCompiler methodsFor:'code generation'!
add: string
currentMethod add: string.
!
addComment: string
currentMethod add: '"', string, '"'.
!
addConstant: value as: name
constants at: name put: value
!
addOnLine: string
currentMethod addOnLine: string.
!
addVariable: name
^ self currentNonInlineMethod addVariable: name
"Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
call: anotherMethod
currentMethod add: anotherMethod call.
!
callOnLine: anotherMethod
currentMethod addOnLine: anotherMethod call.
!
dedent
currentMethod dedent
!
indent
currentMethod indent
!
nl
currentMethod nl
!
smartRemember: parser to: variableName
parser isContextFree ifTrue: [
self codeAssign: 'context lwRemember.'
to: variableName.
] ifFalse: [
self codeAssign: 'context remember.'
to: variableName.
]
!
smartRestore: parser from: mementoName
parser isContextFree ifTrue: [
self add: 'context lwRestore: ', mementoName, '.'.
] ifFalse: [
self add: 'context restore: ', mementoName, '.'.
]
! !
!PPCCompiler methodsFor:'code generation - coding'!
codeAssign: code to: variable
self assert: variable isNil not.
"TODO JK: Hack alert, whatever is magic constant!!"
(variable == #whatever) ifFalse: [
"Do not assign, if somebody does not care!!"
self add: variable ,' := ', code.
] ifTrue: [
"In case code hava a side effect"
self add: code
]
!
codeClearError
self add: 'self clearError.'.
!
codeError: errorMessage
self add: 'self error: ''', errorMessage, '''.'
!
codeHalt
self add: 'self halt. '
!
codeHaltIfShiftPressed
arguments debug ifTrue: [
((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifFalse:[
self add: 'Halt ifShiftPressed.'
]
]
"Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeNextToken
self add: 'self nextToken.'
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturn
currentMethod isInline ifTrue: [
"If inlined, the return variable already holds the value"
] ifFalse: [
self add: '^ ', currentMethod returnVariable
].
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturn: code
" - returns whatever is in code OR
- assigns whatever is in code into the returnVariable"
currentMethod isInline ifTrue:[
self codeAssign: code to: currentMethod returnVariable.
] ifFalse: [
self add: '^ ', code
]
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeStoreValueOf: aBlock intoVariable: aString
| tmpVarirable method |
self assert: aBlock isBlock.
self assert: aString isNil not.
tmpVarirable := returnVariable.
returnVariable := aString.
method := [
aBlock value
] ensure: [
returnVariable := tmpVarirable
].
method isInline ifTrue: [
self callOnLine: method
] ifFalse: [
self codeAssign: (method call) to: aString.
]
"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeTranscriptShow: text
(arguments profile) ifTrue: [
self add: 'Transcript show: ', text storeString, '; cr.'.
]
! !
!PPCCompiler methodsFor:'code generation - ids'!
asSelector: string
"e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432"
| toUse |
toUse := string select: [:char | char isAlphaNumeric or: [ char = $_ ] ].
(toUse isEmpty or: [ toUse first isLetter not ])
ifTrue: [ toUse := 'v', toUse ].
toUse first isUppercase ifFalse:[
toUse := toUse copy.
toUse at: 1 put: toUse first asLowercase
].
^toUse
"Modified: / 10-05-2015 / 07:29:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
idFor: object
self assert: (object isKindOf: PPCNode).
^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none
!
idFor: object prefixed: prefix
^ self idFor: object prefixed: prefix effect: #none
!
idFor: object prefixed: prefix effect: effect
^ self idFor: object prefixed: prefix suffixed: '' effect: effect.
!
idFor: object prefixed: prefix suffixed: suffix effect: effect
| name id |
^ ids at: object ifAbsentPut: [
((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [
"Do not use prefix, if there is a name"
name := self asSelector: object name.
id := (name, suffix) asSymbol.
"Make sure, that the generated ID is uniqe!!"
(ids includes: id) ifTrue: [
(id, '_', ids size asString) asSymbol
] ifFalse: [
id
]
] ifFalse: [
(prefix, '_', (ids size asString), suffix) asSymbol
]
]
!
idFor: object suffixed: suffix
self assert: (object isKindOf: PPCNode) description: 'Shold use PPCNode for ids'.
^ self idFor: object prefixed: object prefix suffixed: suffix effect: #none
! !
!PPCCompiler methodsFor:'code generation - support'!
cache: id as: value
cache at: id put: value.
!
cachedValue: id
^ cache at: id ifAbsent: [ nil ]
!
checkCache: id
| method |
"Check if method is hand written"
method := compiledParser ifNotNil: [ compiledParser compiledMethodAt: id ifAbsent: [ nil ] ].
method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].
^ self cachedValue: id
!
pop
| retval |
retval := compilerStack pop.
currentMethod := compilerStack isEmpty
ifTrue: [ nil ]
ifFalse: [ compilerStack top ].
^ retval
"Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
push
compilerStack push: currentMethod.
(compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
"Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startInline: id
| indentationLevel |
(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
indentationLevel := currentMethod indentationLevel.
currentMethod := PPCInlinedMethod new.
currentMethod id: id.
currentMethod profile: arguments profile.
currentMethod returnVariable: returnVariable.
currentMethod indentationLevel: indentationLevel.
self push.
"Modified: / 23-04-2015 / 18:28:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startMethod: id
(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
currentMethod := PPCMethod new.
currentMethod id: id.
currentMethod profile: arguments profile.
self push.
self cache: id as: currentMethod.
"Modified: / 23-04-2015 / 18:36:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopInline
^ self pop.
"Modified: / 23-04-2015 / 18:28:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopMethod
self cache: currentMethod methodName as: currentMethod.
arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ].
^ self pop.
"Modified: / 01-05-2015 / 14:18:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
top
^ compilerStack top
! !
!PPCCompiler methodsFor:'code generation - variables'!
allocateReturnVariable
"Return a new variable to store parsed value"
^ currentMethod allocateReturnVariable
"Created: / 23-04-2015 / 17:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 23-04-2015 / 21:12:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
allocateTemporaryVariableNamed: preferredName
"Allocate a new variable with (preferably) given name.
Returns a real variable name that should be used."
^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName
"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCompiler methodsFor:'compiling'!
compileParser
self installVariables.
self installMethods.
self installClassConstants.
^ compiledParser
!
copy: parser
^ parser transform: [ :p | p copy ].
!
installClassConstants
constants keysAndValuesDo: [ :key :value |
compiledParser constants at: key put: value
]
!
installMethods
cache keysAndValuesDo: [ :key :method |
compiledParser compileSilently: method code classified: method category.
]
!
installVariables
| varString |
varString := constants keys inject: '' into: [:r :e | r, ' ', e ].
(self compiledParserSuperclass)
subclass: compiledParserName
instanceVariableNames: varString
classVariableNames: ''
poolDictionaries: ''
category: 'PetitCompiler-Generated'.
compiledParser := Smalltalk at: compiledParserName.
! !
!PPCCompiler methodsFor:'initialization'!
initializeForCompiledClassName: aString
self initialize.
compilerStack := Stack new.
cache := IdentityDictionary new.
constants := IdentityDictionary new.
ids := IdentityDictionary new.
compiledParserName := aString asSymbol.
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
| rPackageOrganizer |
rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
rPackageOrganizer notNil ifTrue:[
rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
].
] ifFalse: [
RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
].
Smalltalk at: compiledParserName ifPresent: [ :class |
compiledParser := class.
self clean: compiledParser.
].
Transcript cr; show: 'intialized for: ', aString; cr.
! !
!PPCCompiler class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !