CI: Use VM provided by Pharo team on both Linux and Windows.
Hand-crafter Pharo VM is no longer needed as the Linux slave in
SWING build farm has been upgraded so it has compatible GLIBC.
This makes CI scripts simpler and more usable for other people.
"{ 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> $'
! !