Merge pull request #974 from seandenigris/Issue973

DoIts shouldn't dirty Compiler-Core #973

API-CHANGES.txt

@@ -1,3 +1,10 @@
+0.12.5:
+
++ String >>
+  + value:
++ ProtocolAnnouncement >>
+  + package
+
 0.12.4:
 
 * Package Canvas renamed to Web

src/Compiler-Core.js

@@ -459,7 +459,7 @@ var result,method;
 return smalltalk.withContext(function($ctx1) { 
 var $1,$2;
 method=self._eval_(self._compileExpression_on_(aString,anObject));
-_st(method)._protocol_("xxxDoIt");
+_st(method)._protocol_("**xxxDoIt");
 $1=_st(anObject)._class();
 $ctx1.sendIdx["class"]=1;
 _st($1)._addCompiledMethod_(method);
@@ -469,7 +469,7 @@ $2=result;
 return $2;
 }, function($ctx1) {$ctx1.fill(self,"evaluateExpression:on:",{aString:aString,anObject:anObject,result:result,method:method},globals.Compiler)})},
 args: ["aString", "anObject"],
-source: "evaluateExpression: aString on: anObject\x0a\x09\x22Unlike #eval: evaluate a Smalltalk expression with anObject as the receiver and answer the returned object\x22\x0a\x09| result method |\x0a\x09method := self eval: (self compileExpression: aString on: anObject).\x0a\x09method protocol: 'xxxDoIt'.\x0a\x09anObject class addCompiledMethod: method.\x0a\x09result := anObject xxxDoIt.\x0a\x09anObject class removeCompiledMethod: method.\x0a\x09^ result",
+source: "evaluateExpression: aString on: anObject\x0a\x09\x22Unlike #eval: evaluate a Smalltalk expression with anObject as the receiver and answer the returned object\x22\x0a\x09| result method |\x0a\x09method := self eval: (self compileExpression: aString on: anObject).\x0a\x09method protocol: '**xxxDoIt'.\x0a\x09anObject class addCompiledMethod: method.\x0a\x09result := anObject xxxDoIt.\x0a\x09anObject class removeCompiledMethod: method.\x0a\x09^ result",
 messageSends: ["eval:", "compileExpression:on:", "protocol:", "addCompiledMethod:", "class", "xxxDoIt", "removeCompiledMethod:"],
 referencedClasses: []
 }),
@@ -687,31 +687,6 @@ globals.Compiler.klass);
 
 smalltalk.addClass('DoIt', globals.Object, [], 'Compiler-Core');
 globals.DoIt.comment="`DoIt` is the class used to compile and evaluate expressions. See `Compiler >> evaluateExpression:`.";
-smalltalk.addMethod(
-smalltalk.method({
-selector: "xxxDoIt",
-protocol: 'xxxDoIt',
-fn: function (){
-var self=this;
-function $Smalltalk(){return globals.Smalltalk||(typeof Smalltalk=="undefined"?nil:Smalltalk)}
-return smalltalk.withContext(function($ctx1) { 
-var $1;
-$1=_st((function(){
-return smalltalk.withContext(function($ctx2) {
-return _st(_st($Smalltalk())._packages())._do_((function(each){
-return smalltalk.withContext(function($ctx3) {
-return _st(each)._commit();
-}, function($ctx3) {$ctx3.fillBlock({each:each},$ctx2,2)})}));
-}, function($ctx2) {$ctx2.fillBlock({},$ctx1,1)})}))._value();
-return $1;
-}, function($ctx1) {$ctx1.fill(self,"xxxDoIt",{},globals.DoIt)})},
-args: [],
-source: "xxxDoIt ^ [ Smalltalk packages do: [ :each | each commit ] ] value",
-messageSends: ["value", "do:", "packages", "commit"],
-referencedClasses: ["Smalltalk"]
-}),
-globals.DoIt);
-
 
 
 smalltalk.addClass('Evaluator', globals.InterfacingObject, [], 'Compiler-Core');

src/Compiler-Core.st

@@ -167,7 +167,7 @@ evaluateExpression: aString on: anObject
 	"Unlike #eval: evaluate a Smalltalk expression with anObject as the receiver and answer the returned object"
 	| result method |
 	method := self eval: (self compileExpression: aString on: anObject).
-	method protocol: 'xxxDoIt'.
+	method protocol: '**xxxDoIt'.
 	anObject class addCompiledMethod: method.
 	result := anObject xxxDoIt.
 	anObject class removeCompiledMethod: method.

src/Kernel-Announcements.js

@@ -814,6 +814,34 @@ globals.PackageRemoved.comment="I am emitted when a `Package` is removed from th
 
 smalltalk.addClass('ProtocolAnnouncement', globals.SystemAnnouncement, ['theClass', 'protocol'], 'Kernel-Announcements');
 globals.ProtocolAnnouncement.comment="I am the abstract superclass of protocol-related announcements.";
+smalltalk.addMethod(
+smalltalk.method({
+selector: "package",
+protocol: 'accessing',
+fn: function (){
+var self=this;
+function $Package(){return globals.Package||(typeof Package=="undefined"?nil:Package)}
+return smalltalk.withContext(function($ctx1) { 
+var $2,$1,$3,$4;
+$2=self._protocol();
+$ctx1.sendIdx["protocol"]=1;
+$1=_st($2)._beginsWith_("*");
+if(! smalltalk.assert($1)){
+$3=_st(self._theClass())._package();
+return $3;
+};
+$4=_st($Package())._named_ifAbsent_(_st(self._protocol())._allButFirst(),(function(){
+return nil;
+}));
+return $4;
+}, function($ctx1) {$ctx1.fill(self,"package",{},globals.ProtocolAnnouncement)})},
+args: [],
+source: "package\x0a\x0a\x09(self protocol beginsWith: '*') ifFalse: [\x0a\x09\x09^ self theClass package ].\x0a\x09\x09\x0a\x09^ Package \x0a\x09\x09named: self protocol allButFirst\x0a\x09\x09ifAbsent: [ nil ]",
+messageSends: ["ifFalse:", "beginsWith:", "protocol", "package", "theClass", "named:ifAbsent:", "allButFirst"],
+referencedClasses: ["Package"]
+}),
+globals.ProtocolAnnouncement);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "protocol",

src/Kernel-Announcements.st

@@ -399,6 +399,16 @@ I am the abstract superclass of protocol-related announcements.!
 
 !ProtocolAnnouncement methodsFor: 'accessing'!
 
+package
+
+	(self protocol beginsWith: '*') ifFalse: [
+		^ self theClass package ].
+		
+	^ Package 
+		named: self protocol allButFirst
+		ifAbsent: [ nil ]
+!
+
 protocol
 	^ protocol
 !

src/Kernel-Infrastructure.js

@@ -2081,7 +2081,7 @@ _st(_st(theClass)._package())._beDirty();
 };
 return self}, function($ctx1) {$ctx1.fill(self,"onClassModification:",{anAnnouncement:anAnnouncement},globals.PackageStateObserver)})},
 args: ["anAnnouncement"],
-source: "onClassModification: anAnnouncement\x0a\x09anAnnouncement theClass ifNotNil: [ :theClass |\x0a\x09\x09theClass package beDirty ]",
+source: "onClassModification: anAnnouncement\x0a\x09anAnnouncement theClass ifNotNil: [ :theClass | theClass package beDirty ]",
 messageSends: ["ifNotNil:", "theClass", "beDirty", "package"],
 referencedClasses: []
 }),
@@ -2134,11 +2134,19 @@ protocol: 'reactions',
 fn: function (anAnnouncement){
 var self=this;
 return smalltalk.withContext(function($ctx1) { 
-_st(_st(_st(anAnnouncement)._theClass())._package())._beDirty();
+var $1,$receiver;
+$1=_st(anAnnouncement)._package();
+if(($receiver = $1) == null || $receiver.isNil){
+$1;
+} else {
+var package_;
+package_=$receiver;
+_st(package_)._beDirty();
+};
 return self}, function($ctx1) {$ctx1.fill(self,"onProtocolModification:",{anAnnouncement:anAnnouncement},globals.PackageStateObserver)})},
 args: ["anAnnouncement"],
-source: "onProtocolModification: anAnnouncement\x0a\x09anAnnouncement theClass package beDirty",
-messageSends: ["beDirty", "package", "theClass"],
+source: "onProtocolModification: anAnnouncement\x0a\x09anAnnouncement package ifNotNil: [ :package | package beDirty ]",
+messageSends: ["ifNotNil:", "package", "beDirty"],
 referencedClasses: []
 }),
 globals.PackageStateObserver);

src/Kernel-Infrastructure.st

@@ -772,8 +772,7 @@ observeSystem
 !PackageStateObserver methodsFor: 'reactions'!
 
 onClassModification: anAnnouncement
-	anAnnouncement theClass ifNotNil: [ :theClass |
-		theClass package beDirty ]
+	anAnnouncement theClass ifNotNil: [ :theClass | theClass package beDirty ]
 !
 
 onMethodModification: anAnnouncement
@@ -785,7 +784,7 @@ onPackageAdded: anAnnouncement
 !
 
 onProtocolModification: anAnnouncement
-	anAnnouncement theClass package beDirty
+	anAnnouncement package ifNotNil: [ :package | package beDirty ]
 ! !
 
 PackageStateObserver class instanceVariableNames: 'current'!

src/Kernel-Methods.js

@@ -705,7 +705,7 @@ fn: function (){
 var self=this;
 function $Package(){return globals.Package||(typeof Package=="undefined"?nil:Package)}
 return smalltalk.withContext(function($ctx1) { 
-var $1,$3,$2,$5,$4,$6,$receiver;
+var $1,$3,$2,$4,$5,$receiver;
 $1=self._methodClass();
 $ctx1.sendIdx["methodClass"]=1;
 if(($receiver = $1) == null || $receiver.isNil){
@@ -717,20 +717,16 @@ $3=self._protocol();
 $ctx1.sendIdx["protocol"]=1;
 $2=_st($3)._beginsWith_("*");
 if(! smalltalk.assert($2)){
-$5=self._methodClass();
-$ctx1.sendIdx["methodClass"]=2;
-$4=_st($5)._package();
-$ctx1.sendIdx["package"]=1;
+$4=_st(self._methodClass())._package();
 return $4;
 };
-$6=_st($Package())._named_ifAbsent_(_st(self._protocol())._allButFirst(),(function(){
-return smalltalk.withContext(function($ctx2) {
-return _st(self._methodClass())._package();
-}, function($ctx2) {$ctx2.fillBlock({},$ctx1,3)})}));
-return $6;
+$5=_st($Package())._named_ifAbsent_(_st(self._protocol())._allButFirst(),(function(){
+return nil;
+}));
+return $5;
 }, function($ctx1) {$ctx1.fill(self,"package",{},globals.CompiledMethod)})},
 args: [],
-source: "package\x0a\x09\x22Answer the package the receiver belongs to:\x0a\x09- if it is an extension method, answer the corresponding package\x0a\x09- else answer the `methodClass` package\x22\x0a\x09\x0a\x09self methodClass ifNil: [ ^ nil ].\x0a\x09\x0a\x09(self protocol beginsWith: '*') ifFalse: [\x0a\x09\x09^ self methodClass package ].\x0a\x09\x09\x0a\x09^ Package \x0a\x09\x09named: self protocol allButFirst\x0a\x09\x09ifAbsent: [ self methodClass package ]",
+source: "package\x0a\x09\x22Answer the package the receiver belongs to:\x0a\x09- if it is an extension method, answer the corresponding package\x0a\x09- else answer the `methodClass` package\x22\x0a\x09\x0a\x09self methodClass ifNil: [ ^ nil ].\x0a\x09\x0a\x09(self protocol beginsWith: '*') ifFalse: [\x0a\x09\x09^ self methodClass package ].\x0a\x09\x09\x0a\x09^ Package \x0a\x09\x09named: self protocol allButFirst\x0a\x09\x09ifAbsent: [ nil ]",
 messageSends: ["ifNil:", "methodClass", "ifFalse:", "beginsWith:", "protocol", "package", "named:ifAbsent:", "allButFirst"],
 referencedClasses: ["Package"]
 }),

src/Kernel-Methods.st

@@ -246,7 +246,7 @@ package
 		
 	^ Package 
 		named: self protocol allButFirst
-		ifAbsent: [ self methodClass package ]
+		ifAbsent: [ nil ]
 !
 
 protocol

src/Kernel-Tests.js

@@ -3,6 +3,32 @@ smalltalk.addPackage('Kernel-Tests');
 smalltalk.packages["Kernel-Tests"].transport = {"type":"amd","amdNamespace":"amber_core"};
 
 smalltalk.addClass('AnnouncementSubscriptionTest', globals.TestCase, [], 'Kernel-Tests');
+smalltalk.addMethod(
+smalltalk.method({
+selector: "testAddExtensionMethod",
+protocol: 'tests',
+fn: function (){
+var self=this;
+var method;
+return smalltalk.withContext(function($ctx1) { 
+var $1,$4,$3,$2;
+$1=self._class();
+$ctx1.sendIdx["class"]=1;
+method=_st($1)._compile_protocol_("doNothing","**not-a-package");
+$4=self._class();
+$ctx1.sendIdx["class"]=2;
+$3=_st($4)._package();
+$2=_st($3)._isDirty();
+self._deny_($2);
+_st(self._class())._removeCompiledMethod_(method);
+return self}, function($ctx1) {$ctx1.fill(self,"testAddExtensionMethod",{method:method},globals.AnnouncementSubscriptionTest)})},
+args: [],
+source: "testAddExtensionMethod\x0a\x09| method |\x0a\x09method := self class compile: 'doNothing' protocol: '**not-a-package'.\x0a\x09self deny: self class package isDirty.\x0a\x09self class removeCompiledMethod: method.",
+messageSends: ["compile:protocol:", "class", "deny:", "isDirty", "package", "removeCompiledMethod:"],
+referencedClasses: []
+}),
+globals.AnnouncementSubscriptionTest);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "testHandlesAnnouncement",

src/Kernel-Tests.st

@@ -5,6 +5,13 @@ TestCase subclass: #AnnouncementSubscriptionTest
 
 !AnnouncementSubscriptionTest methodsFor: 'tests'!
 
+testAddExtensionMethod
+	| method |
+	method := self class compile: 'doNothing' protocol: '**not-a-package'.
+	self deny: self class package isDirty.
+	self class removeCompiledMethod: method.
+!
+
 testHandlesAnnouncement
 	| subscription announcementClass1 announcementClass2 classBuilder |