--- a/compiler/PPCCompiler.st Tue May 05 16:25:23 2015 +0200
+++ b/compiler/PPCCompiler.st Sun May 10 06:46:56 2015 +0100
@@ -3,8 +3,9 @@
"{ NameSpace: Smalltalk }"
Object subclass:#PPCCompiler
- instanceVariableNames:'compilerStack compiledParser cache currentMethod ids rootNode
- constants compiledParserName returnVariable arguments'
+ instanceVariableNames:'compilerStack compiledParser cache currentMethod ids constants
+ compiledParserName compiledParserSuperclass returnVariable
+ arguments'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Core'
@@ -36,85 +37,85 @@
!PPCCompiler methodsFor:'accessing'!
arguments: args
- arguments := args
+ arguments := args
!
compiledParser
- ^ compiledParser
+ ^ compiledParser
+!
+
+compiledParserSuperclass
+ ^ compiledParserSuperclass ifNil: [ PPCompiledParser ]
!
currentNonInlineMethod
- ^ compilerStack
- detect:[:m | m isInline not ]
- ifNone:[ self error: 'No non-inlined method']
+ ^ 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
+ ^ currentMethod returnVariable
!
ids
- ^ ids
-!
-
-rootNode
- ^ rootNode
+ ^ ids
! !
!PPCCompiler methodsFor:'cleaning'!
clean: class
" Transcript crShow: 'Cleaning time: ',
- [
+ [
" self cleanGeneratedMethods: class.
- self cleanInstVars: class.
- self cleanConstants: class.
+ self cleanInstVars: class.
+ self cleanConstants: class.
" ] timeToRun asMilliSeconds asString, 'ms'."
!
cleanConstants: class
- class constants removeAll.
+ class constants removeAll.
!
cleanGeneratedMethods: class
- ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
- class methodsDo: [ :mthd |
- mthd category = #generated ifTrue:[
- class removeSelector: mthd selector.
- ]
- ]
- ] ifFalse: [
- (class allSelectorsInProtocol: #generated) do: [ :selector |
- class removeSelectorSilently: selector ].
- ]
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ class methodsDo: [ :mthd |
+ mthd category = #generated ifTrue:[
+ class removeSelector: mthd selector.
+ ]
+ ]
+ ] ifFalse: [
+ (class allSelectorsInProtocol: #generated) do: [ :selector |
+ class removeSelectorSilently: selector ].
+ ]
!
cleanInstVars: class
- class class instanceVariableNames: ''.
+ class class instanceVariableNames: ''.
!
cleanParsers: class
- class parsers removeAll.
+ class parsers removeAll.
! !
!PPCCompiler methodsFor:'code generation'!
add: string
- currentMethod add: string.
+ currentMethod add: string.
!
addComment: string
- currentMethod add: '"', string, '"'.
+ currentMethod add: '"', string, '"'.
!
addConstant: value as: name
- constants at: name put: value
+ constants at: name put: value
!
addOnLine: string
- currentMethod addOnLine: string.
+ currentMethod addOnLine: string.
!
addVariable: name
@@ -124,74 +125,81 @@
!
call: anotherMethod
- currentMethod add: anotherMethod call.
+ currentMethod add: anotherMethod call.
!
callOnLine: anotherMethod
- currentMethod addOnLine: anotherMethod call.
+ currentMethod addOnLine: anotherMethod call.
!
dedent
- currentMethod dedent
+ currentMethod dedent
!
indent
- currentMethod indent
+ currentMethod indent
!
nl
- currentMethod nl
-!
-
-smartRemember: parser
- self flag: 'deprecated'.
- ^ self smartRemember: parser to: #memento
+ currentMethod nl
!
-smartRemember: parser to: variableName
- parser isContextFree ifTrue: [
- ^ variableName, ' := context lwRemember.'.
- ].
- ^ variableName, ':= context remember.'
-!
-
-smartRestore: parser
- self flag: 'deprecated'.
- ^ self smartRestore: parser from: #memento
+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: [
- ^ 'context lwRestore: ', mementoName, '.'.
- ].
- ^ 'context restore: ', 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.
+ 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"
+ "In case code hava a side effect"
self add: code
- ]
+ ]
!
codeClearError
- self add: 'self clearError.'.
+ self add: 'self clearError.'.
!
codeError: errorMessage
- self add: 'self error: ''', errorMessage, '''.'
+ self add: 'self error: ''', errorMessage, '''.'
!
codeHalt
- self add: 'self halt. '
+ self add: 'self halt. '
+!
+
+codeHaltIfShiftPressed
+ arguments debug ifTrue: [
+ self add: 'Halt ifShiftPressed.'
+ ]
+!
+
+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
@@ -206,162 +214,179 @@
!
codeReturn: code
- " - returns whatever is in code OR
- - assigns whatever is in code into the returnVariable"
+ " - returns whatever is in code OR
+ - assigns whatever is in code into the returnVariable"
currentMethod isInline ifTrue:[
- self codeAssign: code to: currentMethod returnVariable.
+ self codeAssign: code to: currentMethod returnVariable.
] ifFalse: [
- self add: '^ ', code
- ]
+ 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>"
+ | 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 uncapitalized asSymbol.
+!
+
idFor: object
- self assert: (object isKindOf: PPCNode).
- ^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none
+ 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
+ ^ self idFor: object prefixed: prefix effect: #none
!
idFor: object prefixed: prefix effect: effect
- ^ self idFor: object prefixed: prefix suffixed: '' 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 := object name.
- "Selector sanitizing inlined here as Smalltalk/X does not
- support asLegalSelector"
- name := name select: [:char | char isAlphaNumeric].
- (name isEmpty or: [ name first isLetter not ])
- ifTrue: [ name := 'v', 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
- ]
+ | 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
]
+ ]
+!
- "Modified: / 01-05-2015 / 14:38:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+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.
+ cache at: id put: value.
!
cachedValue: id
- ^ cache at: id ifAbsent: [ nil ]
+ ^ 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
+ | 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
+ | 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' ]
+ 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
- (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
-
- currentMethod := PPCInlinedMethod new.
- currentMethod id: id.
- currentMethod profile: arguments profile.
- currentMethod returnVariable: returnVariable.
- self push.
+ | 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!!' ].
+ (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
- currentMethod := PPCMethod new.
- currentMethod id: id.
- currentMethod profile: arguments profile.
- self push.
+ currentMethod := PPCMethod new.
+ currentMethod id: id.
+ currentMethod profile: arguments profile.
+ self push.
- self cache: id as: currentMethod.
+ self cache: id as: currentMethod.
"Modified: / 23-04-2015 / 18:36:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopInline
- ^ self pop.
+ ^ 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.
+ 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
+ ^ compilerStack top
! !
!PPCCompiler methodsFor:'code generation - variables'!
@@ -387,104 +412,73 @@
!PPCCompiler methodsFor:'compiling'!
compileParser
- self installVariables.
- self installMethods.
- self installClassConstants.
+ self installVariables.
+ self installMethods.
+ self installClassConstants.
- ^ compiledParser
+ ^ compiledParser
!
copy: parser
- ^ parser transform: [ :p | p copy ].
+ ^ parser transform: [ :p | p copy ].
!
installClassConstants
- constants keysAndValuesDo: [ :key :value |
- compiledParser constants at: key put: value
- ]
+ constants keysAndValuesDo: [ :key :value |
+ compiledParser constants at: key put: value
+ ]
!
installMethods
- cache keysAndValuesDo: [ :key :method |
- compiledParser compileSilently: method code classified: 'generated'.
- ]
+ cache keysAndValuesDo: [ :key :method |
+ compiledParser compileSilently: method code classified: 'generated'.
+ ]
!
installVariables
- | varString |
- varString := constants keys inject: '' into: [:r :e | r, ' ', e ].
-
- PPCompiledParser
- subclass: compiledParserName
- instanceVariableNames: varString
- classVariableNames: ''
- poolDictionaries: ''
- category: 'PetitCompiler-Generated'.
-
- compiledParser := Smalltalk at: compiledParserName.
-!
-
-precomputeFirstSets: root
- | firstSets |
- firstSets := root firstSets.
-
- root allNodesDo: [ :node |
- node firstSet: (firstSets at: node).
- ]
-
-!
+ | varString |
+ varString := constants keys inject: '' into: [:r :e | r, ' ', e ].
-precomputeFollowSets: root
- | followSets |
- followSets := root followSets.
-
- root allNodesDo: [ :node |
- node followSet: (followSets at: node).
- ]
-
-!
+ (self compiledParserSuperclass)
+ subclass: compiledParserName
+ instanceVariableNames: varString
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'PetitCompiler-Generated'.
-precomputeFollowSetsWithTokens: root
- | followSets |
- followSets := root followSetsSuchThat: [:e | e isTerminal or: [ e isKindOf: PPCTrimmingTokenNode ]].
-
- root allNodesDo: [ :node |
- node followSetWithTokens: (followSets at: node).
- ]
-
-!
-
-toCompilerTree: parser
- ^ parser asCompilerTree
+ compiledParser := Smalltalk at: compiledParserName.
! !
!PPCCompiler methodsFor:'initialization'!
initializeForCompiledClassName: aString
-
- self initialize.
- compilerStack := Stack new.
- cache := IdentityDictionary new.
- constants := IdentityDictionary new.
- ids := IdentityDictionary new.
-
+
+ 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'.
- ].
+ 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.
- ].
+ Smalltalk at: compiledParserName ifPresent: [ :class |
+ compiledParser := class.
+ self clean: compiledParser.
+ ].
+
+
+ Transcript cr; show: 'intialized for: ', aString; cr.
! !
!PPCCompiler class methodsFor:'documentation'!