hg/stx-libbasic: comparison Method.st

equal deleted inserted replaced

-:be947d4e7fb2
+:514c749165c3
 "
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	      All Rights Reserved
 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 category:'Kernel-Methods'
 !
 Method comment:'
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	     All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.18 1994-08-23 23:09:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.19 1994-10-10 00:26:43 claus Exp $
 '!
 !Method class methodsFor:'documentation'!
 copyright
 "
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	      All Rights Reserved
 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 "
 !
 version
 "
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.18 1994-08-23 23:09:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.19 1994-10-10 00:26:43 claus Exp $
 "
 !
 documentation
 "
 Do not depend on any value in the flags field - it may change without
 notice.
 Instance variables:
-source          <String>        the source itself (if sourcePosition isNil)
+	source          <String>        the source itself (if sourcePosition isNil)
-or the fileName where the source is found
+					or the fileName where the source is found
-sourcePosition  <Integer>       the position of the methods chunk in the file
+	sourcePosition  <Integer>       the position of the methods chunk in the file
-category        <Symbol>        the methods category
+	category        <Symbol>        the methods category
-package         <Symbol>        the package, in which the methods was defined
+	package         <Symbol>        the package, in which the methods was defined
-(nil if its the standard system package)
+					(nil if its the standard system package)
 WARNING: layout known by compiler and runtime system - dont change
 "
 ! !
 !Method class methodsFor:'initialization'!
 initialize
 PrivateMethodSignal isNil ifTrue:[
-"EXPERIMENTAL"
+	ExecutableCodeObject initialize.
-PrivateMethodSignal := (Signal new) mayProceed:true.
-PrivateMethodSignal notifierString:'attempt to execute private method'.
+	"EXPERIMENTAL"
+	PrivateMethodSignal := ExecutionErrorSignal newSignalMayProceed:true.
+	PrivateMethodSignal nameClass:self message:#privateMethodSignal.
+	PrivateMethodSignal notifierString:'attempt to execute private method'.
 ]
 ! !
+!Method class methodsFor:'signal access'!
+privateMethodSignal
+^ PrivateMethodSignal
+! !
 !Method class methodsFor:'queries'!
 isBuiltInClass
 "this class is known by the run-time-system"
 "return the sourcestring for the receiver"
 |aStream junk|
 source notNil ifTrue:[
-sourcePosition isNil ifTrue:[^ source].
+	sourcePosition isNil ifTrue:[^ source].
-aStream := Smalltalk systemFileStreamFor:('source/' , source).
+	aStream := Smalltalk systemFileStreamFor:('source/' , source).
-aStream notNil ifTrue:[
+	aStream notNil ifTrue:[
-aStream position:sourcePosition.
+	    aStream position:sourcePosition.
-junk := aStream nextChunk.
+	    junk := aStream nextChunk.
-aStream close
+	    aStream close
-]
+	]
 ].
 ^ junk
 !
 source:aString
 !
 comment
 "return the methods comment.
 This is done by searching for and returning the first comment
-from the methods source.
+from the methods source (excluding any double-quotes).
 Returns nil if there is no comment (or source is not available)."
-|text lines line nQuote index i1 i2 commLines|
+|src stream|
-text := self source.
+src := self source.
-text isNil ifTrue:[^ nil].
+src isNil ifTrue:[^ nil].
-lines := text asCollectionOfLines.
-(lines size < 2) ifTrue:[^ nil].
+stream := ReadStream on:src.
+(stream skipThrough:Character doubleQuote) isNil ifTrue:[^ nil].
-index := 2.
+^ stream upTo:Character doubleQuote.
 "
-skip empty lines
+(Method compiledMethodAt:#comment) comment
-"
-line := (lines at:index).
-[line isBlank] whileTrue:[
-index := index + 1.
-index > lines size ifTrue:[^ nil].
-line := (lines at:index).
-].
-nQuote := line occurrencesOf:(Character doubleQuote).
-(nQuote == 0) ifTrue:[^ nil].
-(nQuote == 2) ifTrue:[^ line].
-(nQuote > 2) ifTrue:[
-i1 := line indexOf:(Character doubleQuote).
-i2 := line indexOf:(Character doubleQuote) startingAt:(i1 + 1).
-^ line copyFrom:i1+1 to:i2-1
-].
-commLines := Text new.
-commLines add:line.
-[nQuote ~~ 1] whileTrue:[
-index := index + 1.
-index > lines size ifTrue:[^ nil]. "unclosed comment - could warn here"
-line := lines at:index.
-nQuote := line occurrencesOf:(Character doubleQuote).
-commLines add:line.
-].
-^ commLines asString
-"
-(Method compiledMethodAt:#comment) comment
 "
 !
 category
 "return the methods category or nil"
 "set the flags (number of method variables, stacksize).
 WARNING: for internal use by the compiler only."
 "protect myself a bit - putting in an object would crash me ..."
 (newFlags isMemberOf:SmallInteger) ifTrue:[
-flags := newFlags
+	flags := newFlags
 ]
 !
 private:aBoolean
 "set the flag bit stating that this method is private, and should only be
 int f = _intVal(_INST(flags));
 /* made this a primitive to get define in stc.h */
 #ifdef F_PRIVATE
 if (aBoolean == true)
-f = f | F_PRIVATE;
+	f = f | F_PRIVATE;
 else
-f = f & ~F_PRIVATE;
+	f = f & ~F_PRIVATE;
 _INST(flags) = _MKSMALLINT(f);
 #endif
 %}
 !
 int f = _intVal(_INST(flags));
 /* made this a primitive to get define in stc.h */
 #ifdef F_PRIVATE
 if (f & F_PRIVATE) {
-RETURN (true);
+	RETURN (true);
 }
 #endif
 %}.
 ^ false
 !
 missing SENDxx functions in the VM and cases in #perform. This too
 will be removed in a later release, allowing any number of arguments.
 - for use by compiler only."
 (aNumber between:0 and:self class maxNumberOfArguments) ifFalse:[
-self error:('ST/X only supports up to a maximum of ' ,
+	self error:('ST/X only supports up to a maximum of ' ,
-self class maxNumberOfArguments printString ,
+		    self class maxNumberOfArguments printString ,
-' method arguments').
+		    ' method arguments').
-^ self
+	^ self
 ].
 %{
 /* made this a primitive to get define in stc.h */
 #ifdef F_NARGS
 _INST(flags) = _MKSMALLINT( (_intVal(_INST(flags)) & ~F_NARGS) | (_intVal(aNumber) << F_NARGSHIFT) );
 !
 numberOfMethodVars:aNumber
 "set the number of method variables - for use by compiler only.
 WARNING: playing around here with incorrect values
-may crash smalltalk badly."
+	      may crash smalltalk badly."
 %{  /* NOCONTEXT */
 int f = _intVal(_INST(flags));
 /* made this a primitive to get define in stc.h */
 if (_isSmallInteger(aNumber)) {
-f = (f & ~F_NVARS) | (_intVal(aNumber) << F_NVARSHIFT);
+	f = (f & ~F_NVARS) | (_intVal(aNumber) << F_NVARSHIFT);
-_INST(flags) = _MKSMALLINT(f);
+	_INST(flags) = _MKSMALLINT(f);
 }
 %}
 !
 numberOfMethodVars
 !
 stackSize:aNumber
 "set the depth of the local stack - for use by compiler only.
 WARNING: playing around here with incorrect values
-may crash smalltalk badly.
+	      may crash smalltalk badly.
-(if the runtime library was compiled with DEBUG,
+	      (if the runtime library was compiled with DEBUG,
-a bad stack will be detected and triggers an error)"
+	       a bad stack will be detected and triggers an error)"
 %{  /* NOCONTEXT */
 int f = _intVal(_INST(flags));
 /* made this a primitive to get define in stc.h */
 if (_isSmallInteger(aNumber)) {
-f = (f & ~F_NSTACK) | (_intVal(aNumber) << F_NSTACKSHIFT);
+	f = (f & ~F_NSTACK) | (_intVal(aNumber) << F_NSTACKSHIFT);
-_INST(flags) = _MKSMALLINT(f);
+	_INST(flags) = _MKSMALLINT(f);
 }
 %}
 !
 stackSize
 %}
 ! !
 !Method methodsFor:'queries'!
+who
+"return the class and selector of where I am defined in.
+Since there is no information of the containing class
+in the method, we have to do a search here.
+Normally, this is not a problem, except when a method is
+accepted in the debugger or redefined from within a method
+(maybe done indirectly, if doIt is done recursively)
+- the information about which class the original method was
+defined in is lost in this case.
+Q: should we add a backref from the method to the class ?"
+"
+first, limit the search to global classes only -
+since probability is high, that the receiver is found in there ...
+"
+Smalltalk allBehaviorsDo:[:aClass |
+	|sel|
+	sel := aClass selectorForMethod:self.
+	sel notNil ifTrue:[^ Array with:aClass with:sel].
+	sel := aClass class selectorForMethod:self.
+	sel notNil ifTrue:[^ Array with:aClass class with:sel].
+].
+"
+mhmh - must be a method of some anonymous class (i.e. one not
+in the Smalltalk dictionary; search all instances of Behavior
+"
+Behavior allDerivedInstancesDo:[:someClass |
+	|sel|
+	sel := someClass selectorForMethod:self.
+	sel notNil ifTrue:[^ Array with:someClass with:sel]
+].
+"
+none found - sorry
+"
+^ nil
+"typical situation: some well-known class"
+"
+|m|
+m := Object compiledMethodAt:#copy.
+m who
+"
+"untypical situation: an anonymous class"
+"
+|m cls|
+Object
+	subclass:#FunnyClass
+	instanceVariableNames:'foo'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'testing'.
+cls := Smalltalk at:#FunnyClass.
+Smalltalk removeClass:cls.
+cls compile:'testMethod1:arg foo:=arg'.
+cls compile:'testMethod2 ^ foo'.
+m := cls compiledMethodAt:#testMethod1:.
+m who
+"
+!
 containingClass
 "return the class I am defined in.
-Since there is no information of the containing class
+See comment in who."
-in the method, we have to search here.
+"based on who, which has been added for ST-80 compatibility"
-Normally, this is not a problem, except when a method is
-accepted in the debugger - the information about which
+|pair|
-class the original method was in is then lost.
+pair := self who.
-Q: should we add a backref from the method to the class ?"
+pair notNil ifTrue:[^ pair at:1].
-Smalltalk allBehaviorsDo:[:aClass |
-(aClass containsMethod:self) ifTrue:[^ aClass].
-(aClass class containsMethod:self) ifTrue:[^ aClass class]
-].
-"
-mhmh - must be a method of some anonymous class (i.e. one not
-in the Smalltalk dictionary; search all instances of Behavior
-"
-Behavior allDerivedInstancesDo:[:someClass |
-(someClass containsMethod:self) ifTrue:[
-^ someClass
-].
-].
 "
 none found - sorry
 "
 ^ nil
 !
 |parser sourceString|
 sourceString := self source.
 sourceString notNil ifTrue:[
-parser := Parser parseMethodSpecification:sourceString.
+	parser := Parser parseMethodSpecification:sourceString.
-(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+	(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
-^ parser methodArgs
+	^ parser methodArgs
 ].
 ^ nil
 "
 (Method compiledMethodAt:#printOn:) methodArgNames
 |parser sourceString|
 sourceString := self source.
 sourceString notNil ifTrue:[
-parser := Parser parseMethodArgAndVarSpecification:sourceString.
+	parser := Parser parseMethodArgAndVarSpecification:sourceString.
-(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+	(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
-^ parser methodVars
+	^ parser methodVars
 ].
 ^ nil
 "
 (Method compiledMethodAt:#printOn:) methodVarNames
 |parser sourceString argNames varNames|
 sourceString := self source.
 sourceString notNil ifTrue:[
-parser := Parser parseMethodArgAndVarSpecification:sourceString.
+	parser := Parser parseMethodArgAndVarSpecification:sourceString.
-(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+	(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
-argNames := parser methodArgs.
+	argNames := parser methodArgs.
-varNames := parser methodVars.
+	varNames := parser methodVars.
-argNames isNil ifTrue:[^ varNames].
+	argNames isNil ifTrue:[^ varNames].
-varNames isNil ifTrue:[^ argNames].
+	varNames isNil ifTrue:[^ argNames].
-^ (argNames , varNames)
+	^ (argNames , varNames)
 ].
 ^ nil
 "
 (Method compiledMethodAt:#printOn:) methodArgAndVarNames
 (text size < 2) ifTrue:[^nil].
 line := (text at:2).
 nQuote := line occurrencesOf:(Character doubleQuote).
 (nQuote == 2) ifTrue:[
-qIndex := line indexOf:(Character doubleQuote).
+	qIndex := line indexOf:(Character doubleQuote).
-qIndex2 := line indexOf:(Character doubleQuote) startingAt:(qIndex + 1).
+	qIndex2 := line indexOf:(Character doubleQuote) startingAt:(qIndex + 1).
-^ line copyFrom:(qIndex + 1) to:(qIndex2 - 1)
+	^ line copyFrom:(qIndex + 1) to:(qIndex2 - 1)
 ].
 (nQuote == 1) ifTrue:[
-qIndex := line indexOf:(Character doubleQuote).
+	qIndex := line indexOf:(Character doubleQuote).
-comment := line copyFrom:(qIndex + 1).
+	comment := line copyFrom:(qIndex + 1).
-index := 3.
+	index := 3.
-line := text at:index.
+	line := text at:index.
-nQuote := line occurrencesOf:(Character doubleQuote).
+	nQuote := line occurrencesOf:(Character doubleQuote).
-[nQuote ~~ 1] whileTrue:[
+	[nQuote ~~ 1] whileTrue:[
-comment := comment , Character cr asString , line withoutSpaces.
+	    comment := comment , Character cr asString , line withoutSpaces.
-index := index + 1.
+	    index := index + 1.
-line := text at:index.
+	    line := text at:index.
-nQuote := line occurrencesOf:(Character doubleQuote)
+	    nQuote := line occurrencesOf:(Character doubleQuote)
-].
+	].
-qIndex := line indexOf:(Character doubleQuote).
+	qIndex := line indexOf:(Character doubleQuote).
-^ comment , Character cr asString , (line copyTo:(qIndex - 1)) withoutSpaces
+	^ comment , Character cr asString , (line copyTo:(qIndex - 1)) withoutSpaces
 ].
 ^ nil
 "
 (Method compiledMethodAt:#methodComment) methodComment
 Thus, we arrive here, when playing around in a classes methodArray,
 or compiler/runtime system is broken :-(,
 or you ignore the error messages during some recompile."
 ^ InvalidCodeSignal
-raiseRequestWith:self
+	raiseRequestWith:self
-errorString:'invalid method - not executable'.
+	errorString:'invalid method - not executable'.
 !
 wrongNumberOfArguments:numberGiven
 "this error is triggered, if a method is called with a wrong number
 of arguments. This only applies to #valueWithReceiverXXX - sends.
 With a normal send, this error cannot happen."
 ^ ArgumentSignal
-raiseRequestWith:self
+	raiseRequestWith:self
-errorString:('method got ' , numberGiven printString ,
+	errorString:('method got ' , numberGiven printString ,
-' args while ' , self numberOfMethodArgs printString , ' where expected')
+		     ' args while ' , self numberOfMethodArgs printString , ' where expected')
 !
 privateMethodCalled
 "this error is triggered, if a private method is called from
 outside (i.e. not via a self-send and not via a super-send.
 int nargs;
 OBJ *ap;
 extern OBJ interpret();
 if (__isArray(argArray)) {
-nargs = _arraySize(argArray);
+	nargs = _arraySize(argArray);
-ap = _ArrayInstPtr(argArray)->a_element;
+	ap = _ArrayInstPtr(argArray)->a_element;
 } else {
-if (argArray == nil) {
+	if (argArray == nil) {
-nargs = 0;
+	    nargs = 0;
-} else
+	} else
-nargs = -1;
+	    nargs = -1;
 }
 #ifdef F_NARGS
 if (((_intVal(_INST(flags)) & F_NARGS) >> F_NARGSHIFT) == nargs)
 #endif
 {
-code = _MethodInstPtr(self)->m_code;
+	code = _MethodInstPtr(self)->m_code;
-if (aClass == nil) {
+	if (aClass == nil) {
-searchClass = dummy.ilc_class = _Class(anObject);
+	    searchClass = dummy.ilc_class = _Class(anObject);
-} else {
+	} else {
-searchClass = dummy.ilc_class = aClass;
+	    searchClass = dummy.ilc_class = aClass;
-}
+	}
-if (code) {
+	if (code) {
-/* compiled code */
+	    /* compiled code */
-switch (nargs) {
+	    switch (nargs) {
-case 0:
+		case 0:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy) );
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy) );
-case 1:
+		case 1:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0]) );
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0]) );
-case 2:
+		case 2:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
-case 3:
+		case 3:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
-case 4:
+		case 4:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3]) );
+				 ap[0], ap[1], ap[2], ap[3]) );
-case 5:
+		case 5:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4]) );
+				 ap[0], ap[1], ap[2], ap[3], ap[4]) );
-case 6:
+		case 6:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
-case 7:
+		case 7:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
-case 8:
+		case 8:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7]) );
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7]) );
-case 9:
+		case 9:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8]) );
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8]) );
-case 10:
+		case 10:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9]) );
+				 ap[9]) );
-case 11:
+		case 11:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9], ap[10]) );
+				 ap[9], ap[10]) );
-case 12:
+		case 12:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9], ap[10], ap[11]) );
+				 ap[9], ap[10], ap[11]) );
-case 13:
+		case 13:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9], ap[10], ap[11], ap[12]) );
+				 ap[9], ap[10], ap[11], ap[12]) );
-case 14:
+		case 14:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9], ap[10], ap[11], ap[12], ap[13]) );
+				 ap[9], ap[10], ap[11], ap[12], ap[13]) );
-case 15:
+		case 15:
-RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+		    RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+				 ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
-ap[9], ap[10], ap[11], ap[12], ap[13], ap[14]) );
+				 ap[9], ap[10], ap[11], ap[12], ap[13], ap[14]) );
-}
+	    }
-} else {
+	} else {
-/* interpreted code */
+	    /* interpreted code */
-switch (nargs) {
+	    switch (nargs) {
-case 0:
+		case 0:
-RETURN ( interpret(self, 0, anObject, aSymbol, SND_COMMA searchClass) );
+		    RETURN ( interpret(self, 0, anObject, aSymbol, SND_COMMA searchClass) );
-case 1:
+		case 1:
-RETURN ( interpret(self, 1, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 1, anObject, aSymbol, SND_COMMA searchClass,
-ap[0]) );
+				   ap[0]) );
-case 2:
+		case 2:
-RETURN ( interpret(self, 2, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 2, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1]) );
+				   ap[0], ap[1]) );
-case 3:
+		case 3:
-RETURN ( interpret(self, 3, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 3, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2]) );
+				   ap[0], ap[1], ap[2]) );
-case 4:
+		case 4:
-RETURN ( interpret(self, 4, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 4, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3]) );
+				   ap[0], ap[1], ap[2], ap[3]) );
-case 5:
+		case 5:
-RETURN ( interpret(self, 5, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 5, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4]) );
+				   ap[0], ap[1], ap[2], ap[3], ap[4]) );
-case 6:
+		case 6:
-RETURN ( interpret(self, 6, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 6, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
-case 7:
+		case 7:
-RETURN ( interpret(self, 7, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 7, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
-case 8:
+		case 8:
-RETURN ( interpret(self, 8, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 8, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7]) );
+				   ap[7]) );
-case 9:
+		case 9:
-RETURN ( interpret(self, 9, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 9, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8]) );
+				   ap[7], ap[8]) );
-case 10:
+		case 10:
-RETURN ( interpret(self, 10, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 10, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9]) );
+				   ap[7], ap[8], ap[9]) );
-case 11:
+		case 11:
-RETURN ( interpret(self, 11, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 11, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9], ap[10]) );
+				   ap[7], ap[8], ap[9], ap[10]) );
-case 12:
+		case 12:
-RETURN ( interpret(self, 12, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 12, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9], ap[11]) );
+				   ap[7], ap[8], ap[9], ap[11]) );
-case 13:
+		case 13:
-RETURN ( interpret(self, 13, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 13, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9], ap[11], ap[12]) );
+				   ap[7], ap[8], ap[9], ap[11], ap[12]) );
-case 14:
+		case 14:
-RETURN ( interpret(self, 14, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 14, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9], ap[11], ap[12], ap[13]) );
+				   ap[7], ap[8], ap[9], ap[11], ap[12], ap[13]) );
-case 15:
+		case 15:
-RETURN ( interpret(self, 15, anObject, aSymbol, SND_COMMA searchClass,
+		    RETURN ( interpret(self, 15, anObject, aSymbol, SND_COMMA searchClass,
-ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+				   ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
-ap[7], ap[8], ap[9], ap[11], ap[12], ap[13], ap[14]) );
+				   ap[7], ap[8], ap[9], ap[11], ap[12], ap[13], ap[14]) );
-}
+	    }
-}
+	}
 }
 %}
 .
 (argArray isMemberOf:Array) ifFalse:[
-"
+	"
-arguments must be either nil or an array
+	 arguments must be either nil or an array
-"
+	"
-^ self badArgumentArray
+	^ self badArgumentArray
 ].
 (argArray size ~~ self numberOfMethodArgs) ifTrue:[
-"
+	"
-the method expects a different number of arguments
+	 the method expects a different number of arguments
-"
+	"
-^ self wrongNumberOfArguments:argArray size
+	^ self wrongNumberOfArguments:argArray size
 ].
 "
 the VM only supports a limited number of arguments in sends
 "
 ^ self tooManyArguments
 "
 (Float compiledMethodAt:#+)
-valueWithReceiver:1.0 arguments:#(2.0)
+	valueWithReceiver:1.0 arguments:#(2.0)
 'the next example is a wrong one - which is detected by True's method ...'.
 (True compiledMethodAt:#printString)
-valueWithReceiver:false arguments:nil
+	valueWithReceiver:false arguments:nil
 'the next example is a wrong one - it is nowhere detected
 and a wrong value returned ...'.
 (Point compiledMethodAt:#x)
-valueWithReceiver:(1->2) arguments:nil
+	valueWithReceiver:(1->2) arguments:nil
 'the next example is VERY bad one - it is nowhere detected
 and may crash the system WARNING: save your work before doing this ...'.
 (Point compiledMethodAt:#x)
-valueWithReceiver:(Object new) arguments:nil
+	valueWithReceiver:(Object new) arguments:nil
 'the next example is a wrong one - which is detected here ...'.
 (Object compiledMethodAt:#printOn:)
-valueWithReceiver:false arguments:nil
+	valueWithReceiver:false arguments:nil
 'the next example is a wrong one - which is detected here ...'.
 (Object compiledMethodAt:#printOn:)
-valueWithReceiver:false arguments:#()
+	valueWithReceiver:false arguments:#()
 "
 ! !
 !Method methodsFor:'printing & storing'!
 Since methods do not store their class/selector, we have to search
 for it here."
 |myClass|
-aStream nextPutAll:'a Method('.
+aStream nextPutAll:(self classNameWithArticle).
+aStream nextPut:$(.
 myClass := self containingClass.
 myClass notNil ifTrue:[
-myClass name printOn:aStream.
+	myClass name printOn:aStream.
-aStream nextPutAll:' '.
+	aStream nextPutAll:' '.
-(myClass selectorForMethod:self) printOn:aStream
+	(myClass selectorForMethod:self) printOn:aStream
 ] ifFalse:[
-aStream nextPutAll:'???'
+	aStream nextPutAll:'no class'
 ].
 aStream nextPut:$)
+! !
+!Method class methodsFor:'binary storage'!
+binaryDefinitionFrom: stream manager: manager
+"read my definition from stream."
+|cls sel|
+"type-byte"
+stream nextByte == 0 ifTrue:[
+	"
+	 built-in method
+	"
+	cls := manager nextObject.
+	sel := manager nextObject.
+	"
+	 mhmh - on the source system, this was a machinecode
+	 method, while here its an interpreted one ...
+	"
+	cls isLoaded ifFalse:[
+	    cls autoload
+	].
+	^ cls compiledMethodAt:sel
+].
+"
+bytecode method
+"
+^ super binaryDefinitionFrom:stream manager:manager
 ! !
 !Method methodsFor:'binary storage'!
 asByteCodeMethod
 Otherwise, return the receiver. The new method is not installed in
 the methodDictionary of any class - just returned.
 Can be used to obtain a bytecode version of a machine-code method
 for binary storage or dynamic recompilation (which is not yet finished)."
-|temporaryMethod cls sourceString upd silent|
+|temporaryMethod cls sourceString upd silent lazy|
 byteCode notNil ifTrue:[
-^ self
+	"
+	 is already a bytecoded method
+	"
+	^ self
 ].
 cls := self containingClass.
+cls isNil ifTrue:[
+	'cannot generate bytecode (no class for compilation)' errorPrintNL.
+	^ nil
+].
 sourceString := self source.
 sourceString isNil ifTrue:[
-'cannot generate bytecode (no source for compilation)' errorPrintNL.
+	'cannot generate bytecode (no source for compilation)' errorPrintNL.
 	^ nil
 ].
 "
-dont want this to go into the changes file
+dont want this to go into the changes file,
+dont want output on Transcript and definitely
+dont want a lazy method ...
 "
 upd := Class updateChanges:false.
 silent := Smalltalk silentLoading:true.
+lazy := Compiler compileLazy:false.
 [
-temporaryMethod := cls compiler compile:sourceString
+	temporaryMethod := cls compiler compile:sourceString
-forClass:cls
+				       forClass:cls
-inCategory:(self category)
+				     inCategory:(self category)
-notifying:nil
+				      notifying:nil
-install:false.
+					install:false.
 ] valueNowOrOnUnwindDo:[
-Class updateChanges:upd.
+	Class updateChanges:upd.
-Smalltalk silentLoading:silent.
+	Compiler compileLazy:lazy.
+	Smalltalk silentLoading:silent.
 ].
 (temporaryMethod isNil or:[temporaryMethod == #Error]) ifTrue:[
-'cannot generate bytecode (contains primitive code or error)' errorPrintNL.
+	'cannot generate bytecode (contains primitive code or error)' errorPrintNL.
 	^ nil.
 ].
 "
 try to save a bit of memory, by sharing the source (whatever it is)
 "
 (LargeInteger compiledMethodAt:#normalize) asByteCodeMethod
 (SmallInteger compiledMethodAt:#+) asByteCodeMethod
 "
 !
-storeBinaryDefinitionOn: stream manager: manager
+storeBinaryDefinitionOn:stream manager:manager
-"can only store bytecode - machine code is not storable.
+"only store bytecode-methods - machinecode methods are stored
+as class/selector pair and a lookup is done when restored.
 If the receiver method is a built-in (i.e. machine coded)
 method, a temporary interpreted byte code method is created,
 and its bytecode stored.
 This works only, if the source of the method is available and the
 method does not contain primitive code."
-|storedMethod|
+|storedMethod who|
 byteCode isNil ifTrue:[
-storedMethod := self asByteCodeMethod.
+	self code notNil ifTrue:[
-storedMethod isNil ifTrue:[
+	    (who := self who) notNil ifTrue:[
-self error:'store of built-in method failed'.
+		"
-^ nil
+		 machine code only - assume its a built-in method,
-].
+		 and store the class/selector information.
-^ storedMethod storeBinaryDefinitionOn:stream manager:manager
+		 The restored method may not be exactly the same ...
-].
+		"
-^ super storeBinaryDefinitionOn:stream manager:manager
+		manager putIdOf:(self class) on:stream.
+		stream nextPutByte:0.   "means built-in method"
+		manager putIdOf:(who at:1) on:stream.
+		manager putIdOf:(who at:2) on:stream.
+		^ self
+	    ]
+	].
+	storedMethod := self asByteCodeMethod.
+	storedMethod isNil ifTrue:[
+	    self error:'store of built-in method failed'.
+	    ^ nil
+	].
+	^ storedMethod storeBinaryDefinitionOn:stream manager:manager
+].
+manager putIdOf:(self class) on:stream.
+stream nextPutByte:1.       "means byte-coded method"
+self storeBinaryDefinitionBodyOn:stream manager:manager
+!
+readBinaryContentsFrom: stream manager: manager
+"tell the newly restored Font about restoration"
+self code notNil ifTrue:[
+	"built-in method - already complete"
+	^ self
+].
+^ super readBinaryContentsFrom: stream manager: manager
 ! !
-!Method methodsFor:'obsolete binary fileOut'!
-binaryFileOutLiteralsOn:aStream
-|index n|
-literals isNil ifTrue:[
-aStream nextPutAll:'0'.
-aStream nextPut:$!!.
-^ self
-].
-aStream nextPutAll:literals size printString.
-aStream nextPut:$!!.
-index := 1.
-literals do:[:lit |
-lit isNumber ifTrue:[
-lit storeOn:aStream
-] ifFalse:[
-((lit isKindOf:String) or:[lit isKindOf:Character]) ifTrue:[
-lit storeOn:aStream
-] ifFalse:[
-(lit isKindOf:Array) ifTrue:[
-aStream nextPut:$(.
-lit storeOn:aStream.
-aStream nextPut:$)
-] ifFalse:[
-lit isBehavior ifTrue:[
-aStream nextPutAll:'(Smalltalk at:#'.
-n := lit name.
-lit isMeta ifTrue:[
-n := (n copyTo:(n size - 5)) , ') class'
-] ifFalse:[
-n := n , ')'
-].
-aStream nextPutAll:n
-] ifFalse:[
-self error:('invalid literal ' , lit class name)
-]
-]
-]
-].
-aStream nextPut:$!!.
-index := index + 1
-]
-!
-binaryFileOutOn:aStream
-byteCode isNil ifTrue:[
-self notify:'no bytecodes to fileout'.
-^ self
-].
-self binaryFileOutLiteralsOn:aStream.
-flags storeOn:aStream.
-aStream nextPut:$!!.
-byteCode size storeOn:aStream.
-aStream nextPut:$!!.
-aStream nextPutBytes:(byteCode size) from:byteCode
-! !

changeset 159	514c749165c3
parent 142	c7844287bddf
child 176	48061f8659aa