1Smalltalk.Metaclass extend [
2
3    newMeta: className environment: aNamespace subclassOf: theSuperclass instanceVariableArray: arrayOfInstVarNames shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
4	"Private - create a full featured class and install it"
5
6	<category: 'basic'>
7	| aClass |
8	aClass := self new.
9	classVarDict environment: aClass.
10	instanceClass := aClass.
11	aNamespace at: className put: aClass.
12	theSuperclass isNil ifFalse: [theSuperclass addSubclass: aClass].
13	Behavior flushCache.
14	aClass := aClass
15		    superclass: theSuperclass;
16		    setName: className;
17		    setEnvironment: aNamespace;
18		    setInstanceVariables: arrayOfInstVarNames;
19		    setInstanceSpec: shape instVars: arrayOfInstVarNames size;
20		    setClassVariables: classVarDict;
21		    setSharedPools: sharedPoolNames;
22		    makeUntrusted: theSuperclass isUntrusted;
23		    category: categoryName;
24		    yourself.
25	VisualGST.SystemChangeNotifier root classAdded: aClass.
26	^ aClass
27    ]
28
29    name: className environment: aNamespace subclassOf: newSuperclass instanceVariableArray: variableArray shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
30    "Private - create a full featured class and install it, or change an
31     existing one"
32
33    <category: 'basic'>
34    | oldClass aClass realShape needToRecompileMetaclasses needToRecompileClasses |
35    realShape := shape == #word
36	    ifTrue: [CSymbols.CLongSize = 4 ifTrue: [#uint] ifFalse: [#uint64]]
37	    ifFalse: [shape].
38
39    "Look for an existing metaclass"
40    aClass := aNamespace hereAt: className ifAbsent: [nil].
41    aClass isNil
42        ifTrue:
43	[^self
44	    newMeta: className
45	    environment: aNamespace
46	    subclassOf: newSuperclass
47	    instanceVariableArray: variableArray
48	    shape: realShape
49	    classPool: classVarDict
50	    poolDictionaries: sharedPoolNames
51	    category: categoryName].
52    aClass isVariable & realShape notNil
53        ifTrue:
54	[aClass shape == realShape
55	    ifFalse:
56	    [SystemExceptions.MutationError
57	        signal: 'Cannot change shape of variable class']].
58    newSuperclass isUntrusted & self class isUntrusted not
59        ifTrue:
60	[SystemExceptions.MutationError
61	    signal: 'Cannot move trusted class below untrusted superclass'].
62    needToRecompileMetaclasses := false.
63    oldClass := aClass copy.
64    aClass classPool isNil
65        ifTrue: [aClass setClassVariables: classVarDict]
66        ifFalse:
67	[classVarDict keysDo:
68	    [:key |
69	    (aClass classPool includesKey: key) ifFalse: [aClass addClassVarName: key]].
70	aClass classPool keys do:
71	    [:aKey |
72	    (classVarDict includesKey: aKey)
73	        ifFalse:
74		[aClass removeClassVarName: aKey.
75		needToRecompileMetaclasses := true]]].
76
77    "If instance or indexed variables change, update
78     instance variables and instance spec of the class and all its subclasses"
79    (needToRecompileClasses := variableArray ~= aClass allInstVarNames
80	    | needToRecompileMetaclasses) | (aClass shape ~~ realShape)
81        ifTrue:
82	[aClass instanceCount > 0 ifTrue: [ObjectMemory globalGarbageCollect].
83	aClass
84	    updateInstanceVars: variableArray
85	    superclass: newSuperclass
86	    shape: realShape].
87
88    "Now add/remove pool dictionaries.  FIXME: They may affect name binding,
89     so we should probably recompile everything if they change."
90    aClass sharedPoolDictionaries isEmpty
91        ifTrue: [aClass setSharedPools: sharedPoolNames]
92        ifFalse:
93	[sharedPoolNames do:
94	    [:dict |
95	    (aClass sharedPoolDictionaries includes: dict)
96	        ifFalse: [aClass addSharedPool: dict]].
97	aClass sharedPoolDictionaries copy do:
98	    [:dict |
99	    (sharedPoolNames includes: dict)
100	        ifFalse:
101		[aClass removeSharedPool: dict.
102		needToRecompileMetaclasses := true]]].
103    aClass superclass ~~ newSuperclass
104        ifTrue:
105	["Mutate the class if the set of class-instance variables changes."
106
107	self superclass allInstVarNames ~= newSuperclass class allInstVarNames
108	    ifTrue:
109	    [aClass class
110	        updateInstanceVars:
111		newSuperclass class allInstVarNames,
112		aClass class instVarNames
113	        superclass: newSuperclass class
114	        shape: aClass class shape].
115
116	"Fix references between classes..."
117	aClass superclass removeSubclass: aClass.
118	newSuperclass addSubclass: aClass.
119	aClass superclass: newSuperclass.
120	needToRecompileClasses := true.
121
122	"...and between metaclasses..."
123	self superclass removeSubclass: self.
124	newSuperclass class addSubclass: self.
125	self superclass: newSuperclass class.
126	needToRecompileMetaclasses := true].
127    aClass category: categoryName.
128
129    "Please note that I need to recompile the classes in this sequence;
130     otherwise, the same error is propagated to each selector which is compiled
131     after an error is detected even though there are no further compilation
132     errors. Apparently, there is a bug in the primitive #primCompile:.  This
133     can be cleaned up later"
134    needToRecompileClasses | needToRecompileMetaclasses
135        ifTrue:
136	[aClass compileAll.
137	needToRecompileMetaclasses ifTrue: [aClass class compileAll].
138	aClass compileAllSubclasses.
139	needToRecompileMetaclasses ifTrue: [aClass class compileAllSubclasses]].
140    Behavior flushCache.
141    VisualGST.SystemChangeNotifier root classDefinitionChangedFrom: oldClass to: aClass.
142    ^aClass
143    ]
144]
145
146