--- a/compiler/PPCCompiler.st Tue Aug 18 22:46:10 2015 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,691 +0,0 @@
-"{ 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-Compiler'
-!
-
-
-!PPCCompiler class methodsFor:'instance creation'!
-
-new
- "return an initialized instance"
-
- ^ self on: PPCArguments default
-!
-
-on: aPPCArguments
- "return an initialized instance"
-
- ^ self basicNew
- arguments: aPPCArguments;
- initializeForCompiledClassName: aPPCArguments parserName
-! !
-
-!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 includesKey: name) ifTrue:[
- (constants at: name) ~= value ifTrue:[
- self error:'Duplicate constant!!'.
- ].
- ^ self.
- ].
- constants at: name put: value
-
- "Modified: / 29-05-2015 / 07:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-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.
-!
-
-codeComment: string
- currentMethod add: '"', string, '"'.
-!
-
-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'!
-
-code:aStringOrBlockOrRBParseNode
- currentMethod code: aStringOrBlockOrRBParseNode
-
- "Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-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.
- ]
-!
-
-codeAssignParsedValueOf:aBlock to:aString
- | tmpVarirable method |
-
- self assert:aBlock isBlock.
- self assert:aString isNil not.
- tmpVarirable := returnVariable.
- returnVariable := aString.
- method := [
- aBlock value
- ] ensure:[ returnVariable := tmpVarirable ].
- self assert: (method isKindOf: PPCMethod).
- method isInline ifTrue:[
- self callOnLine:method
- ] ifFalse:[
- self codeEvaluateAndAssign:(method call) to:aString.
- ]
-
- "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeBlock: contents
- currentMethod codeBlock: contents
-
- "Created: / 01-06-2015 / 22:35:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeClearError
- self add: 'self clearError.'.
-!
-
-codeDot
- self addOnLine:'.'.
-
- "Created: / 16-06-2015 / 06:09:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeError
- self add: 'self error: ''message notspecified''.'.
-!
-
-codeError: errorMessage
- self add: 'self error: ''', errorMessage, '''.'
-!
-
-codeError: errorMessage at: position
- self add: 'self error: ''', errorMessage, ''' at: ', position asString, '.'
-!
-
-codeEvaluate: selector argument: argument on: 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, ' ', selector,' ', argument.
- ] ifTrue: [
- "In case argument has a side effect"
- self add: argument
- ]
-!
-
-codeEvaluateAndAssign: argument 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 ,' := ', argument.
- ] ifTrue: [
- "In case an argument has a side effect"
- self add: argument.
- ]
-!
-
-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>"
-!
-
-codeIf: condition then: then
- self codeIf: condition then: then else: nil
-
- "Created: / 16-06-2015 / 06:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeIf: condition then: then else: else
- currentMethod
- add: '(';
- code: condition;
- addOnLine: ')'.
- then notNil ifTrue:[
- currentMethod
- addOnLine:' ifTrue:';
- codeBlock: then.
- ].
- else notNil ifTrue:[
- currentMethod
- addOnLine:' ifFalse:';
- codeBlock: else.
- ].
- self codeDot.
-
- "Created: / 01-06-2015 / 22:43:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 16-06-2015 / 06:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeIfErrorThen: then
- ^ self codeIf: 'error' then: then else: nil
-
- "Created: / 16-06-2015 / 06:06:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeIfErrorThen: then else: else
- ^ self codeIf: 'error' then: then else: else
-
- "Created: / 16-06-2015 / 06:05:56 / 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>"
-!
-
-codeProfileStart
- self add: 'context methodInvoked: #', currentMethod methodName, '.'
-
- "Created: / 01-06-2015 / 21:17:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeProfileStop
- self add: 'context methodFinished: #', currentMethod methodName, '.'
-
- "Created: / 01-06-2015 / 21:19:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeReturn
- currentMethod isInline ifTrue: [
- "If inlined, the return variable already holds the value"
- ] ifFalse: [
- arguments profile ifTrue:[
- self codeProfileStop.
- ].
- self add: '^ ', currentMethod returnVariable
- ].
-
- "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 01-06-2015 / 21:49:04 / 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 codeEvaluateAndAssign: code to: currentMethod returnVariable.
- ] ifFalse: [
- arguments profile ifTrue:[
- self codeProfileStop.
- ].
- self add: '^ ', code
- ]
-
- "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 01-06-2015 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeReturnParsedValueOf:aBlock
- | tmpVarirable method |
-
- self assert:aBlock isBlock.
- tmpVarirable := returnVariable.
- method := aBlock value.
- self assert: returnVariable == tmpVarirable.
- self assert: (method isKindOf: PPCMethod).
- method isInline ifTrue:[
- self callOnLine:method.
- self codeReturn: returnVariable.
- ] ifFalse:[
- self codeReturn: method call.
-
- ]
-
- "Created: / 23-04-2015 / 18:21:51 / 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 codeEvaluateAndAssign: (method call) to: aString.
- ]
-
- "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-codeTokenGuard: node ifFalse: codeBlock
- | guard id |
- guard := PPCTokenGuard on: node.
- (guard makesSense) ifTrue: [
- id := self idFor: guard firstToken.
-
- self add: 'self ', id asString, ' ifFalse: ['.
- self indent.
- codeBlock value.
- self dedent.
- self add: '].'.
- ]
-!
-
-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 asString).
- 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 - profiling'!
-
-profileTokenRead: tokenName
- arguments profile ifTrue: [
- self add: 'context tokenRead: ', tokenName storeString, '.'
- ]
-! !
-
-!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 returnVariable: returnVariable.
- currentMethod indentationLevel: indentationLevel.
- self push.
-
- "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-startMethod: id
- (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
-
- currentMethod := PPCMethod new.
- currentMethod id: id.
- arguments profile ifTrue:[
- self codeProfileStart.
- ].
- self push.
-
- self cache: id as: currentMethod.
-
- "Modified: / 01-06-2015 / 21:19:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-stopInline
- ^ self pop.
-
- "Modified: / 01-06-2015 / 21:37:59 / 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-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-top
- ^ compilerStack top
-! !
-
-!PPCCompiler methodsFor:'code generation - variables'!
-
-allocateReturnVariable
- ^ self allocateReturnVariableNamed: 'retval'
-
- "Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-allocateReturnVariableNamed: name
- "Allocate (or return previously allocated one) temporary variable used for
- storing a parser's return value (the parsed object)"
- ^ currentMethod allocateReturnVariableNamed: name
-
- "Created: / 15-06-2015 / 18:04:48 / 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 source classified: method category.
- ]
-
- "Modified: / 24-07-2015 / 19:45:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-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 := Dictionary 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.
-
- "Modified: / 26-05-2015 / 17:09:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-! !
-
-!PPCCompiler class methodsFor:'documentation'!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
-! !
-