Fixed ClassBuilder >> addSubclass:... with class migration

js/Kernel-Classes.deploy.js

@@ -851,26 +851,36 @@ smalltalk.Metaclass);
 
 smalltalk.addClass('ClassBuilder', smalltalk.Object, [], 'Kernel-Classes');
 smalltalk.addMethod(
-"_addSubclassOf_named_instanceVariableNames_",
+"_addSubclassOf_named_instanceVariableNames_package_",
 smalltalk.method({
-selector: "addSubclassOf:named:instanceVariableNames:",
-fn: function (aClass,aString,aCollection){
+selector: "addSubclassOf:named:instanceVariableNames:package:",
+fn: function (aClass,aString,aCollection,packageName){
 var self=this;
-return smalltalk.withContext(function($ctx1) { 
smalltalk.addClass(aString, aClass, aCollection);
-	    return smalltalk[aString];
-return self}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:",{aClass:aClass,aString:aString,aCollection:aCollection}, smalltalk.ClassBuilder)})}
+return smalltalk.withContext(function($ctx1) { 
var $1,$2,$3;
+$1=_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_(aString);
+if(($receiver = $1) == nil || $receiver == undefined){
+$1;
+} else {
+$2=_st(self)._migrateClassNamed_superclass_instanceVariableNames_package_(aString,aClass,aCollection,packageName);
+return $2;
+};
+$3=_st(self)._basicAddSubclassOf_named_instanceVariableNames_package_(aClass,aString,aCollection,packageName);
+return $3;
+}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})}
 }),
 smalltalk.ClassBuilder);
 
 smalltalk.addMethod(
-"_addSubclassOf_named_instanceVariableNames_package_",
+"_basicAddSubclassOf_named_instanceVariableNames_package_",
 smalltalk.method({
-selector: "addSubclassOf:named:instanceVariableNames:package:",
+selector: "basicAddSubclassOf:named:instanceVariableNames:package:",
 fn: function (aClass,aString,aCollection,packageName){
 var self=this;
-return smalltalk.withContext(function($ctx1) { 
smalltalk.addClass(aString, aClass, aCollection, packageName);
-	    return smalltalk[aString];
-return self}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})}
+return smalltalk.withContext(function($ctx1) { 
+		smalltalk.addClass(aString, aClass, aCollection, packageName);
+		return smalltalk[aString]
+	;
+return self}, function($ctx1) {$ctx1.fill(self,"basicAddSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})}
 }),
 smalltalk.ClassBuilder);
 
@@ -891,6 +901,17 @@ return self}, function($ctx1) {$ctx1.fill(self,"basicClass:instanceVariableNames
 }),
 smalltalk.ClassBuilder);
 
+smalltalk.addMethod(
+"_basicRemoveClass_",
+smalltalk.method({
+selector: "basicRemoveClass:",
+fn: function (aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
smalltalk.removeClass(aClass);
+return self}, function($ctx1) {$ctx1.fill(self,"basicRemoveClass:",{aClass:aClass}, smalltalk.ClassBuilder)})}
+}),
+smalltalk.ClassBuilder);
+
 smalltalk.addMethod(
 "_basicRenameClass_to_",
 smalltalk.method({
@@ -960,6 +981,34 @@ return $1;
 }),
 smalltalk.ClassBuilder);
 
+smalltalk.addMethod(
+"_migrateClassNamed_superclass_instanceVariableNames_package_",
+smalltalk.method({
+selector: "migrateClassNamed:superclass:instanceVariableNames:package:",
+fn: function (aString,aClass,aCollection,packageName){
+var self=this;
+var oldClass,newClass;
+return smalltalk.withContext(function($ctx1) { 
var $1,$2,$3;
+oldClass=_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_(aString);
+$1=self;
+_st($1)._basicRenameClass_to_(oldClass,_st("Old").__comma(aString));
+$2=_st($1)._basicRemoveClass_(oldClass);
+newClass=_st(self)._addSubclassOf_named_instanceVariableNames_package_(aClass,aString,aCollection,packageName);
+_st(self)._setupClass_(newClass);
+_st(newClass)._comment_(_st(oldClass)._comment());
+_st(_st(_st(oldClass)._methodDictionary())._values())._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
return _st(_st((smalltalk.Compiler || Compiler))._new())._install_forClass_category_(_st(each)._source(),newClass,_st(each)._category());
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+_st(_st(_st(_st(oldClass)._class())._methodDictionary())._values())._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
return _st(_st((smalltalk.Compiler || Compiler))._new())._install_forClass_category_(_st(each)._source(),_st(newClass)._class(),_st(each)._category());
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+_st(self)._setupClass_(newClass);
+$3=newClass;
+return $3;
+}, function($ctx1) {$ctx1.fill(self,"migrateClassNamed:superclass:instanceVariableNames:package:",{aString:aString,aClass:aClass,aCollection:aCollection,packageName:packageName,oldClass:oldClass,newClass:newClass}, smalltalk.ClassBuilder)})}
+}),
+smalltalk.ClassBuilder);
+
 smalltalk.addMethod(
 "_renameClass_to_",
 smalltalk.method({

js/Kernel-Classes.js

@@ -1145,34 +1145,44 @@ smalltalk.Metaclass);
 smalltalk.addClass('ClassBuilder', smalltalk.Object, [], 'Kernel-Classes');
 smalltalk.ClassBuilder.comment="ClassBuilder is responsible for compiling new classes or modifying existing classes in the system.\x0a\x0aRather than using ClassBuilder directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`."
 smalltalk.addMethod(
-"_addSubclassOf_named_instanceVariableNames_",
+"_addSubclassOf_named_instanceVariableNames_package_",
 smalltalk.method({
-selector: "addSubclassOf:named:instanceVariableNames:",
+selector: "addSubclassOf:named:instanceVariableNames:package:",
 category: 'private',
-fn: function (aClass,aString,aCollection){
+fn: function (aClass,aString,aCollection,packageName){
 var self=this;
-return smalltalk.withContext(function($ctx1) { 
smalltalk.addClass(aString, aClass, aCollection);
-	    return smalltalk[aString];
-return self}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:",{aClass:aClass,aString:aString,aCollection:aCollection}, smalltalk.ClassBuilder)})},
-args: ["aClass", "aString", "aCollection"],
-source: "addSubclassOf: aClass named: aString instanceVariableNames: aCollection\x0a\x09<smalltalk.addClass(aString, aClass, aCollection);\x0a\x09    return smalltalk[aString]>",
-messageSends: [],
-referencedClasses: []
+return smalltalk.withContext(function($ctx1) { 
var $1,$2,$3;
+$1=_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_(aString);
+if(($receiver = $1) == nil || $receiver == undefined){
+$1;
+} else {
+$2=_st(self)._migrateClassNamed_superclass_instanceVariableNames_package_(aString,aClass,aCollection,packageName);
+return $2;
+};
+$3=_st(self)._basicAddSubclassOf_named_instanceVariableNames_package_(aClass,aString,aCollection,packageName);
+return $3;
+}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})},
+args: ["aClass", "aString", "aCollection", "packageName"],
+source: "addSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName\x0a\x09\x0a    (Smalltalk current at: aString) ifNotNil: [ \x0a    \x09^ self \x0a        \x09migrateClassNamed: aString \x0a            superclass: aClass \x0a            instanceVariableNames: aCollection \x0a            package: packageName ].\x0a\x0a\x09^ self \x0a    \x09basicAddSubclassOf: aClass \x0a        named: aString \x0a        instanceVariableNames: aCollection \x0a        package: packageName",
+messageSends: ["ifNotNil:", "migrateClassNamed:superclass:instanceVariableNames:package:", "at:", "current", "basicAddSubclassOf:named:instanceVariableNames:package:"],
+referencedClasses: ["Smalltalk"]
 }),
 smalltalk.ClassBuilder);
 
 smalltalk.addMethod(
-"_addSubclassOf_named_instanceVariableNames_package_",
+"_basicAddSubclassOf_named_instanceVariableNames_package_",
 smalltalk.method({
-selector: "addSubclassOf:named:instanceVariableNames:package:",
+selector: "basicAddSubclassOf:named:instanceVariableNames:package:",
 category: 'private',
 fn: function (aClass,aString,aCollection,packageName){
 var self=this;
-return smalltalk.withContext(function($ctx1) { 
smalltalk.addClass(aString, aClass, aCollection, packageName);
-	    return smalltalk[aString];
-return self}, function($ctx1) {$ctx1.fill(self,"addSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})},
+return smalltalk.withContext(function($ctx1) { 
+		smalltalk.addClass(aString, aClass, aCollection, packageName);
+		return smalltalk[aString]
+	;
+return self}, function($ctx1) {$ctx1.fill(self,"basicAddSubclassOf:named:instanceVariableNames:package:",{aClass:aClass,aString:aString,aCollection:aCollection,packageName:packageName}, smalltalk.ClassBuilder)})},
 args: ["aClass", "aString", "aCollection", "packageName"],
-source: "addSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName\x0a\x09<smalltalk.addClass(aString, aClass, aCollection, packageName);\x0a\x09    return smalltalk[aString]>",
+source: "basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName\x0a\x09<\x0a\x09\x09smalltalk.addClass(aString, aClass, aCollection, packageName);\x0a\x09\x09return smalltalk[aString]\x0a\x09>",
 messageSends: [],
 referencedClasses: []
 }),
@@ -1194,12 +1204,28 @@ _st(aClass)._basicAt_put_("iVarNames",_st(self)._instanceVariableNamesFor_(aStri
 _st(self)._setupClass_(aClass);
 return self}, function($ctx1) {$ctx1.fill(self,"basicClass:instanceVariableNames:",{aClass:aClass,aString:aString}, smalltalk.ClassBuilder)})},
 args: ["aClass", "aString"],
-source: "basicClass: aClass instanceVariableNames: aString\x0a\x09aClass isMetaclass ifFalse: [self error: aClass name, ' is not a metaclass'].\x0a\x09aClass basicAt: 'iVarNames' put: (self instanceVariableNamesFor: aString).\x0a    \x0a\x09self setupClass: aClass",
+source: "basicClass: aClass instanceVariableNames: aString\x0a\x0a\x09aClass isMetaclass ifFalse: [self error: aClass name, ' is not a metaclass'].\x0a\x09aClass basicAt: 'iVarNames' put: (self instanceVariableNamesFor: aString).\x0a    \x0a\x09self setupClass: aClass",
 messageSends: ["ifFalse:", "error:", ",", "name", "isMetaclass", "basicAt:put:", "instanceVariableNamesFor:", "setupClass:"],
 referencedClasses: []
 }),
 smalltalk.ClassBuilder);
 
+smalltalk.addMethod(
+"_basicRemoveClass_",
+smalltalk.method({
+selector: "basicRemoveClass:",
+category: 'private',
+fn: function (aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
smalltalk.removeClass(aClass);
+return self}, function($ctx1) {$ctx1.fill(self,"basicRemoveClass:",{aClass:aClass}, smalltalk.ClassBuilder)})},
+args: ["aClass"],
+source: "basicRemoveClass: aClass\x0a\x09<smalltalk.removeClass(aClass)>",
+messageSends: [],
+referencedClasses: []
+}),
+smalltalk.ClassBuilder);
+
 smalltalk.addMethod(
 "_basicRenameClass_to_",
 smalltalk.method({
@@ -1283,12 +1309,45 @@ return smalltalk.withContext(function($ctx2) {
return _st(each)._isEmpty();
 return $1;
 }, function($ctx1) {$ctx1.fill(self,"instanceVariableNamesFor:",{aString:aString}, smalltalk.ClassBuilder)})},
 args: ["aString"],
-source: "instanceVariableNamesFor: aString\x0a\x09^(aString tokenize: ' ') reject: [:each | each isEmpty]",
+source: "instanceVariableNamesFor: aString\x0a\x09^(aString tokenize: ' ') reject: [ :each | each isEmpty ]",
 messageSends: ["reject:", "isEmpty", "tokenize:"],
 referencedClasses: []
 }),
 smalltalk.ClassBuilder);
 
+smalltalk.addMethod(
+"_migrateClassNamed_superclass_instanceVariableNames_package_",
+smalltalk.method({
+selector: "migrateClassNamed:superclass:instanceVariableNames:package:",
+category: 'private',
+fn: function (aString,aClass,aCollection,packageName){
+var self=this;
+var oldClass,newClass;
+return smalltalk.withContext(function($ctx1) { 
var $1,$2,$3;
+oldClass=_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_(aString);
+$1=self;
+_st($1)._basicRenameClass_to_(oldClass,_st("Old").__comma(aString));
+$2=_st($1)._basicRemoveClass_(oldClass);
+newClass=_st(self)._addSubclassOf_named_instanceVariableNames_package_(aClass,aString,aCollection,packageName);
+_st(self)._setupClass_(newClass);
+_st(newClass)._comment_(_st(oldClass)._comment());
+_st(_st(_st(oldClass)._methodDictionary())._values())._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
return _st(_st((smalltalk.Compiler || Compiler))._new())._install_forClass_category_(_st(each)._source(),newClass,_st(each)._category());
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+_st(_st(_st(_st(oldClass)._class())._methodDictionary())._values())._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
return _st(_st((smalltalk.Compiler || Compiler))._new())._install_forClass_category_(_st(each)._source(),_st(newClass)._class(),_st(each)._category());
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+_st(self)._setupClass_(newClass);
+$3=newClass;
+return $3;
+}, function($ctx1) {$ctx1.fill(self,"migrateClassNamed:superclass:instanceVariableNames:package:",{aString:aString,aClass:aClass,aCollection:aCollection,packageName:packageName,oldClass:oldClass,newClass:newClass}, smalltalk.ClassBuilder)})},
+args: ["aString", "aClass", "aCollection", "packageName"],
+source: "migrateClassNamed: aString superclass: aClass instanceVariableNames: aCollection package: packageName\x0a\x09| oldClass newClass |\x0a    \x0a    oldClass := Smalltalk current at: aString.\x0a    \x0a    \x22Rename the class for existing instances\x22\x0a\x09self \x0a    \x09basicRenameClass: oldClass to: 'Old', aString;\x0a        basicRemoveClass: oldClass.\x0a        \x0a    newClass := self \x0a\x09\x09addSubclassOf: aClass\x0a\x09\x09named: aString \x0a\x09\x09instanceVariableNames: aCollection\x0a\x09\x09package: packageName.\x0a\x0a\x09self setupClass: newClass.\x0a\x0a\x09newClass comment: oldClass comment.\x0a\x0a\x09oldClass methodDictionary values do: [:each |\x0a\x09\x09Compiler new install: each source forClass: newClass category: each category].\x0a\x0a\x09oldClass class methodDictionary values do: [:each |\x0a\x09\x09Compiler new install: each source forClass: newClass class category: each category].\x0a\x0a\x09self setupClass: newClass.\x0a    \x0a\x09^newClass",
+messageSends: ["at:", "current", "basicRenameClass:to:", ",", "basicRemoveClass:", "addSubclassOf:named:instanceVariableNames:package:", "setupClass:", "comment:", "comment", "do:", "install:forClass:category:", "source", "category", "new", "values", "methodDictionary", "class"],
+referencedClasses: ["Smalltalk", "Compiler"]
+}),
+smalltalk.ClassBuilder);
+
 smalltalk.addMethod(
 "_renameClass_to_",
 smalltalk.method({

js/Kernel-Tests.deploy.js

@@ -535,6 +535,30 @@ return self}, function($ctx1) {$ctx1.fill(self,"testClassCopy",{}, smalltalk.Cla
 }),
 smalltalk.ClassBuilderTest);
 
+smalltalk.addMethod(
+"_testClassMigration",
+smalltalk.method({
+selector: "testClassMigration",
+fn: function (){
+var self=this;
+var instance,oldClass;
+return smalltalk.withContext(function($ctx1) { 
oldClass=_st(self["@builder"])._copyClass_named_((smalltalk.ObjectMock || ObjectMock),"ObjectMock2");
+instance=_st(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("ObjectMock2"))._new();
+_st((smalltalk.ObjectMock || ObjectMock))._subclass_instanceVariableNames_package_(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("ObjectMock2"),"","Kernel-Tests");
+_st(self)._deny_(_st(oldClass).__eq_eq((smalltalk.ObjectMock2 || ObjectMock2)));
+_st(self)._assert_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._superclass()).__eq_eq((smalltalk.ObjectMock || ObjectMock)));
+_st(self)._assert_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._instanceVariableNames())._isEmpty());
+_st(self)._assert_equals_(_st((smalltalk.ObjectMock2 || ObjectMock2))._selectors(),_st(oldClass)._selectors());
+_st(self)._assert_equals_(_st((smalltalk.ObjectMock2 || ObjectMock2))._comment(),_st(oldClass)._comment());
+_st(self)._assert_equals_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._package())._name(),"Kernel-Tests");
+_st(self)._deny_(_st(_st(instance)._class()).__eq_eq((smalltalk.ObjectMock2 || ObjectMock2)));
+_st(self)._assert_equals_(_st(_st(instance)._class())._name(),"OldObjectMock2");
+_st(self)._assert_(_st(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("OldObjectMock2"))._isNil());
+_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._removeClass_((smalltalk.ObjectMock2 || ObjectMock2));
+return self}, function($ctx1) {$ctx1.fill(self,"testClassMigration",{instance:instance,oldClass:oldClass}, smalltalk.ClassBuilderTest)})}
+}),
+smalltalk.ClassBuilderTest);
+
 smalltalk.addMethod(
 "_testInstanceVariableNames",
 smalltalk.method({

js/Kernel-Tests.js

@@ -640,6 +640,35 @@ referencedClasses: ["ObjectMock"]
 }),
 smalltalk.ClassBuilderTest);
 
+smalltalk.addMethod(
+"_testClassMigration",
+smalltalk.method({
+selector: "testClassMigration",
+category: 'running',
+fn: function (){
+var self=this;
+var instance,oldClass;
+return smalltalk.withContext(function($ctx1) { 
oldClass=_st(self["@builder"])._copyClass_named_((smalltalk.ObjectMock || ObjectMock),"ObjectMock2");
+instance=_st(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("ObjectMock2"))._new();
+_st((smalltalk.ObjectMock || ObjectMock))._subclass_instanceVariableNames_package_(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("ObjectMock2"),"","Kernel-Tests");
+_st(self)._deny_(_st(oldClass).__eq_eq((smalltalk.ObjectMock2 || ObjectMock2)));
+_st(self)._assert_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._superclass()).__eq_eq((smalltalk.ObjectMock || ObjectMock)));
+_st(self)._assert_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._instanceVariableNames())._isEmpty());
+_st(self)._assert_equals_(_st((smalltalk.ObjectMock2 || ObjectMock2))._selectors(),_st(oldClass)._selectors());
+_st(self)._assert_equals_(_st((smalltalk.ObjectMock2 || ObjectMock2))._comment(),_st(oldClass)._comment());
+_st(self)._assert_equals_(_st(_st((smalltalk.ObjectMock2 || ObjectMock2))._package())._name(),"Kernel-Tests");
+_st(self)._deny_(_st(_st(instance)._class()).__eq_eq((smalltalk.ObjectMock2 || ObjectMock2)));
+_st(self)._assert_equals_(_st(_st(instance)._class())._name(),"OldObjectMock2");
+_st(self)._assert_(_st(_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._at_("OldObjectMock2"))._isNil());
+_st(_st((smalltalk.Smalltalk || Smalltalk))._current())._removeClass_((smalltalk.ObjectMock2 || ObjectMock2));
+return self}, function($ctx1) {$ctx1.fill(self,"testClassMigration",{instance:instance,oldClass:oldClass}, smalltalk.ClassBuilderTest)})},
+args: [],
+source: "testClassMigration\x0a\x09| instance oldClass |\x0a    \x0a    oldClass := builder copyClass: ObjectMock named: 'ObjectMock2'.\x0a    instance := (Smalltalk  current at: 'ObjectMock2') new.\x0a    \x0a    \x22Change the superclass of ObjectMock2\x22\x0a    ObjectMock subclass: (Smalltalk current at: 'ObjectMock2')\x0a    \x09instanceVariableNames: ''\x0a        package: 'Kernel-Tests'.\x0a    \x0a    self deny: oldClass == ObjectMock2.\x0a    \x0a\x09self assert: ObjectMock2 superclass == ObjectMock.\x0a\x09self assert: ObjectMock2 instanceVariableNames isEmpty.\x0a\x09self assert: ObjectMock2 selectors equals: oldClass selectors.\x0a    self assert: ObjectMock2 comment equals: oldClass comment.\x0a    self assert: ObjectMock2 package name equals: 'Kernel-Tests'.\x0a    \x0a\x09self deny: instance class == ObjectMock2.\x0a    self assert: instance class name equals: 'OldObjectMock2'.\x0a    \x0a    self assert: (Smalltalk current at: 'OldObjectMock2') isNil.\x0a    \x0a    Smalltalk current removeClass: ObjectMock2",
+messageSends: ["copyClass:named:", "new", "at:", "current", "subclass:instanceVariableNames:package:", "deny:", "==", "assert:", "superclass", "isEmpty", "instanceVariableNames", "assert:equals:", "selectors", "comment", "name", "package", "class", "isNil", "removeClass:"],
+referencedClasses: ["ObjectMock", "Smalltalk", "ObjectMock2"]
+}),
+smalltalk.ClassBuilderTest);
+
 smalltalk.addMethod(
 "_testInstanceVariableNames",
 smalltalk.method({
@@ -2848,6 +2877,7 @@ smalltalk.NumberTest);
 
 
 smalltalk.addClass('ObjectMock', smalltalk.Object, ['foo', 'bar'], 'Kernel-Tests');
+smalltalk.ObjectMock.comment="ObjectMock is there only to perform tests on classes."
 smalltalk.addMethod(
 "_foo",
 smalltalk.method({

st/Kernel-Classes.st

@@ -440,23 +440,41 @@ superclass: aClass subclass: aString instanceVariableNames: aString2 package: aS
 
 !ClassBuilder methodsFor: 'private'!
 
-addSubclassOf: aClass named: aString instanceVariableNames: aCollection
-	<smalltalk.addClass(aString, aClass, aCollection);
-	    return smalltalk[aString]>
+addSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
+	
+    (Smalltalk current at: aString) ifNotNil: [ 
+    	^ self 
+        	migrateClassNamed: aString 
+            superclass: aClass 
+            instanceVariableNames: aCollection 
+            package: packageName ].
+
+	^ self 
+    	basicAddSubclassOf: aClass 
+        named: aString 
+        instanceVariableNames: aCollection 
+        package: packageName
 !
 
-addSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
-	<smalltalk.addClass(aString, aClass, aCollection, packageName);
-	    return smalltalk[aString]>
+basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
+	<
+		smalltalk.addClass(aString, aClass, aCollection, packageName);
+		return smalltalk[aString]
+	>
 !
 
 basicClass: aClass instanceVariableNames: aString
+
 	aClass isMetaclass ifFalse: [self error: aClass name, ' is not a metaclass'].
 	aClass basicAt: 'iVarNames' put: (self instanceVariableNamesFor: aString).
     
 	self setupClass: aClass
 !
 
+basicRemoveClass: aClass
+	<smalltalk.removeClass(aClass)>
+!
+
 basicRenameClass: aClass to: aString
 	<
 		smalltalk[aString] = aClass;
@@ -487,7 +505,38 @@ copyClass: aClass named: aString
 !
 
 instanceVariableNamesFor: aString
-	^(aString tokenize: ' ') reject: [:each | each isEmpty]
+	^(aString tokenize: ' ') reject: [ :each | each isEmpty ]
+!
+
+migrateClassNamed: aString superclass: aClass instanceVariableNames: aCollection package: packageName
+	| oldClass newClass |
+    
+    oldClass := Smalltalk current at: aString.
+    
+    "Rename the class for existing instances"
+	self 
+    	basicRenameClass: oldClass to: 'Old', aString;
+        basicRemoveClass: oldClass.
+        
+    newClass := self 
+		addSubclassOf: aClass
+		named: aString 
+		instanceVariableNames: aCollection
+		package: packageName.
+
+	self setupClass: newClass.
+
+	newClass comment: oldClass comment.
+
+	oldClass methodDictionary values do: [:each |
+		Compiler new install: each source forClass: newClass category: each category].
+
+	oldClass class methodDictionary values do: [:each |
+		Compiler new install: each source forClass: newClass class category: each category].
+
+	self setupClass: newClass.
+    
+	^newClass
 ! !
 
 Object subclass: #ClassCategoryReader

st/Kernel-Tests.st

@@ -206,6 +206,33 @@ testClassCopy
 	self assert: theClass methodDictionary keys equals: ObjectMock methodDictionary keys
 !
 
+testClassMigration
+	| instance oldClass |
+    
+    oldClass := builder copyClass: ObjectMock named: 'ObjectMock2'.
+    instance := (Smalltalk  current at: 'ObjectMock2') new.
+    
+    "Change the superclass of ObjectMock2"
+    ObjectMock subclass: (Smalltalk current at: 'ObjectMock2')
+    	instanceVariableNames: ''
+        package: 'Kernel-Tests'.
+    
+    self deny: oldClass == ObjectMock2.
+    
+	self assert: ObjectMock2 superclass == ObjectMock.
+	self assert: ObjectMock2 instanceVariableNames isEmpty.
+	self assert: ObjectMock2 selectors equals: oldClass selectors.
+    self assert: ObjectMock2 comment equals: oldClass comment.
+    self assert: ObjectMock2 package name equals: 'Kernel-Tests'.
+    
+	self deny: instance class == ObjectMock2.
+    self assert: instance class name equals: 'OldObjectMock2'.
+    
+    self assert: (Smalltalk current at: 'OldObjectMock2') isNil.
+    
+    Smalltalk current removeClass: ObjectMock2
+!
+
 testInstanceVariableNames
 	self assert: (builder instanceVariableNamesFor: '  hello   world   ') equals: #('hello' 'world')
 ! !
@@ -1104,6 +1131,8 @@ testTruncated
 Object subclass: #ObjectMock
 	instanceVariableNames: 'foo bar'
 	package: 'Kernel-Tests'!
+!ObjectMock commentStamp!
+ObjectMock is there only to perform tests on classes.!
 
 !ObjectMock methodsFor: 'not yet classified'!