--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCClass.st Mon Aug 24 15:34:14 2015 +0100
@@ -0,0 +1,298 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCClass
+ instanceVariableNames:'methodDictionary currentMethod constants idGen arguments
+ methodStack returnVariable properties'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Compiler-Codegen'
+!
+
+!PPCClass methodsFor:'accessing'!
+
+arguments: args
+ arguments := args
+!
+
+constants
+ ^ constants
+!
+
+currentMethod
+ ^ currentMethod
+!
+
+currentNonInlineMethod
+ ^ methodStack
+ 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
+!
+
+idGen
+ ^ idGen
+!
+
+idGen: anObject
+ idGen := anObject
+!
+
+ids
+ ^ idGen ids
+!
+
+methodDictionary
+ ^ methodDictionary
+!
+
+name
+ ^ self propertyAt: #name
+!
+
+name: value
+ ^ self propertyAt: #name put: value
+!
+
+superclass
+ ^ self propertyAt: #superclass
+!
+
+superclass: value
+ ^ self propertyAt: #superclass put: value
+! !
+
+!PPCClass methodsFor:'accessing-properties'!
+
+hasProperty: aKey
+ "Test if the property aKey is present."
+
+ ^ properties notNil and: [ properties includesKey: aKey ]
+!
+
+properties
+ ^ properties
+!
+
+properties: aDictionary
+ properties := aDictionary
+!
+
+propertyAt: aKey
+ ^ self propertyAt: aKey ifAbsent: [ nil ]
+!
+
+propertyAt: aKey ifAbsent: aBlock
+ "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+
+ ^ properties isNil
+ ifTrue: [ aBlock value ]
+ ifFalse: [ properties at: aKey ifAbsent: aBlock ]
+!
+
+propertyAt: aKey ifAbsentPut: aBlock
+ "Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+
+ ^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+!
+
+propertyAt: aKey put: anObject
+ "Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+ ^ (properties ifNil: [ properties := Dictionary new: 1 ])
+ at: aKey put: anObject
+! !
+
+!PPCClass methodsFor:'constants'!
+
+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>"
+! !
+
+!PPCClass methodsFor:'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: anObject
+ ^ idGen idFor: anObject
+!
+
+idFor: anObject defaultName: defaultName
+ ^ idGen idFor: anObject defaultName: defaultName
+!
+
+numberIdFor: object
+ ^ idGen numericIdFor: object
+! !
+
+!PPCClass methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ methodStack := Stack new.
+ methodDictionary := IdentityDictionary new.
+ constants := Dictionary new.
+ idGen := PPCIdGenerator new.
+! !
+
+!PPCClass methodsFor:'method cache'!
+
+cachedMethod: id
+ ^ methodDictionary at: id ifAbsent: [ nil ]
+!
+
+cachedMethod: id ifPresent: aBlock
+ ^ methodDictionary at: id ifPresent: aBlock
+!
+
+store: method as: id
+ self assert: (method isKindOf: PPCMethod).
+ methodDictionary at: id put: method.
+! !
+
+!PPCClass methodsFor:'support'!
+
+parsedValueOf: 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 isMethod).
+ ^ method
+!
+
+pop
+ | retval |
+ retval := methodStack pop.
+ currentMethod := methodStack isEmpty
+ ifTrue: [ nil ]
+ ifFalse: [ methodStack top ].
+ ^ retval
+
+ "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+push
+ methodStack push: currentMethod.
+ (methodStack 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>"
+!
+
+returnVariable
+ self error: 'Should never be called and accessed outside this class'.
+ ^ returnVariable
+!
+
+startInline
+ | indentationLevel |
+ indentationLevel := currentMethod indentationLevel.
+
+ currentMethod := PPCInlinedMethod new.
+ currentMethod returnVariable: returnVariable.
+ currentMethod indentationLevel: indentationLevel.
+ self push.
+
+ "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+startInline: id
+ | indentationLevel |
+ (methodDictionary 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 category: category
+ (methodDictionary includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
+
+ currentMethod := PPCMethod new.
+ currentMethod id: id.
+ currentMethod category: category.
+
+ self push.
+ self store: currentMethod as: id.
+
+ "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 store: currentMethod as: currentMethod methodName.
+ ^ self pop.
+! !
+
+!PPCClass methodsFor:'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>"
+! !
+