--- /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.
+! !
+