"{ 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 methodDictionary values 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.

            ]           

        ]

    ]

    "Modified: / 17-08-2015 / 13:55:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

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

        ]

    ]

    "Modified: / 24-07-2015 / 19:45:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

installVariables

    | instvarString classvarString |

    instvarString := instvars inject: '' into: [:r :e | r, ' ', e  ].

    classvarString := constants keys inject: '' into: [:r :e | r, ' ', e  ].

    ((Smalltalk respondsTo:#isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifTrue:[

        [

            compiledSuperclass 

                subclass: compiledClassName  

                instanceVariableNames: instvarString 

                classVariableNames: classvarString 

                poolDictionaries: '' 

                category: 'PetitCompiler-Generated'.

        ] on: ClassBuildWarning do:[:ex | ex proceed ].

    ] ifFalse:[

        compiledSuperclass 

            subclass: compiledClassName  

            instanceVariableNames: instvarString 

            classVariableNames: classvarString 

            poolDictionaries: '' 

            category: 'PetitCompiler-Generated'.

    ].

    compiledClass := Smalltalk at: compiledClassName.

    "Modified: / 17-08-2015 / 14:44:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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.

! !

!PPCClassBuilder class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !