|
1 " |
|
2 COPYRIGHT (c) 1988-93 by Claus Gittinger |
|
3 All Rights Reserved |
|
4 |
|
5 This software is furnished under a license and may be used |
|
6 only in accordance with the terms of that license and with the |
|
7 inclusion of the above copyright notice. This software may not |
|
8 be provided or otherwise made available to, or used by, any |
|
9 other person. No title to or ownership of the software is |
|
10 hereby transferred. |
|
11 " |
|
12 |
|
13 Class subclass:#Metaclass |
|
14 instanceVariableNames:'' |
|
15 classVariableNames:'' |
|
16 poolDictionaries:'' |
|
17 category:'Kernel-Classes' |
|
18 ! |
|
19 |
|
20 Metaclass comment:' |
|
21 |
|
22 COPYRIGHT (c) 1988-93 by Claus Gittinger |
|
23 All Rights Reserved |
|
24 |
|
25 every class-class is a subclass of Metaclass |
|
26 - this adds support for creating new subclasses or changing the definition |
|
27 of an already existing class. |
|
28 |
|
29 %W% %E% |
|
30 '! |
|
31 |
|
32 !Metaclass methodsFor:'creating classes'! |
|
33 |
|
34 name:newName inEnvironment:aSystemDictionary |
|
35 subclassOf:aClass |
|
36 instanceVariableNames:stringOfInstVarNames |
|
37 variable:variableBoolean |
|
38 words:wordsBoolean |
|
39 pointers:pointersBoolean |
|
40 classVariableNames:stringOfClassVarNames |
|
41 poolDictionaries:stringOfPoolNames |
|
42 category:categoryString |
|
43 comment:commentString |
|
44 changed:changed |
|
45 |
|
46 |newClass newMetaclass nInstVars nameString classSymbol oldClass |
|
47 allSubclasses classVarChange instVarChange superClassChange newComment |
|
48 upd| |
|
49 |
|
50 nInstVars := stringOfInstVarNames countWords. |
|
51 nameString := newName asString. |
|
52 classSymbol := nameString asSymbol. |
|
53 newComment := commentString. |
|
54 |
|
55 (aSystemDictionary includesKey:classSymbol) ifTrue:[ |
|
56 oldClass := aSystemDictionary at:classSymbol. |
|
57 (newComment isNil and:[oldClass isBehavior "isKindOf:Class"]) ifTrue:[ |
|
58 newComment := oldClass comment |
|
59 ] |
|
60 ]. |
|
61 |
|
62 "create the metaclass first" |
|
63 newMetaclass := Metaclass new. |
|
64 newMetaclass setSuperclass:(aClass class). |
|
65 newMetaclass instSize:(aClass class instSize). |
|
66 newMetaclass flags:0. "not indexed" |
|
67 newMetaclass setName:(nameString , 'class'). |
|
68 newMetaclass classVariableString:'' "stringOfClassVarNames". |
|
69 newMetaclass setComment:newComment category:categoryString. |
|
70 |
|
71 newClass := newMetaclass new. |
|
72 newClass setSuperclass:aClass. |
|
73 newClass instSize:(aClass instSize + nInstVars). |
|
74 |
|
75 (variableBoolean == true) ifTrue:[ |
|
76 pointersBoolean ifTrue:[ |
|
77 newClass flags:4 "pointerarray" |
|
78 ] ifFalse:[ |
|
79 wordsBoolean ifTrue:[ |
|
80 newClass flags:2 "wordarray" |
|
81 ] ifFalse:[ |
|
82 newClass flags:1 "bytearray" |
|
83 ] |
|
84 ] |
|
85 ] ifFalse:[ |
|
86 "this is a backward compatible hack" |
|
87 |
|
88 (variableBoolean == #float) ifTrue:[ |
|
89 newClass flags:6 "float array" |
|
90 ] ifFalse:[ |
|
91 (variableBoolean == #double) ifTrue:[ |
|
92 newClass flags:7 "double array" |
|
93 ] ifFalse:[ |
|
94 (variableBoolean == #long) ifTrue:[ |
|
95 newClass flags:3 "long array" |
|
96 ] ifFalse:[ |
|
97 newClass flags:0 |
|
98 ] |
|
99 ] |
|
100 ]. |
|
101 ]. |
|
102 |
|
103 newClass setName:nameString. |
|
104 (nInstVars ~~ 0) ifTrue:[ |
|
105 newClass instanceVariableString:stringOfInstVarNames |
|
106 ]. |
|
107 oldClass notNil ifTrue:[ |
|
108 "setting first will make new class clear obsolete classvars" |
|
109 newClass setClassVariableString:(oldClass classVariableString) |
|
110 ]. |
|
111 newClass classVariableString:stringOfClassVarNames. |
|
112 |
|
113 oldClass notNil ifTrue:[ |
|
114 "dont have to flush if class is brand-new" |
|
115 |
|
116 ObjectMemory flushCaches. |
|
117 ]. |
|
118 |
|
119 aSystemDictionary at:classSymbol put:newClass. |
|
120 |
|
121 self addChangeRecordForClass:newClass. |
|
122 |
|
123 oldClass isNil ifTrue:[ |
|
124 commentString notNil ifTrue:[ |
|
125 newClass comment:commentString |
|
126 ] |
|
127 ] ifFalse:[ |
|
128 "if only category/comment has changed, do not recompile .." |
|
129 |
|
130 (oldClass superclass == newClass superclass) ifTrue:[ |
|
131 (oldClass instSize == newClass instSize) ifTrue:[ |
|
132 (oldClass flags == newClass flags) ifTrue:[ |
|
133 (oldClass name = newClass name) ifTrue:[ |
|
134 (oldClass instanceVariableString = newClass instanceVariableString) ifTrue:[ |
|
135 (oldClass classVariableString = newClass classVariableString) ifTrue:[ |
|
136 (newComment ~= oldClass comment) ifTrue:[ |
|
137 oldClass comment:newComment |
|
138 ]. |
|
139 oldClass category:categoryString. |
|
140 aSystemDictionary at:classSymbol put:oldClass. |
|
141 oldClass changed. |
|
142 ^ oldClass |
|
143 ] |
|
144 ] |
|
145 ] |
|
146 ] |
|
147 ] |
|
148 ]. |
|
149 |
|
150 (newComment ~= oldClass comment) ifTrue:[ |
|
151 newClass comment:newComment |
|
152 ]. |
|
153 |
|
154 upd := Class updateChanges:false. |
|
155 |
|
156 superClassChange := oldClass superclass ~~ newClass superclass. |
|
157 |
|
158 classVarChange := oldClass classVariableString ~= newClass classVariableString. |
|
159 |
|
160 classVarChange ifTrue:[ |
|
161 " no need to recompile if classvars are added " |
|
162 classVarChange := (newClass classVariableString startsWith: oldClass classVariableString) not |
|
163 ]. |
|
164 classVarChange := classVarChange or:[superClassChange]. |
|
165 classVarChange := classVarChange or:[self anyInvalidatedMethodsIn: oldClass class]. |
|
166 |
|
167 classVarChange ifTrue:[ |
|
168 "must recompile class-methods" |
|
169 self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass. |
|
170 newMetaclass recompile |
|
171 ] ifFalse:[ |
|
172 "class methods still work" |
|
173 self copyMethodsFrom:(oldClass class) for:newMetaclass |
|
174 ]. |
|
175 |
|
176 instVarChange := oldClass instanceVariableString ~= newClass instanceVariableString. |
|
177 instVarChange ifTrue:[ |
|
178 " no need to recompile if instvars are added " |
|
179 instVarChange := (newClass instanceVariableString startsWith: oldClass instanceVariableString) not |
|
180 ]. |
|
181 instVarChange := instVarChange or:[superClassChange]. |
|
182 instVarChange := instVarChange or:[self anyInvalidatedMethodsIn: oldClass]. |
|
183 |
|
184 (instVarChange or:[classVarChange]) ifTrue:[ |
|
185 "must recompile instance-methods" |
|
186 self copyInvalidatedMethodsFrom:oldClass for:newClass. |
|
187 newClass recompile |
|
188 ] ifFalse:[ |
|
189 "instance methods still work" |
|
190 self copyMethodsFrom:oldClass for:newClass |
|
191 ]. |
|
192 |
|
193 "get list of all subclasses - do before superclass is changed" |
|
194 |
|
195 allSubclasses := oldClass allSubclasses. |
|
196 |
|
197 "update superclass of immediate subclasses" |
|
198 |
|
199 oldClass subclassesDo:[:aClass | |
|
200 aClass superclass:newClass |
|
201 ]. |
|
202 |
|
203 "update instSizes and recompile all subclasses if needed" |
|
204 |
|
205 "for subclasses we must be strict" |
|
206 classVarChange := oldClass classVariableString ~= newClass classVariableString. |
|
207 classVarChange := classVarChange or:[superClassChange]. |
|
208 |
|
209 "for subclasses we must be strict since offsets change" |
|
210 instVarChange := oldClass instanceVariableString ~= newClass instanceVariableString. |
|
211 instVarChange := instVarChange or:[superClassChange]. |
|
212 |
|
213 allSubclasses do:[:aClass | |
|
214 aClass instSize:(aClass instSize + (newClass instSize - oldClass instSize)). |
|
215 (classVarChange or:[self anyInvalidatedMethodsIn:aClass class]) ifTrue:[ |
|
216 aClass class recompileAll |
|
217 ]. |
|
218 (classVarChange or:[instVarChange or:[self anyInvalidatedMethodsIn: aClass]]) ifTrue:[ |
|
219 aClass recompileAll |
|
220 ] |
|
221 ]. |
|
222 |
|
223 ObjectMemory flushCaches. |
|
224 Class updateChanges:upd |
|
225 ]. |
|
226 oldClass isNil ifTrue:[ |
|
227 Smalltalk changed |
|
228 ] ifFalse:[ |
|
229 oldClass setName:(oldClass name , '-old') |
|
230 ]. |
|
231 ^ newClass |
|
232 ! |
|
233 |
|
234 new |
|
235 "returs a new class class" |
|
236 |newClass| |
|
237 |
|
238 newClass := self basicNew. |
|
239 newClass setSuperclass:(Object class) |
|
240 selectors:(Array new:0) |
|
241 methods:(Array new:0) |
|
242 instSize:0 |
|
243 flags:0. |
|
244 newClass setComment:(self comment) category:(self category). |
|
245 ^ newClass |
|
246 ! ! |
|
247 |
|
248 !Metaclass methodsFor:'class instance variables'! |
|
249 |
|
250 instanceVariableNames:aString |
|
251 "changing / adding class-inst vars - |
|
252 this actually creates a new metaclass and class" |
|
253 |
|
254 |newClass newMetaclass nClassInstVars oldClass |
|
255 allSubclasses upd t oldVars sizeChange| |
|
256 |
|
257 oldVars := self instanceVariableString. |
|
258 aString = oldVars ifTrue:[^ self]. |
|
259 |
|
260 nClassInstVars := aString countWords. |
|
261 sizeChange := nClassInstVars ~~ oldVars countWords. |
|
262 |
|
263 "create the new metaclass" |
|
264 newMetaclass := Metaclass new. |
|
265 newMetaclass setSuperclass:superclass. |
|
266 newMetaclass instSize:(superclass instSize + nClassInstVars). |
|
267 (nClassInstVars ~~ 0) ifTrue:[ |
|
268 newMetaclass instanceVariableString:aString |
|
269 ]. |
|
270 newMetaclass flags:0. "not indexed" |
|
271 newMetaclass setName:name. |
|
272 newMetaclass classVariableString:classvars. |
|
273 newMetaclass category:category. |
|
274 newMetaclass setComment:comment. |
|
275 |
|
276 "find the class which is my sole instance" |
|
277 |
|
278 t := Smalltalk allClasses select:[:element | element class == self]. |
|
279 (t size ~~ 1) ifTrue:[ |
|
280 self error:'oops - I should have exactly one instance'. |
|
281 ^ nil |
|
282 ]. |
|
283 oldClass := t anElement. |
|
284 |
|
285 "create a new class" |
|
286 newClass := newMetaclass new. |
|
287 newClass setSuperclass:(oldClass superclass). |
|
288 newClass instSize:(oldClass instSize). |
|
289 newClass flags:(oldClass flags). |
|
290 newClass setName:(oldClass name). |
|
291 newClass instanceVariableString:(oldClass instanceVariableString). |
|
292 newClass classVariableString:(oldClass classVariableString). |
|
293 newClass comment:(oldClass comment). |
|
294 newClass category:(oldClass category). |
|
295 |
|
296 ObjectMemory flushCaches. |
|
297 |
|
298 Smalltalk at:(oldClass name asSymbol) put:newClass. |
|
299 |
|
300 upd := Class updateChanges:false. |
|
301 |
|
302 (oldVars isBlank |
|
303 or:[aString startsWith:oldVars]) ifTrue:[ |
|
304 "there where none before or a new var has been added |
|
305 - methods still work" |
|
306 self copyMethodsFrom:self for:newMetaclass. |
|
307 self copyMethodsFrom:oldClass for:newClass |
|
308 ] ifFalse:[ |
|
309 "recompile class-methods" |
|
310 self copyInvalidatedMethodsFrom:self for:newMetaclass. |
|
311 newMetaclass recompile. |
|
312 |
|
313 "recompile instance-methods" |
|
314 self copyInvalidatedMethodsFrom:oldClass for:newClass. |
|
315 newClass recompile |
|
316 ]. |
|
317 |
|
318 "get list of all subclasses - do before superclass is changed" |
|
319 |
|
320 allSubclasses := oldClass allSubclasses. |
|
321 |
|
322 "update superclass of immediate subclasses" |
|
323 |
|
324 oldClass subclassesDo:[:aClass | |
|
325 aClass superclass:newClass |
|
326 ]. |
|
327 |
|
328 "update instSizes and recompile all subclasses if needed" |
|
329 |
|
330 allSubclasses do:[:aClass | |
|
331 aClass class recompileAll. |
|
332 aClass recompileAll |
|
333 ]. |
|
334 |
|
335 ObjectMemory flushCaches. |
|
336 Class updateChanges:upd. |
|
337 ^ newMetaclass |
|
338 ! ! |
|
339 |
|
340 !Metaclass methodsFor:'queries'! |
|
341 |
|
342 isMeta |
|
343 "return true, if the receiver is some kind of metaclass; |
|
344 true is returned here. Redefines isMeta in Object" |
|
345 |
|
346 ^ true |
|
347 ! ! |
|
348 |
|
349 !Metaclass methodsFor:'private'! |
|
350 |
|
351 copyMethodsFrom:oldClass for:newClass |
|
352 "when a class has changed, but metaclass is unaffected (i.e. classVars |
|
353 have not changed) there is no need to recompile them" |
|
354 |
|
355 newClass selectors:(oldClass selectors) methods:(oldClass methodDictionary) |
|
356 ! |
|
357 |
|
358 copyInvalidatedMethodsFrom:oldClass for:newClass |
|
359 "when a class has been changed, copy all old methods into the new class |
|
360 - changing code to a trap method giving an error message; |
|
361 this allows us to keep the source while trapping uncompilable (due to |
|
362 now undefined instvars) methods" |
|
363 |
|
364 |trap trapCode trapByteCode| |
|
365 |
|
366 trap := Method compiledMethodAt:#invalidMethod. |
|
367 trapCode := trap code. |
|
368 trapByteCode := trap byteCode. |
|
369 |
|
370 newClass selectors:(oldClass selectors) methods:(oldClass methodDictionary). |
|
371 newClass methodDictionary do:[:aMethod | |
|
372 aMethod code:trapCode. |
|
373 aMethod literals:nil. |
|
374 aMethod byteCode:trapByteCode |
|
375 ] |
|
376 ! |
|
377 |
|
378 anyInvalidatedMethodsIn:aClass |
|
379 "return true, if aClass has any invalidated methods in it" |
|
380 |
|
381 |trap trapCode trapByteCode| |
|
382 |
|
383 trap := Method compiledMethodAt:#invalidMethod. |
|
384 trapCode := trap code. |
|
385 trapByteCode := trap byteCode. |
|
386 |
|
387 aClass methodDictionary do:[:aMethod | |
|
388 trapCode notNil ifTrue:[ |
|
389 (aMethod code == trapCode) ifTrue:[^ true] |
|
390 ]. |
|
391 trapByteCode notNil ifTrue:[ |
|
392 (aMethod byteCode == trapByteCode) ifTrue:[^ true] |
|
393 ] |
|
394 ]. |
|
395 ^ false |
|
396 ! ! |