|
1 "{ Package: 'stx:goodies/petitparser/compiler' }" |
|
2 |
|
3 "{ NameSpace: Smalltalk }" |
|
4 |
|
5 Object subclass:#PPCClassBuilder |
|
6 instanceVariableNames:'compiledClass compiledClassName constants instvars |
|
7 methodDictionary compiledSuperclass' |
|
8 classVariableNames:'' |
|
9 poolDictionaries:'' |
|
10 category:'PetitCompiler-Core' |
|
11 ! |
|
12 |
|
13 !PPCClassBuilder methodsFor:'accessing'! |
|
14 |
|
15 compiledClass |
|
16 ^ compiledClass |
|
17 ! |
|
18 |
|
19 compiledClassName |
|
20 ^ compiledClassName |
|
21 ! |
|
22 |
|
23 compiledClassName: anObject |
|
24 compiledClassName := anObject asSymbol |
|
25 ! |
|
26 |
|
27 compiledSuperclass |
|
28 ^ compiledSuperclass |
|
29 ! |
|
30 |
|
31 compiledSuperclass: anObject |
|
32 compiledSuperclass := anObject |
|
33 ! |
|
34 |
|
35 constants |
|
36 ^ constants |
|
37 ! |
|
38 |
|
39 constants: anObject |
|
40 constants := anObject |
|
41 ! |
|
42 |
|
43 instvars |
|
44 ^ instvars |
|
45 ! |
|
46 |
|
47 instvars: anObject |
|
48 instvars := anObject |
|
49 ! |
|
50 |
|
51 methodDictionary |
|
52 ^ methodDictionary |
|
53 ! |
|
54 |
|
55 methodDictionary: anObject |
|
56 methodDictionary := anObject |
|
57 ! ! |
|
58 |
|
59 !PPCClassBuilder methodsFor:'cleaning'! |
|
60 |
|
61 clean |
|
62 Smalltalk at: compiledClassName ifPresent: [ :e | |
|
63 compiledClass := e. |
|
64 self cleanGeneratedMethods. |
|
65 ] |
|
66 ! |
|
67 |
|
68 cleanGeneratedMethods |
|
69 ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ |
|
70 compiledClass methodsDo: [ :mthd | |
|
71 (mthd category beginsWith: 'generated') ifTrue:[ |
|
72 compiledClass removeSelector: mthd selector. |
|
73 ] |
|
74 ] |
|
75 ] ifFalse: [ |
|
76 (compiledClass allProtocolsUpTo: compiledClass) do: [ :protocol | |
|
77 (protocol beginsWith: 'generated') ifTrue: [ |
|
78 compiledClass removeProtocol: protocol. |
|
79 ] |
|
80 ] |
|
81 ] |
|
82 ! ! |
|
83 |
|
84 !PPCClassBuilder methodsFor:'compiling'! |
|
85 |
|
86 compileClass |
|
87 self clean. |
|
88 |
|
89 self installVariables. |
|
90 self installMethods. |
|
91 self setConstants. |
|
92 |
|
93 ^ compiledClass |
|
94 ! |
|
95 |
|
96 installMethods |
|
97 methodDictionary values do: [ :method | |
|
98 (compiledClass methodDictionary includesKey: method methodName) ifFalse: [ |
|
99 compiledClass compileSilently: method code classified: method category. |
|
100 ] |
|
101 ] |
|
102 ! |
|
103 |
|
104 installVariables |
|
105 | instvarString classvarString | |
|
106 instvarString := instvars inject: '' into: [:r :e | r, ' ', e ]. |
|
107 classvarString := constants keys inject: '' into: [:r :e | r, ' ', e ]. |
|
108 |
|
109 compiledSuperclass |
|
110 subclass: compiledClassName |
|
111 instanceVariableNames: instvarString |
|
112 classVariableNames: classvarString |
|
113 poolDictionaries: '' |
|
114 category: 'PetitCompiler-Generated'. |
|
115 |
|
116 compiledClass := Smalltalk at: compiledClassName. |
|
117 ! |
|
118 |
|
119 registerPackages |
|
120 ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ |
|
121 | rPackageOrganizer | |
|
122 rPackageOrganizer := Smalltalk at: #RPackageOrganizer. |
|
123 rPackageOrganizer notNil ifTrue:[ |
|
124 rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'. |
|
125 ]. |
|
126 ] ifFalse: [ |
|
127 RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'. |
|
128 ]. |
|
129 ! |
|
130 |
|
131 setClassVars |
|
132 constants keysAndValuesDo: [ :key :value | |
|
133 compiledClass classVarNamed: key put: value |
|
134 ] |
|
135 ! |
|
136 |
|
137 setConstants |
|
138 constants keysAndValuesDo: [ :key :value | |
|
139 compiledClass classVarNamed: key put: value |
|
140 ] |
|
141 ! ! |
|
142 |
|
143 !PPCClassBuilder methodsFor:'initialization'! |
|
144 |
|
145 initialize |
|
146 super initialize. |
|
147 |
|
148 methodDictionary := IdentityDictionary new. |
|
149 constants := IdentityDictionary new. |
|
150 instvars := IdentitySet new. |
|
151 |
|
152 self registerPackages. |
|
153 ! ! |
|
154 |