> Thus, we have created a new version of the fix that incorporates both my and
> his changes. This version works with Squeak 3.2gamma (4827), but it does not
> work with Squeak 3.3 yet. As I said before, I'm going to look at that with
> Henrik next week and try to make it compatible.
> 
> Cheers,
> Nathanael

Here is a version that we have tested with 3.3a-4843 and 4827, early 3.3a
images will not work (e.g. 4769). It should be fine for going into the
update stream.

Henrik & Nathanael

-------------- next part --------------
'From Squeak3.3alpha of 30 January 2002 [latest update: #4843] on 2 May 2002 at 12:04:37 pm'!
"Change Set:		ClassBuilderFix for 3.3a
Date:			23 April 2002
Author:			Nathanael SchŠrli & Andreas Raab

Fixes various problems in both ClassBuilder and the handling of obsolete subclasses. Updated for modules."!

Object subclass: #ClassBuilder2
	instanceVariableNames: 'environ blah classMap instVarMap progress maxClassIndex currentClassIndex module '
	classVariableNames: 'QuietMode '
	module: #(Squeak Language Core Classes)!

!Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:13'!
removeAllObsoleteSubclasses
	"Remove all the obsolete subclasses of the receiver"
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	ObsoleteSubclasses removeKey: self ifAbsent: [].
! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:16'!
removeObsoleteSubclass: aClass
	"Remove aClass from the weakly remembered obsolete subclasses"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	obs _ ObsoleteSubclasses at: self ifAbsent:[^ self].
	(obs includes: aClass) ifFalse:[^self].
	obs _ obs copyWithout: aClass.
	obs _ obs copyWithout: nil.
	obs isEmpty
		ifTrue: [ObsoleteSubclasses removeKey: self ifAbsent: []]
		ifFalse: [ObsoleteSubclasses at: self put: obs].! !


!ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/15/2002 00:46'!
newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe
	"Create a new subclass of the given superclass.
	Note: The new class may be meta."
	| newFormat newClass meta |
	"Compute the format of the new class"
	newFormat _ 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
	newFormat == nil ifTrue:[^nil].

	"Check if we really need a new subclass"
	(oldClass ~~ nil and:[
		newSuper == oldClass superclass and:[
			newFormat = oldClass format and:[
				instVars = oldClass instVarNames]]]) 
					ifTrue:[^oldClass].

	unsafe ifFalse:[
		"Make sure we don't redefine any dangerous classes"
		(self tooDangerousClasses includes: oldClass name) ifTrue:[
			self error: oldClass name, ' cannot be changed'.
		].

		"Check if the receiver should not be redefined"
		(oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined!! \Proceed to store over it.' withCRs]].

	(oldClass == nil or:[oldClass isMeta not]) ifTrue:["Requires new metaclass"
		meta _ Metaclass new.
		meta
			superclass: (newSuper ifNil:[Class] ifNotNil:[newSuper class])
			methodDictionary: MethodDictionary new
			format: (newSuper ifNil:[Class format] ifNotNil:[newSuper class format]).
		meta superclass addSubclass: meta. "In case of Class"
		newClass _ meta new.
	] ifFalse:[ newClass _ oldClass clone].
	newClass 
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: newFormat;
		setInstVarNames: instVars;
		organization: (oldClass ifNotNil:[oldClass organization]).
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 5/2/2002 11:18'!
reshapeClass: aClass to: templateClass super: newSuper
	"Reshape the given class to the new super class.
	If templateClass is not nil then it defines the shape of the new class"
	| fmt newClass newMeta newSuperMeta oldMeta instVars oldClass aClassIsObsolete |
	aClassIsObsolete _ aClass isObsolete.
	templateClass == nil
		ifTrue:[oldClass _ aClass]
		ifFalse:[oldClass _ templateClass].
	aClass becomeUncompact.
	"Compute the new format of the class"
	instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames].
	fmt _ self computeFormat: oldClass typeOfClass
				instSize: instVars size
				forSuper: newSuper
				ccIndex: 0."Known to be 0 since we uncompacted aClass first"
	fmt == nil ifTrue:[^nil].
	aClass isMeta ifFalse:["Create a new meta class"
		oldMeta _ aClass class.
		newMeta _ oldMeta clone.
		newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class].
		newMeta 
			superclass: newSuperMeta
			methodDictionary: MethodDictionary new
			format: (self computeFormat: oldMeta typeOfClass 
							instSize: oldMeta instVarNames size 
							forSuper: newSuperMeta
							ccIndex: 0);
			setInstVarNames: oldMeta instVarNames;
			organization: oldMeta organization.
		"Recompile the meta class"
		oldMeta hasMethods 
			ifTrue:[newMeta compileAllFrom: oldMeta].
		"Fix up meta class structure"
		oldMeta superclass addObsoleteSubclass: oldMeta.
		(oldMeta superclass subclasses includes: oldMeta) ifTrue:[
			oldMeta superclass removeSubclass: oldMeta.
			newMeta superclass addSubclass: newMeta].
		"And record the change so we can fix global refs later"
		self recordClass: oldMeta replacedBy: newMeta.
	].
	newClass _ newMeta == nil
		ifTrue:[oldClass clone]
		ifFalse:[newMeta adoptInstance: aClass from: oldMeta].
	newClass
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: fmt;
		setInstVarNames: instVars;
		organization: aClass organization.

	"Recompile the new class"
	aClass hasMethods 
		ifTrue:[newClass compileAllFrom: aClass].

	"Export the new class into the environment"
	aClass isMeta ifFalse:[
		"Derefence super sends in the old class"
		self fixSuperSendsFrom: aClass.
		"Export the class"
		aClassIsObsolete ifFalse: [
			[newClass module redefineName: newClass name as: newClass export: true]
				on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]].
		"And use the ST association in the new class"
		self fixSuperSendsTo: newClass].

	"Fix up the class hierarchy"
	aClassIsObsolete ifFalse: [
		(aClass superclass subclasses includes: aClass) ifTrue:[
			aClass superclass removeSubclass: aClass.
			"NOTE: aClass is added as an obsoleteSubclass of its superclass in the method 
			ClassBuilder>>update:to:"
			newClass superclass addSubclass: newClass].
	] ifTrue: [
		"If aClass is obsolete, also newClass is obsolete and therefore it has to be added to the
		obsolete subclasses of its superclass"
		newClass superclass addObsoleteSubclass: newClass
	].
	"And record the change"
	self recordClass: aClass replacedBy: newClass.

	^newClass! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 4/23/2002 15:57'!
update: oldClass to: newClass
	"Convert oldClass and all its instances into newClass. The process is to do a two-way #become of the old vs. new instances, then we map the old instances into a temporary class and then we do a one-way become of the old into the new class. The entire process must be run unpreemptively so that
	a) nobody can create any more instances of oldClass 
	   (which may happen in a process switch), and
	b) in case we don't #primitiveChangeClassTo: nobody can
	   hold on to any of the old instances (which would #become
	   instances of the new class later on).
	The return value of this method is the temporary class we used for converting instances so that the senders still have a handle on the 'old' class."
	| oldInstances someLeft tmp tmpClass |
	[
		someLeft _ false.
		tmpClass _ oldClass clone.
		oldInstances _ newClass updateInstancesFrom: oldClass.
		oldInstances size > 0 ifTrue:[
			"need to map instances"
			self hasPrimitiveChangeClassTo ifTrue:[
				"Much easier, faster, and better that way"
				tmp _ tmpClass basicNew.
				oldInstances do:[:inst| 
					inst primitiveChangeClassTo: tmp.
					inst class == tmpClass ifFalse:[self error:'Ouch']].
			] ifFalse:[
				"Do it the hard way. We need to make sure that there are no
				instances of oldClass anymore. Thus we're #becoming the old
				instances into temp instances and do a big GC afterwards. 
				This is sloooooow (a bulk become + full GC for any class having
				instances) but it's most definitely a way to get the required result."
				tmpClass updateInstances: oldInstances from: oldClass isMeta: oldClass isMeta.
				Smalltalk garbageCollect.
			].
		].
		"It's better to be sure than sorry..."
		someLeft _ oldClass isMeta not and:[oldClass someInstance notNil].
		"NOTE: The above is a sanity check to see if there are any left-over instances from the old class. The reason why we exclude meta classes here is that in some places within the class builder (most noticably right on top of this method) temporary instances of meta classes are created. E.g., when we have a non-meta class the code on top saying:
			tmpClass _ oldClass clone.
		will create a new instance of oldClass' class (e.g., a copy of oldClass). If - for any reason - both a class and its meta class are modified without the garbage collector cleaning up these temporary instances the test above will report left-over instances of the meta class (this is because Metaclass>>updateInstancesFrom: assumes that there is only one instance of the meta class). In a way, the error is correct but fixing the problem short of having Metaclass enumerate the entire object memory is hard. It would mean to make sure that at no place in the class builder (or anywhere else in the system) a class is created without creating the appropriate metaclass. For our example of 'tmpClass := oldClass clone' this would lead to code like:
			oldClass isMeta
				ifTrue:[tmpClass := oldClass clone]
				ifFalse:[tmpClass := oldClass class clone adoptInstance: oldClass from: oldClass class].
		And now you can see why we haven't fixed this problem for real yet ;-) Also, there are some other places in the class builder which need to be fixed in order to get it right."
		someLeft ifFalse:[
			"remap obsolete subclasses in case they have instances"
			oldClass obsoleteSubclasses do: [:obs|
				obs ifNotNil: [
					obs superclass: tmpClass.
					"Since obsolete subclasses are stored outside the class,
					we have to add them manually to tmpClass"
					tmpClass addObsoleteSubclass: obs].
			].

			"Removing of obsolete subclasses is necessary in order to prevent having two 
			entries with obsolete subclasses in the ObsoleteSubclasses dictionary (after 
			we did the becomeForward)"
			oldClass removeAllObsoleteSubclasses.
			oldClass becomeForward: newClass.
			tmpClass isMeta ifFalse:
				[tmpClass class replaceObsoleteInstanceWith: tmpClass]].
	] valueUnpreemptively.
	someLeft
		ifTrue:[self error:'Illegal pointers to obsolete instances found'].
	"If the old (resp. the new) class is obsolete, we have to remove it from the
	obsolete subclasses of tmpClass' superclass. NOTE: If it is not obsolete, it gets removed from
	the set of subclasses in ClassBuilder>>reshapeClass:to:super:"
	oldClass isObsolete ifTrue: [tmpClass superclass removeObsoleteSubclass: oldClass].
	tmpClass superclass addObsoleteSubclass: tmpClass.
	tmpClass obsolete.
	^tmpClass! !


!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'!
checkClassHierarchyConsistency
	"Check the consistency of the class hierarchy. The class hierarchy is consistent if the following
	two logical equivalences hold for classes A and B:
	- B is obsolete and 'B superclass' yields A  <-->  'A obsoleteSubclasses' contains B
	- B is not obsolete and 'B superclass' yields A  <-->  'A subclasses' contains B"
	Utilities informUserDuring:[:bar|
		self checkClassHierarchyConsistency: bar.
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'!
checkClassHierarchyConsistency: informer
	"Check the consistency of the class hierarchy. The class hierarchy is consistent if the following
	two logical equivalences hold for classes A and B:
	- B is obsolete and 'B superclass' yields A  <-->  'A obsoleteSubclasses' contains B
	- B is not obsolete and 'B superclass' yields A  <-->  'A subclasses' contains B"
	| classes |
	Transcript cr; show: 'Start checking the class hierarchy...'.
	Smalltalk garbageCollect.
	classes := Metaclass allInstances.
	classes keysAndValuesDo: [:index :meta |
		informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'.
		meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each].
		self checkClassHierarchyConsistencyFor: meta.
	].
	Transcript show: 'OK'.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'!
checkClassHierarchyConsistencyFor: aClassDescription
	"Check whether aClassDescription has a consistent superclass and consistent regular and obsolete
	subclasses"

	| mySuperclass |
	mySuperclass _ aClassDescription superclass.
	(mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete
			ifTrue: [self error: 'Something wrong!!'].
	mySuperclass ifNil: [^ self].  "Obsolete subclasses of nil cannot be stored"
	(mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete
			ifFalse: [self error: 'Something wrong!!'].

	aClassDescription subclasses do: [:each |
		each isObsolete ifTrue: [self error: 'Something wrong!!'].
		each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!']
	].
	aClassDescription obsoleteSubclasses do: [:each |
		each isObsolete ifFalse: [self error: 'Something wrong!!'].
		each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!']
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:00'!
cleanupAndCheckClassHierarchy
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary.
	Afterwards it checks whether the hierarchy is really consistent."
	Utilities informUserDuring:[:bar|
		self cleanupAndCheckClassHierarchy: bar.
	].
! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'!
cleanupAndCheckClassHierarchy: informer
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary.
	Afterwards it checks whether the hierarchy is really consistent."

	Transcript cr; show: '*** Before cleaning up ***'.
	self countReallyObsoleteClassesAndMetaclasses.
	self cleanupClassHierarchy: informer.
	self checkClassHierarchyConsistency: informer.
	Transcript cr; cr; show: '*** After cleaning up ***'.
	self countReallyObsoleteClassesAndMetaclasses.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'!
cleanupClassHierarchy
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary."
	Utilities informUserDuring:[:bar|
		self cleanupClassHierarchy: bar.
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'!
cleanupClassHierarchy: informer
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary."
	| classes |
	Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'.
	Smalltalk garbageCollect.
	classes := Metaclass allInstances.
	classes keysAndValuesDo: [:index :meta |
		informer value:'Fixing  class hierarchy ', (index * 100 // classes size) printString,'%'.
		"Check classes before metaclasses (because Metaclass>>isObsolete
		checks whether the related class is obsolete)"
		meta allInstances do: [:each | self cleanupClassHierarchyFor: each].
		self cleanupClassHierarchyFor: meta.
	].
	Transcript show: 'DONE'.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/2/2002 11:47'!
cleanupClassHierarchyFor: aClassDescription
	
	| myName mySuperclass |
	mySuperclass _ aClassDescription superclass.
	(self isReallyObsolete: aClassDescription) ifTrue: [
		
		"Remove class >>>from SystemDictionary if it is obsolete"
		myName _ aClassDescription name asString.
		"myName is a String in an IdentityDictionary, take care!!!!"
		Module root deepSubmodulesDo: [:mod |
			(mod definedNames keys asArray 
				detect: [:key | key = myName] ifNone: [nil]) 
					ifNotNilDo: [:key | 
						mod privateDefinedNames removeKey: key.
						mod privateExportedNames removeKey: key ifAbsent: []]].

		"Make class officially obsolete if it is not"
		(aClassDescription name asString beginsWith: 'AnObsolete')
			ifFalse: [aClassDescription obsolete].

		aClassDescription isObsolete 
			ifFalse: [self error: 'Something wrong!!'].

		"Add class to obsoleteSubclasses of its superclass"
		mySuperclass
			ifNil: [self error: 'Obsolete subclasses of nil cannot be stored'].
		(mySuperclass obsoleteSubclasses includes: aClassDescription)
			ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription].
	] ifFalse:[
		"check if superclass has aClassDescription in its obsolete subclasses"
		mySuperclass ifNil:[mySuperclass _ Class]. "nil subclasses"
		mySuperclass removeObsoleteSubclass: aClassDescription.
	].
	"And remove its obsolete subclasses if not actual superclass"
	aClassDescription obsoleteSubclasses do:[:obs|
		obs superclass == aClassDescription ifFalse:[
			aClassDescription removeObsoleteSubclass: obs]].
! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'!
countReallyObsoleteClassesAndMetaclasses
	"Counting really obsolete classes and metaclasses"

	| metaSize classSize |
	Smalltalk garbageCollect.
	metaSize _ self reallyObsoleteMetaclasses size.
	Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString.
	classSize _ self reallyObsoleteClasses size.
	Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr.
	"Metaclasses must correspond to classes!!"
	metaSize ~= classSize 
		ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'!
isReallyObsolete: aClassDescription
	"Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete
	isObsolete does not always return the right answer"

	^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!
reallyObsoleteClasses
	| obsoleteClasses |
	obsoleteClasses _ OrderedCollection new.
	Metaclass allInstances do: [:meta | meta allInstances do: [:each | 
		(self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]].
	^ obsoleteClasses! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!
reallyObsoleteMetaclasses
	^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! !

"Postscript:
Clean up the class hierarchy."
Utilities informUserDuring:[:bar|
bar value:'Repairing the class hierarchy -- please stand by'.
(Object respondsTo: #module) ifTrue:[
	"Necessary cleanup for 3.3alpha"
	Smalltalk allObjectsDo:[:o| ((o isBehavior and: [o isMeta not]) and: [o module == Smalltalk]) 
		ifTrue:[o module: Module smalltalk." Transcript show: o; space"]]].
ClassBuilder cleanupAndCheckClassHierarchy: bar.
].
!