hg/stx-libbasic: comparison Method.st

equal deleted inserted replaced

-:f4c3a230f42f
+:5c9959ce98af
 source notNil ifTrue:[
 	sourcePosition notNil ifTrue:[
 	    self source:(self source)
 	]
 ].
+!
+mclass:aClass
+mclass notNil ifTrue:[
+'Method [warning]: mclass already set' errorPrintCR.
+].
+mclass := aClass.
 !
 package
 "return the package-symbol"
 "based on who, which has been added for ST-80 compatibility"
 |who|
+mclass notNil ifTrue:[^ mclass].
 who := self who.
 who notNil ifTrue:[^ who methodClass].
 "
 none found - sorry
 "
 who
 "return the class and selector of where I am defined in;
 nil is returned for unbound methods.
 ST/X special notice:
-	returns an instance of MethodWhoInfo, which
+returns an instance of MethodWhoInfo, which
-	responds to #methodClass and #methodSelector query messages.
+responds to #methodClass and #methodSelector query messages.
-	For backward- (& ST-80) compatibility, the returned object also
+For backward- (& ST-80) compatibility, the returned object also
-	responds to #at:1 and #at:2 messages.
+responds to #at:1 and #at:2 messages.
 Implementation notice:
-	Since there is no information of the containing class
+Since there is no information of the containing class
-	in the method, we have to do a search here.
+in the method, we have to do a search here.
-	Normally, this is not a problem, except when a method is
+Normally, this is not a problem, except when a method is
-	accepted in the debugger or redefined from within a method
+accepted in the debugger or redefined from within a method
-	(maybe done indirectly, if #doIt is done recursively)
+(maybe done indirectly, if #doIt is done recursively)
-	- the information about which class the original method was
+- the information about which class the original method was
-	defined in is lost in this case.
+defined in is lost in this case.
 Problem:
-	this is heavily called for in the debugger to create
+this is heavily called for in the debugger to create
-	a readable context walkback. For unbound methods, it is
+a readable context walkback. For unbound methods, it is
-	slow, since the search (over all classes) will always fail.
+slow, since the search (over all classes) will always fail.
 Q: should we add a backref from the method to the class
-	and/or add a subclass of Method for unbound ones ?
+and/or add a subclass of Method for unbound ones ?
 Q2: if so, what about the bad guy then, who copies methods around to
-	 other classes ?"
+other classes ?"
 |classes cls sel fn clsName|
+mclass notNil ifTrue:[
+sel := mclass selectorAtMethod:self.
+sel notNil ifTrue:[
+^ MethodWhoInfo class:mclass selector:sel
+].
+].
 "
 speedup kludge: if my sourceFileName is valid,
 extract the className from it and try that class first.
 "
 (fn := self sourceFilename) notNil ifTrue:[
-	clsName := fn asFilename withoutSuffix name.
+clsName := fn asFilename withoutSuffix name.
-	clsName := clsName asSymbolIfInterned.
+clsName := clsName asSymbolIfInterned.
-	clsName notNil ifTrue:[
+clsName notNil ifTrue:[
-	    cls := Smalltalk at:clsName ifAbsent:nil.
+cls := Smalltalk at:clsName ifAbsent:nil.
-	    cls notNil ifTrue:[
+cls notNil ifTrue:[
-		sel := cls selectorAtMethod:self.
+sel := cls selectorAtMethod:self.
-		sel notNil ifTrue:[
+sel notNil ifTrue:[
-		    ^ MethodWhoInfo class:cls selector:sel
+^ MethodWhoInfo class:cls selector:sel
-		].
+].
-		cls := cls class.
+cls := cls class.
-		sel := cls selectorAtMethod:self.
+sel := cls selectorAtMethod:self.
-		sel notNil ifTrue:[
+sel notNil ifTrue:[
-		    ^ MethodWhoInfo class:cls selector:sel
+^ MethodWhoInfo class:cls selector:sel
-		].
+].
-	    ]
+]
-	].
+].
 ].
 "
 then, look in the class we found something the last time
 this may often give a hit, when asking who repeatingly for
 a context chain. (keep last by its name, to not keep classes from
 being garbage collected)
 "
 LastWhoClass notNil ifTrue:[
-	cls := Smalltalk at:LastWhoClass ifAbsent:nil.
+cls := Smalltalk at:LastWhoClass ifAbsent:nil.
-	cls notNil ifTrue:[
+cls notNil ifTrue:[
-	    sel := cls selectorAtMethod:self.
+sel := cls selectorAtMethod:self.
-	    sel notNil ifTrue:[
+sel notNil ifTrue:[
-		^ MethodWhoInfo class:cls selector:sel
+^ MethodWhoInfo class:cls selector:sel
-	    ].
+].
-	    cls := cls class.
+cls := cls class.
-	    sel := cls selectorAtMethod:self.
+sel := cls selectorAtMethod:self.
-	    sel notNil ifTrue:[
+sel notNil ifTrue:[
-		^ MethodWhoInfo class:cls selector:sel
+^ MethodWhoInfo class:cls selector:sel
-	    ].
+].
-	]
+]
 ].
 "
 first, limit the search to global classes only -
 since probability is high, that the receiver is found in there ...
 classes := Smalltalk allClasses.
 "
 instance methods are usually more common - search those first
 "
 classes do:[:aClass |
-	|sel|
+|sel|
-	sel := aClass selectorAtMethod:self ifAbsent:nil.
+sel := aClass selectorAtMethod:self ifAbsent:nil.
-	sel notNil ifTrue:[
+sel notNil ifTrue:[
-	    LastWhoClass := aClass theNonMetaclass name.
+LastWhoClass := aClass theNonMetaclass name.
-	    ^ MethodWhoInfo class:aClass selector:sel
+^ MethodWhoInfo class:aClass selector:sel
-	].
+].
 ].
 classes do:[:aClass |
-	|sel|
+|sel|
-	sel := aClass class selectorAtMethod:self.
+sel := aClass class selectorAtMethod:self.
-	sel notNil ifTrue:[
+sel notNil ifTrue:[
-	    LastWhoClass := aClass theNonMetaclass name.
+LastWhoClass := aClass theNonMetaclass name.
-	    ^ MethodWhoInfo class:aClass class selector:sel
+^ MethodWhoInfo class:aClass class selector:sel
-	].
+].
 ].
 LastWhoClass := nil.
 "
 mhmh - must be a method of some anonymous class (i.e. one not
 in the Smalltalk dictionary). Search all instances of Behavior
 "
 Behavior allSubInstancesDo:[:someClass |
-	|sel|
+|sel|
-	(classes includes:someClass) ifFalse:[
+(classes includes:someClass) ifFalse:[
-	    sel := someClass selectorAtMethod:self.
+sel := someClass selectorAtMethod:self.
-	    sel notNil ifTrue:[
+sel notNil ifTrue:[
-		^ MethodWhoInfo class:someClass selector:sel
+^ MethodWhoInfo class:someClass selector:sel
-	    ]
+]
-	]
+]
 ].
 "
 none found - sorry
 "
 ^ nil
 "untypical situation: an anonymous class"
 "
 |m cls|
 Object
-	subclass:#FunnyClass
+subclass:#FunnyClass
-	instanceVariableNames:'foo'
+instanceVariableNames:'foo'
-	classVariableNames:''
+classVariableNames:''
-	poolDictionaries:''
+poolDictionaries:''
-	category:'testing'.
+category:'testing'.
 cls := Smalltalk at:#FunnyClass.
 Smalltalk removeClass:cls.
 cls compile:'testMethod1:arg foo:=arg'.
 cls compile:'testMethod2 ^ foo'.
 ! !
 !Method class methodsFor:'documentation'!
 version
-^ '$Header: /cvs/stx/stx/libbasic/Method.st,v 1.186 2000-03-24 11:54:40 cg Exp $'
+^ '$Header: /cvs/stx/stx/libbasic/Method.st,v 1.187 2000-03-24 12:53:35 cg Exp $'
 ! !
 Method initialize!

changeset 5324	5c9959ce98af
parent 5322	411b6c0f7250
child 5339	c922450b57b5