"{ Package: 'stx:goodies/petitparser/compiler' }"

"{ NameSpace: Smalltalk }"

Object subclass:#PPCClassBuilder
	instanceVariableNames:'compiledClass compiledClassName constants instvars
		methodDictionary compiledSuperclass'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Core'
!

!PPCClassBuilder class methodsFor:'instance creation'!

new
    "return an initialized instance"

    ^ self basicNew initialize.
! !

!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
    (compiledClass methodDictionary size == 0) ifTrue: [ ^ self ].

    "this is hack, but might help the performance..."
    (compiledClass methods allSatisfy: [:m | m category beginsWith: 'generated']) ifTrue: [
        compiledClass removeFromSystem.
        compiledClass := nil.
        ^ self
    ].


    ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
        compiledClass methodsDo: [ :mthd |
            (mthd category beginsWith: 'generated') ifTrue:[
                compiledClass removeSelector: mthd selector.
            ]
        ]
    ] ifFalse: [ 
"		compiledClass methodsDo: [ :mthd |
            (mthd category beginsWith: 'generated') ifTrue:[
                compiledClass removeSelector: mthd selector.
            ]
        ]
"
"		Too slow, but more stable :("
        (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 source 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.
! !