--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCClassBuilder.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,154 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCClassBuilder
+ instanceVariableNames:'compiledClass compiledClassName constants instvars
+ methodDictionary compiledSuperclass'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Core'
+!
+
+!PPCClassBuilder methodsFor:'accessing'!
+
+compiledClass
+ ^ compiledClass
+!
+
+compiledClassName
+ ^ compiledClassName
+!
+
+compiledClassName: anObject
+ compiledClassName := anObject asSymbol
+!
+
+compiledSuperclass
+ ^ compiledSuperclass
+!
+
+compiledSuperclass: anObject
+ compiledSuperclass := anObject
+!
+
+constants
+ ^ constants
+!
+
+constants: anObject
+ constants := anObject
+!
+
+instvars
+ ^ instvars
+!
+
+instvars: anObject
+ instvars := anObject
+!
+
+methodDictionary
+ ^ methodDictionary
+!
+
+methodDictionary: anObject
+ methodDictionary := anObject
+! !
+
+!PPCClassBuilder methodsFor:'cleaning'!
+
+clean
+ Smalltalk at: compiledClassName ifPresent: [ :e |
+ compiledClass := e.
+ self cleanGeneratedMethods.
+ ]
+!
+
+cleanGeneratedMethods
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ compiledClass methodsDo: [ :mthd |
+ (mthd category beginsWith: 'generated') ifTrue:[
+ compiledClass removeSelector: mthd selector.
+ ]
+ ]
+ ] ifFalse: [
+ (compiledClass allProtocolsUpTo: compiledClass) do: [ :protocol |
+ (protocol beginsWith: 'generated') ifTrue: [
+ compiledClass removeProtocol: protocol.
+ ]
+ ]
+ ]
+! !
+
+!PPCClassBuilder methodsFor:'compiling'!
+
+compileClass
+ self clean.
+
+ self installVariables.
+ self installMethods.
+ self setConstants.
+
+ ^ compiledClass
+!
+
+installMethods
+ methodDictionary values do: [ :method |
+ (compiledClass methodDictionary includesKey: method methodName) ifFalse: [
+ compiledClass compileSilently: method code classified: method category.
+ ]
+ ]
+!
+
+installVariables
+ | instvarString classvarString |
+ instvarString := instvars inject: '' into: [:r :e | r, ' ', e ].
+ classvarString := constants keys inject: '' into: [:r :e | r, ' ', e ].
+
+ compiledSuperclass
+ subclass: compiledClassName
+ instanceVariableNames: instvarString
+ classVariableNames: classvarString
+ poolDictionaries: ''
+ category: 'PetitCompiler-Generated'.
+
+ compiledClass := Smalltalk at: compiledClassName.
+!
+
+registerPackages
+ ((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'.
+ ].
+!
+
+setClassVars
+ constants keysAndValuesDo: [ :key :value |
+ compiledClass classVarNamed: key put: value
+ ]
+!
+
+setConstants
+ constants keysAndValuesDo: [ :key :value |
+ compiledClass classVarNamed: key put: value
+ ]
+! !
+
+!PPCClassBuilder methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ methodDictionary := IdentityDictionary new.
+ constants := IdentityDictionary new.
+ instvars := IdentitySet new.
+
+ self registerPackages.
+! !
+