Kernel improvements for Helios

js/Kernel-Announcements.deploy.js

@@ -312,6 +312,33 @@ smalltalk.MethodModified);
 
 
 
+smalltalk.addClass('MethodMoved', smalltalk.MethodAnnouncement, ['oldProtocol'], 'Kernel-Announcements');
+smalltalk.addMethod(
+smalltalk.method({
+selector: "oldProtocol",
+fn: function (){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+var $1;
+$1=self["@oldProtocol"];
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"oldProtocol",{},smalltalk.MethodMoved)})},
+messageSends: []}),
+smalltalk.MethodMoved);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "oldProtocol:",
+fn: function (aString){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+self["@oldProtocol"]=aString;
+return self}, function($ctx1) {$ctx1.fill(self,"oldProtocol:",{aString:aString},smalltalk.MethodMoved)})},
+messageSends: []}),
+smalltalk.MethodMoved);
+
+
+
 smalltalk.addClass('MethodRemoved', smalltalk.MethodAnnouncement, [], 'Kernel-Announcements');
 
 

js/Kernel-Announcements.js

@@ -426,6 +426,43 @@ smalltalk.MethodModified);
 
 
 
+smalltalk.addClass('MethodMoved', smalltalk.MethodAnnouncement, ['oldProtocol'], 'Kernel-Announcements');
+smalltalk.addMethod(
+smalltalk.method({
+selector: "oldProtocol",
+category: 'accessing',
+fn: function (){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+var $1;
+$1=self["@oldProtocol"];
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"oldProtocol",{},smalltalk.MethodMoved)})},
+args: [],
+source: "oldProtocol\x0a\x09^ oldProtocol",
+messageSends: [],
+referencedClasses: []
+}),
+smalltalk.MethodMoved);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "oldProtocol:",
+category: 'accessing',
+fn: function (aString){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+self["@oldProtocol"]=aString;
+return self}, function($ctx1) {$ctx1.fill(self,"oldProtocol:",{aString:aString},smalltalk.MethodMoved)})},
+args: ["aString"],
+source: "oldProtocol: aString\x0a\x09oldProtocol := aString",
+messageSends: [],
+referencedClasses: []
+}),
+smalltalk.MethodMoved);
+
+
+
 smalltalk.addClass('MethodRemoved', smalltalk.MethodAnnouncement, [], 'Kernel-Announcements');
 
 

js/Kernel-Classes.deploy.js

@@ -263,8 +263,10 @@ selector: "compile:",
 fn: function (aString){
 var self=this;
 return smalltalk.withContext(function($ctx1) { 
-_st(self)._compile_category_(aString,"");
-return self}, function($ctx1) {$ctx1.fill(self,"compile:",{aString:aString},smalltalk.Behavior)})},
+var $1;
+$1=_st(self)._compile_category_(aString,"");
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"compile:",{aString:aString},smalltalk.Behavior)})},
 messageSends: ["compile:category:"]}),
 smalltalk.Behavior);
 
@@ -275,8 +277,10 @@ fn: function (aString,anotherString){
 var self=this;
 function $Compiler(){return smalltalk.Compiler||(typeof Compiler=="undefined"?nil:Compiler)}
 return smalltalk.withContext(function($ctx1) { 
-_st(_st($Compiler())._new())._install_forClass_category_(aString,self,anotherString);
-return self}, function($ctx1) {$ctx1.fill(self,"compile:category:",{aString:aString,anotherString:anotherString},smalltalk.Behavior)})},
+var $1;
+$1=_st(_st($Compiler())._new())._install_forClass_category_(aString,self,anotherString);
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"compile:category:",{aString:aString,anotherString:anotherString},smalltalk.Behavior)})},
 messageSends: ["install:forClass:category:", "new"]}),
 smalltalk.Behavior);
 
@@ -1097,14 +1101,20 @@ selector: "copyClass:named:",
 fn: function (aClass,aString){
 var self=this;
 var newClass;
+function $ClassAdded(){return smalltalk.ClassAdded||(typeof ClassAdded=="undefined"?nil:ClassAdded)}
+function $SystemAnnouncer(){return smalltalk.SystemAnnouncer||(typeof SystemAnnouncer=="undefined"?nil:SystemAnnouncer)}
 return smalltalk.withContext(function($ctx1) { 
-var $1;
+var $1,$2,$3;
 newClass=_st(self)._addSubclassOf_named_instanceVariableNames_package_(_st(aClass)._superclass(),aString,_st(aClass)._instanceVariableNames(),_st(_st(aClass)._package())._name());
 _st(self)._copyClass_to_(aClass,newClass);
-$1=newClass;
-return $1;
+$1=_st($ClassAdded())._new();
+_st($1)._theClass_(newClass);
+$2=_st($1)._yourself();
+_st(_st($SystemAnnouncer())._current())._announce_($2);
+$3=newClass;
+return $3;
 }, function($ctx1) {$ctx1.fill(self,"copyClass:named:",{aClass:aClass,aString:aString,newClass:newClass},smalltalk.ClassBuilder)})},
-messageSends: ["addSubclassOf:named:instanceVariableNames:package:", "superclass", "instanceVariableNames", "name", "package", "copyClass:to:"]}),
+messageSends: ["addSubclassOf:named:instanceVariableNames:package:", "superclass", "instanceVariableNames", "name", "package", "copyClass:to:", "announce:", "theClass:", "new", "yourself", "current"]}),
 smalltalk.ClassBuilder);
 
 smalltalk.addMethod(

js/Kernel-Classes.js

@@ -335,10 +335,12 @@ category: 'compiling',
 fn: function (aString){
 var self=this;
 return smalltalk.withContext(function($ctx1) { 
-_st(self)._compile_category_(aString,"");
-return self}, function($ctx1) {$ctx1.fill(self,"compile:",{aString:aString},smalltalk.Behavior)})},
+var $1;
+$1=_st(self)._compile_category_(aString,"");
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"compile:",{aString:aString},smalltalk.Behavior)})},
 args: ["aString"],
-source: "compile: aString\x0a\x09self compile: aString category: ''",
+source: "compile: aString\x0a\x09^ self compile: aString category: ''",
 messageSends: ["compile:category:"],
 referencedClasses: []
 }),
@@ -352,10 +354,12 @@ fn: function (aString,anotherString){
 var self=this;
 function $Compiler(){return smalltalk.Compiler||(typeof Compiler=="undefined"?nil:Compiler)}
 return smalltalk.withContext(function($ctx1) { 
-_st(_st($Compiler())._new())._install_forClass_category_(aString,self,anotherString);
-return self}, function($ctx1) {$ctx1.fill(self,"compile:category:",{aString:aString,anotherString:anotherString},smalltalk.Behavior)})},
+var $1;
+$1=_st(_st($Compiler())._new())._install_forClass_category_(aString,self,anotherString);
+return $1;
+}, function($ctx1) {$ctx1.fill(self,"compile:category:",{aString:aString,anotherString:anotherString},smalltalk.Behavior)})},
 args: ["aString", "anotherString"],
-source: "compile: aString category: anotherString\x0a\x09Compiler new\x0a\x09\x09install: aString\x0a\x09\x09forClass: self\x0a\x09\x09category: anotherString",
+source: "compile: aString category: anotherString\x0a\x09^ Compiler new\x0a\x09\x09install: aString\x0a\x09\x09forClass: self\x0a\x09\x09category: anotherString",
 messageSends: ["install:forClass:category:", "new"],
 referencedClasses: ["Compiler"]
 }),
@@ -1447,17 +1451,23 @@ category: 'copying',
 fn: function (aClass,aString){
 var self=this;
 var newClass;
+function $ClassAdded(){return smalltalk.ClassAdded||(typeof ClassAdded=="undefined"?nil:ClassAdded)}
+function $SystemAnnouncer(){return smalltalk.SystemAnnouncer||(typeof SystemAnnouncer=="undefined"?nil:SystemAnnouncer)}
 return smalltalk.withContext(function($ctx1) { 
-var $1;
+var $1,$2,$3;
 newClass=_st(self)._addSubclassOf_named_instanceVariableNames_package_(_st(aClass)._superclass(),aString,_st(aClass)._instanceVariableNames(),_st(_st(aClass)._package())._name());
 _st(self)._copyClass_to_(aClass,newClass);
-$1=newClass;
-return $1;
+$1=_st($ClassAdded())._new();
+_st($1)._theClass_(newClass);
+$2=_st($1)._yourself();
+_st(_st($SystemAnnouncer())._current())._announce_($2);
+$3=newClass;
+return $3;
 }, function($ctx1) {$ctx1.fill(self,"copyClass:named:",{aClass:aClass,aString:aString,newClass:newClass},smalltalk.ClassBuilder)})},
 args: ["aClass", "aString"],
-source: "copyClass: aClass named: aString\x0a\x09| newClass |\x0a\x0a\x09newClass := self\x0a\x09\x09addSubclassOf: aClass superclass\x0a\x09\x09named: aString\x0a\x09\x09instanceVariableNames: aClass instanceVariableNames\x0a\x09\x09package: aClass package name.\x0a\x0a\x09self copyClass: aClass to: newClass.\x0a\x09\x0a\x09^newClass",
-messageSends: ["addSubclassOf:named:instanceVariableNames:package:", "superclass", "instanceVariableNames", "name", "package", "copyClass:to:"],
-referencedClasses: []
+source: "copyClass: aClass named: aString\x0a\x09| newClass |\x0a\x0a\x09newClass := self\x0a\x09\x09addSubclassOf: aClass superclass\x0a\x09\x09named: aString\x0a\x09\x09instanceVariableNames: aClass instanceVariableNames\x0a\x09\x09package: aClass package name.\x0a\x0a\x09self copyClass: aClass to: newClass.\x0a\x09\x0a\x09SystemAnnouncer current\x0a\x09\x09announce: (ClassAdded new\x0a\x09\x09\x09theClass: newClass;\x0a\x09\x09\x09yourself).\x0a\x09\x0a\x09^newClass",
+messageSends: ["addSubclassOf:named:instanceVariableNames:package:", "superclass", "instanceVariableNames", "name", "package", "copyClass:to:", "announce:", "theClass:", "new", "yourself", "current"],
+referencedClasses: ["ClassAdded", "SystemAnnouncer"]
 }),
 smalltalk.ClassBuilder);
 

js/Kernel-Methods.deploy.js

@@ -335,26 +335,33 @@ smalltalk.method({
 selector: "category:",
 fn: function (aString){
 var self=this;
-var oldCategory;
+var oldProtocol;
+function $MethodMoved(){return smalltalk.MethodMoved||(typeof MethodMoved=="undefined"?nil:MethodMoved)}
+function $SystemOrganizer(){return smalltalk.SystemOrganizer||(typeof SystemOrganizer=="undefined"?nil:SystemOrganizer)}
 return smalltalk.withContext(function($ctx1) { 
-var $1;
-oldCategory=_st(self)._category();
+var $1,$2,$3;
+oldProtocol=_st(self)._protocol();
 _st(self)._basicAt_put_("category",aString);
-$1=_st(self)._methodClass();
-if(($receiver = $1) == nil || $receiver == undefined){
-$1;
+$1=_st($MethodMoved())._new();
+_st($1)._method_(self);
+_st($1)._oldProtocol_(oldProtocol);
+$2=_st($1)._yourself();
+_st(_st($SystemOrganizer())._current())._announce_($2);
+$3=_st(self)._methodClass();
+if(($receiver = $3) == nil || $receiver == undefined){
+$3;
 } else {
 _st(_st(_st(self)._methodClass())._organization())._addElement_(aString);
 _st(_st(_st(_st(self)._methodClass())._methods())._select_((function(each){
 return smalltalk.withContext(function($ctx2) {
-return _st(_st(each)._category()).__eq(oldCategory);
+return _st(_st(each)._protocol()).__eq(oldProtocol);
 }, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._ifEmpty_((function(){
 return smalltalk.withContext(function($ctx2) {
-return _st(_st(_st(self)._methodClass())._organization())._removeElement_(oldCategory);
+return _st(_st(_st(self)._methodClass())._organization())._removeElement_(oldProtocol);
 }, function($ctx2) {$ctx2.fillBlock({},$ctx1)})}));
 };
-return self}, function($ctx1) {$ctx1.fill(self,"category:",{aString:aString,oldCategory:oldCategory},smalltalk.CompiledMethod)})},
-messageSends: ["category", "basicAt:put:", "ifNotNil:", "addElement:", "organization", "methodClass", "ifEmpty:", "removeElement:", "select:", "=", "methods"]}),
+return self}, function($ctx1) {$ctx1.fill(self,"category:",{aString:aString,oldProtocol:oldProtocol},smalltalk.CompiledMethod)})},
+messageSends: ["protocol", "basicAt:put:", "announce:", "method:", "new", "oldProtocol:", "yourself", "current", "ifNotNil:", "addElement:", "organization", "methodClass", "ifEmpty:", "removeElement:", "select:", "=", "methods"]}),
 smalltalk.CompiledMethod);
 
 smalltalk.addMethod(

js/Kernel-Methods.js

@@ -468,29 +468,36 @@ selector: "category:",
 category: 'accessing',
 fn: function (aString){
 var self=this;
-var oldCategory;
+var oldProtocol;
+function $MethodMoved(){return smalltalk.MethodMoved||(typeof MethodMoved=="undefined"?nil:MethodMoved)}
+function $SystemAnnouncer(){return smalltalk.SystemAnnouncer||(typeof SystemAnnouncer=="undefined"?nil:SystemAnnouncer)}
 return smalltalk.withContext(function($ctx1) { 
-var $1;
-oldCategory=_st(self)._category();
+var $1,$2,$3;
+oldProtocol=_st(self)._protocol();
 _st(self)._basicAt_put_("category",aString);
-$1=_st(self)._methodClass();
-if(($receiver = $1) == nil || $receiver == undefined){
-$1;
+$1=_st($MethodMoved())._new();
+_st($1)._method_(self);
+_st($1)._oldProtocol_(oldProtocol);
+$2=_st($1)._yourself();
+_st(_st($SystemAnnouncer())._current())._announce_($2);
+$3=_st(self)._methodClass();
+if(($receiver = $3) == nil || $receiver == undefined){
+$3;
 } else {
 _st(_st(_st(self)._methodClass())._organization())._addElement_(aString);
 _st(_st(_st(_st(self)._methodClass())._methods())._select_((function(each){
 return smalltalk.withContext(function($ctx2) {
-return _st(_st(each)._category()).__eq(oldCategory);
+return _st(_st(each)._protocol()).__eq(oldProtocol);
 }, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._ifEmpty_((function(){
 return smalltalk.withContext(function($ctx2) {
-return _st(_st(_st(self)._methodClass())._organization())._removeElement_(oldCategory);
+return _st(_st(_st(self)._methodClass())._organization())._removeElement_(oldProtocol);
 }, function($ctx2) {$ctx2.fillBlock({},$ctx1)})}));
 };
-return self}, function($ctx1) {$ctx1.fill(self,"category:",{aString:aString,oldCategory:oldCategory},smalltalk.CompiledMethod)})},
+return self}, function($ctx1) {$ctx1.fill(self,"category:",{aString:aString,oldProtocol:oldProtocol},smalltalk.CompiledMethod)})},
 args: ["aString"],
-source: "category: aString\x0a\x09| oldCategory |\x0a\x09oldCategory := self category.\x0a\x09self basicAt: 'category' put: aString.\x0a\x09\x0a\x09self methodClass ifNotNil: [\x0a\x09\x09self methodClass organization addElement: aString.\x0a\x09\x0a\x09\x09(self methodClass methods\x0a\x09\x09\x09select: [ :each | each category = oldCategory ])\x0a\x09\x09\x09ifEmpty: [ self methodClass organization removeElement: oldCategory ] ]",
-messageSends: ["category", "basicAt:put:", "ifNotNil:", "addElement:", "organization", "methodClass", "ifEmpty:", "removeElement:", "select:", "=", "methods"],
-referencedClasses: []
+source: "category: aString\x0a\x09| oldProtocol |\x0a\x09oldProtocol := self protocol.\x0a\x09self basicAt: 'category' put: aString.\x0a\x0a\x09SystemAnnouncer current announce: (MethodMoved new\x0a\x09\x09method: self;\x0a\x09\x09oldProtocol: oldProtocol;\x0a\x09\x09yourself).\x0a\x0a\x09self methodClass ifNotNil: [\x0a\x09\x09self methodClass organization addElement: aString.\x0a\x09\x0a\x09\x09(self methodClass methods\x0a\x09\x09\x09select: [ :each | each protocol = oldProtocol ])\x0a\x09\x09\x09ifEmpty: [ self methodClass organization removeElement: oldProtocol ] ]",
+messageSends: ["protocol", "basicAt:put:", "announce:", "method:", "new", "oldProtocol:", "yourself", "current", "ifNotNil:", "addElement:", "organization", "methodClass", "ifEmpty:", "removeElement:", "select:", "=", "methods"],
+referencedClasses: ["MethodMoved", "SystemAnnouncer"]
 }),
 smalltalk.CompiledMethod);
 

st/Kernel-Announcements.st

@@ -197,6 +197,20 @@ oldMethod: aMethod
 	oldMethod := aMethod
 ! !
 
+MethodAnnouncement subclass: #MethodMoved
+	instanceVariableNames: 'oldProtocol'
+	package: 'Kernel-Announcements'!
+
+!MethodMoved methodsFor: 'accessing'!
+
+oldProtocol
+	^ oldProtocol
+!
+
+oldProtocol: aString
+	oldProtocol := aString
+! !
+
 MethodAnnouncement subclass: #MethodRemoved
 	instanceVariableNames: ''
 	package: 'Kernel-Announcements'!

st/Kernel-Classes.st

@@ -195,11 +195,11 @@ addCompiledMethod: aMethod
 !
 
 compile: aString
-	self compile: aString category: ''
+	^ self compile: aString category: ''
 !
 
 compile: aString category: anotherString
-	Compiler new
+	^ Compiler new
 		install: aString
 		forClass: self
 		category: anotherString
@@ -570,6 +570,11 @@ copyClass: aClass named: aString
 
 	self copyClass: aClass to: newClass.
 	
+	SystemAnnouncer current
+		announce: (ClassAdded new
+			theClass: newClass;
+			yourself).
+	
 	^newClass
 !
 

st/Kernel-Methods.st

@@ -191,16 +191,21 @@ category
 !
 
 category: aString
-	| oldCategory |
-	oldCategory := self category.
+	| oldProtocol |
+	oldProtocol := self protocol.
 	self basicAt: 'category' put: aString.
-	
+
+	SystemOrganizer current announce: (MethodMoved new
+		method: self;
+		oldProtocol: oldProtocol;
+		yourself).
+
 	self methodClass ifNotNil: [
 		self methodClass organization addElement: aString.
 	
 		(self methodClass methods
-			select: [ :each | each category = oldCategory ])
-			ifEmpty: [ self methodClass organization removeElement: oldCategory ] ]
+			select: [ :each | each protocol = oldProtocol ])
+			ifEmpty: [ self methodClass organization removeElement: oldProtocol ] ]
 !
 
 fn