.
"
COPYRIGHT (c) 1989 by Claus Gittinger
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
other person. No title to or ownership of the software is
hereby transferred.
"
CompiledCode subclass:#Method
instanceVariableNames:'source sourcePosition category package'
classVariableNames:'PrivateMethodSignal
LastFileReference LastSourceFileName
LastWhoClass'
poolDictionaries:''
category:'Kernel-Methods'
!
Method comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/Method.st,v 1.40 1995-08-08 00:47:31 claus Exp $
'!
!Method class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
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
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libbasic/Method.st,v 1.40 1995-08-08 00:47:31 claus Exp $
"
!
documentation
"
this class defines protocol for executable methods;
both compiled and interpreted methods are represented by this class.
Compiled methods have a non-nil code field, while interpreted methods have
a nil code field and non-nil byteCode field.
If there are both non-nil code and bytecode fields, the VM will execute
the machine-code of a method. If both are nil when executed, a noByteCode
message is sent by the VM to the method where a signal is raised.
The methods sourcecode is represented by source and sourcePosition:
- if sourcePosition is a Number, the source-field is the fileName and
sourcePosition is the character offset of the source-chunk in this source file.
- If sourcePosition is nil, the source is the string in the source field.
(an old version used ExternalString instances here, but that lead to
10000 additional little objects ...)
The flags field defines things like the number of method-locals,
method arguments and stack requirements (for interpreted methods).
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)
or the fileName where the source is found
sourcePosition <Integer> the position of the methods chunk in the file
category <Symbol> the methods category
package <Symbol> the package, in which the methods was defined
Class variables:
PrivateMethodSignal raised on privacy violation (see docu)
LastFileReference weak reference to the last sourceFile
LastSourceFileName to speedup source access via NFS
WARNING: layout known by compiler and runtime system - dont change
"
!
privacy
"
ST/X includes an EXPERIMENTAL implementation of method privacy.
Individual methods may be set to private or protected via the
#setPrivate and #setProtected messages. Also, categories may be
filedIn as a whole as private using #privateMethodsFor: or as
protected using #protectedMethodsFor: instead of the well known #methodsFor:.
The additional #publicMethodsFor: is for documentation purposes, and
is equivalent to #methodsFor: (also to support fileIn of ENVY methods).
Private methods may be executed only when called via a self or super-send
from the superclass, the class itself or subclasses.
Protected methods may not be called from subclasses.
When such a situation arises, the VM (runtime system) will raise the
PrivateMethodSignal exception (if nonNil), which usually brings you into the
debugger.
If PrivateMethodSignal is nil, the VM will not check for this, and
execution is as usual. (you may want to nil-it for production code,
and leave it non nil during development).
NOTICE: there is no (not yet ?) standard defined for method privacy,
however, the interface was designed to be somewhat ENVY compatible (from
what can be deduced by reading PD code).
Also, the usability of privacy is still to be tested.
This interface, the implementation and the rules for when a privacy viaolation
is reported may change (in case of some ANSI standard being defined).
Be warned and send me suggestions & critics (constructive ;-)
"
! !
!Method class methodsFor:'initialization'!
initialize
PrivateMethodSignal isNil ifTrue:[
"EXPERIMENTAL"
PrivateMethodSignal := ExecutionErrorSignal newSignalMayProceed:true.
PrivateMethodSignal nameClass:self message:#privateMethodSignal.
PrivateMethodSignal notifierString:'attempt to execute private/protected method'.
]
! !
!Method class methodsFor:'Signal constants'!
privateMethodSignal
"return the signal raised when a private/protected method is called
by some other object (i.e. not a self- or super send)"
^ PrivateMethodSignal
! !
!Method class methodsFor:'queries'!
isBuiltInClass
"this class is known by the run-time-system"
^ self == Method
!
maxNumberOfArguments
"this limit will be removed in one of the next versions ..."
^ 15 "cannot be easily changed"
! !
!Method methodsFor:'queries'!
isMethod
"return true, if the receiver is some kind of method;
true returned here - the method is redefined from Object."
^ true
! !
!Method methodsFor:'accessing'!
source
"return the sourcestring for the receiver"
|aStream fileName junk|
source notNil ifTrue:[
"
if sourcePosition is nonNil, its the fileName and
sourcePosition is the offset.
Otherwise, source is the real source
"
sourcePosition isNil ifTrue:[^ source].
"/
"/ original code:
"/
"/ aStream := Smalltalk systemFileStreamFor:('source/' , source).
"/ aStream notNil ifTrue:[
"/ aStream position:sourcePosition.
"/ junk := aStream nextChunk.
"/ aStream close
"/ ]
"/
"/ we keep the last source file open, because open/close
"/ operations maybe somewhat slow on NFS-mounted file systems
"/ Since the reference to the file is weak, it will be closed
"/ automatically if the file is not referenced for a while. Neat trick.
LastSourceFileName = source ifTrue:[
aStream := LastFileReference at:1.
].
aStream isNil ifTrue:[
fileName := Smalltalk getSourceFileName:source.
fileName isNil ifTrue:[
fileName := source
].
aStream := fileName asFilename readStream.
].
aStream notNil ifTrue:[
aStream position:sourcePosition.
junk := aStream nextChunk.
"
keep a weak reference - maybe its needed again soon ...
"
LastFileReference isNil ifTrue:[
LastFileReference := WeakArray new:1
].
LastFileReference at:1 put:aStream.
LastSourceFileName := source
]
].
^ junk
!
source:aString
"set the methods sourcestring"
source := aString.
sourcePosition := nil
!
sourceFilename
"return the sourcefilename if source is extern; nil otherwise"
sourcePosition notNil ifTrue:[^ source].
^ nil
!
sourcePosition
"return the sourceposition if source is extern; nil otherwise"
^ sourcePosition
!
sourceFilename:aFileName position:aNumber
"set the methods sourcefile/position"
source := aFileName.
sourcePosition := aNumber
!
comment
"return the methods comment.
This is done by searching for and returning the first comment
from the methods source (excluding any double-quotes).
Returns nil if there is no comment (or source is not available)."
|src stream|
src := self source.
src isNil ifTrue:[^ nil].
stream := ReadStream on:src.
(stream skipThrough:Character doubleQuote) isNil ifTrue:[^ nil].
^ stream upTo:Character doubleQuote.
"
(Method compiledMethodAt:#comment) comment
"
!
category
"return the methods category or nil"
^ category
!
category:aStringOrSymbol
"set the methods category"
category := aStringOrSymbol asSymbol
!
package
"return the package-symbol"
^ package
!
package:aSymbol
"set the package-symbol"
package := aSymbol
!
flags
"return the flags (number of method variables, stacksize etc.).
Dont depend on the values in the flag field - it may change
without notice."
^ flags
!
flags:newFlags
"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
]
!
setToPrivate
"set the flag bit stating that this method is private.
Execution of the receiver will only be allowed for self/super-sends from
the class, superclasses or subclasses (or via #perform).
If a private method is called by some other class, a runtime
error (PrivateMethodSignal) is raised.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
#ifdef F_PRIVATE
int f = _intVal(_INST(flags));
f = (f & ~F_CLASSPRIVATE) | F_PRIVATE;
_INST(flags) = _MKSMALLINT(f);
#endif
%}
!
setToProtected
"set the flag bit stating that this method is protected.
Execution of the receiver will only be allowed for self sends from
the class or superclasses. (or via #perform).
If a private method is called by some other class, a runtime
error (PrivateMethodSignal) is raised.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
#ifdef F_CLASSPRIVATE
int f = _intVal(_INST(flags));
f = (f & ~F_PRIVATE) | F_CLASSPRIVATE;
_INST(flags) = _MKSMALLINT(f);
#endif
%}
!
setToPublic
"clear any privacy of the receiver. The receiver may be executed by
any send. This is the default.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
int f = _intVal(_INST(flags));
#if F_PRIVATE
f = f & ~F_PRIVATE;
#endif
#if F_CLASSPRIVATE
f = f & ~F_CLASSPRIVATE;
#endif
_INST(flags) = _MKSMALLINT(f);
%}
!
isPrivate
"return true, if this is a private method.
Execution of private methods is only allowed via self/super sends
from superclasses, the class itself or subclasses.
If a private method is called by some other class, a runtime
error (PrivateMethodSignal) is raised.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
#ifdef F_PRIVATE
int f = _intVal(_INST(flags));
if (f & F_PRIVATE) {
RETURN (true);
}
#endif
%}.
^ false
!
isProtected
"return true, if this is a protected method.
Execution of protected methods is only allowed via self sends
from superclasses or the class itself.
If a protected method is called by some other class, a runtime
error (PrivateMethodSignal) is raised.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
#ifdef F_CLASSPRIVATE
int f = _intVal(_INST(flags));
if (f & F_CLASSPRIVATE) {
RETURN (true);
}
#endif
%}.
^ false
!
isPublic
"return true, if this is a public method - I.e. can be executed via any send.
This is the default.
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
%{ /* NOCONTEXT */
/* I made this a primitive to get the define constant from stc.h */
int f = _intVal(_INST(flags));
#ifdef F_PRIVATE
if (f & F_PRIVATE) {
RETURN (false);
}
#endif
#ifdef F_CLASSPRIVATE
if (f & F_CLASSPRIVATE) {
RETURN (false);
}
#endif
%}.
^ true
!
numberOfMethodArgs:aNumber
"currently, the number of arguments is NOT remembered in
methods, but this will be added soon to allow for more checking
in #perform:.
The limitation in the max. number of arguments is due to the
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 class maxNumberOfArguments printString ,
' method arguments').
^ 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) );
#endif
%}
!
numberOfMethodArgs
"return the number of arguments, the method expects."
%{ /* NOCONTEXT */
/* made this a primitive to get define in stc.h */
#ifdef F_NARGS
RETURN (_MKSMALLINT((_intVal(_INST(flags)) & F_NARGS) >> F_NARGSHIFT));
#endif
%}
.
"
The old implementation simply counted the arguments from
the methods source - new versions include this information
in the flag instVar, for more security in #perform:
"
^ self methodArgNames size
!
numberOfMethodVars:aNumber
"set the number of method variables - for use by compiler only.
WARNING: playing around here with incorrect values
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);
_INST(flags) = _MKSMALLINT(f);
}
%}
!
numberOfMethodVars
"return the number of method local variables.
Do not depend on the returned value - future optimizations
may change things here (i.e. when moving block-locals into
surrounding method for inlining).
- for debugging only."
%{ /* NOCONTEXT */
/* made this a primitive to get define in stc.h */
RETURN (_MKSMALLINT((_intVal(_INST(flags)) & F_NVARS) >> F_NVARSHIFT));
%}
!
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.
(if the runtime library was compiled with DEBUG,
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);
_INST(flags) = _MKSMALLINT(f);
}
%}
!
stackSize
"return the number of temporaries needed as stack in the context.
Do not depend on the returned value - future optimizations
may change things here.
- for debugging only."
%{ /* NOCONTEXT */
/* made this a primitive to get define in stc.h */
RETURN (_MKSMALLINT((_intVal(_INST(flags)) & F_NSTACK) >> F_NSTACKSHIFT));
%}
! !
!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.
Problem: this is heavily called for in the debugger to create
a readable context walkback. For unbound methods, it is
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 ?"
|classes cls sel|
"
very first, 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.
cls notNil ifTrue:[
sel := cls selectorAtMethod:self.
sel notNil ifTrue:[^ Array with:cls with: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 := aClass selectorAtMethod:self.
sel notNil ifTrue:[LastWhoClass := aClass name.
^ Array with:aClass with:sel].
].
LastWhoClass := nil.
classes do:[:aClass |
|sel|
sel := aClass class selectorAtMethod: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 allSubInstancesDo:[:someClass |
|sel|
sel := someClass selectorAtMethod: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.
See comment in who."
"based on who, which has been added for ST-80 compatibility"
|pair|
pair := self who.
pair notNil ifTrue:[^ pair at:1].
"
none found - sorry
"
^ nil
"
|m|
m := Object compiledMethodAt:#at:.
m containingClass
"
!
selector
"return the selector under which I am found in my containingClasses
method-table.
See comment in who."
"based on who, which has been added for ST-80 compatibility"
|pair|
pair := self who.
pair notNil ifTrue:[^ pair at:2].
"
none found - sorry
"
^ nil
"
|m|
m := Object compiledMethodAt:#at:.
m selector
"
!
parse:parseSelector return:accessSelector or:valueIfNoSource
"helper for methodArgNames, methodVarNames etc.
Get the source, let parser parse it using parseSelector,
return parser info using accessSelector"
|parser sourceString|
sourceString := self source.
sourceString notNil ifTrue:[
parser := Parser perform:parseSelector with:sourceString.
(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
^ parser perform:accessSelector
].
^ valueIfNoSource
!
methodArgNames
"return a collection with the methods argument names.
Uses Parser to parse methods source and extract the names."
^ self parse:#parseMethodSpecification: return:#methodArgs or:nil
"
(Method compiledMethodAt:#printOn:) methodArgNames
"
!
methodVarNames
"return a collection with the methods local-variable names.
Uses Parser to parse methods source and extract the names."
^ self parse:#parseMethodArgAndVarSpecification: return:#methodVars or:nil
"
(Method compiledMethodAt:#printOn:) methodVarNames
"
!
hasPrimitiveCode
"return true, if the method contains primitive code; false if not.
Uses Parser to parse methods source and get the information."
^ self parse:#parseMethod: return:#hasPrimitiveCode or:false
"
(Method compiledMethodAt:#hasPrimitiveCode) hasPrimitiveCode
(Object compiledMethodAt:#at:) hasPrimitiveCode
(Object compiledMethodAt:#basicAt:) hasPrimitiveCode
"
!
methodArgAndVarNames
"return a collection with the methods argument and variable names.
Uses Parser to parse methods source and extract the names."
|parser sourceString argNames varNames|
sourceString := self source.
sourceString notNil ifTrue:[
parser := Parser parseMethodArgAndVarSpecification:sourceString.
(parser isNil or:[parser == #Error]) ifTrue:[^ nil].
argNames := parser methodArgs.
varNames := parser methodVars.
argNames isNil ifTrue:[^ varNames].
varNames isNil ifTrue:[^ argNames].
^ (argNames , varNames)
].
^ nil
"
(Method compiledMethodAt:#printOn:) methodArgAndVarNames
"
!
methodComment
"return the methods first comment, nil if there is none.
This is a somewhat stupid implementation."
|text line nQuote index qIndex qIndex2 comment|
text := self source asCollectionOfLines.
(text size < 2) ifTrue:[^nil].
line := (text at:2).
nQuote := line occurrencesOf:(Character doubleQuote).
(nQuote == 2) ifTrue:[
qIndex := line indexOf:(Character doubleQuote).
qIndex2 := line indexOf:(Character doubleQuote) startingAt:(qIndex + 1).
^ line copyFrom:(qIndex + 1) to:(qIndex2 - 1)
].
(nQuote == 1) ifTrue:[
qIndex := line indexOf:(Character doubleQuote).
comment := line copyFrom:(qIndex + 1).
index := 3.
line := text at:index.
nQuote := line occurrencesOf:(Character doubleQuote).
[nQuote ~~ 1] whileTrue:[
comment := comment , Character cr asString , line withoutSpaces.
index := index + 1.
line := text at:index.
nQuote := line occurrencesOf:(Character doubleQuote)
].
qIndex := line indexOf:(Character doubleQuote).
^ comment , Character cr asString , (line copyTo:(qIndex - 1)) withoutSpaces
].
^ nil
"
(Method compiledMethodAt:#methodComment) methodComment
"
!
referencesGlobal:aGlobalSymbol
"return true, if this method references the global
bound to aGlobalSymbol."
literals isNil ifTrue:[^ false].
^ (literals identityIndexOf:aGlobalSymbol startingAt:1) ~~ 0
!
sends:aSelectorSymbol
"return true, if this method contains a message-send
with aSelectorSymbol as selector.
- due to the simple check in the literal array, also simple uses
of aSelectorSymbol as symbol will return true.
Should ask compiler, if there is really a send."
^ self referencesGlobal:aSelectorSymbol
!
isLazyMethod
"return true, if this is a lazy method.
False is returned here - this method is redefined in LazyMethod"
^ false
!
isWrapped
"return true, if this is a wrapper method.
False is returned here - this method is redefined in WrappedMethod"
^ false
!
wrapper
"only for wrapped methods: return the wrapper.
Thats the WrapperMethod which contains myself."
WrappedMethod allInstancesDo:[:m |
m originalMethod == self ifTrue:[^ m].
].
^ nil
!
isInvalid
"return true, if this method is not executable due to
a (re)-compilation error. (see comment in Method>>invalidCodeObject)"
|m|
m := Method compiledMethodAt:#invalidCodeObject.
(self code notNil and:[self code = m code]) ifTrue:[^ true].
(byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
m := Method compiledMethodAt:#uncompiledCodeObject.
(self code notNil and:[self code = m code]) ifTrue:[^ true].
(byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
m := Metaclass compiledMethodAt:#invalidCodeObject.
(self code notNil and:[self code = m code]) ifTrue:[^ true].
(byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
^ false
! !
!Method methodsFor:'error handling'!
invalidCodeObject
"this method is triggered by the interpreter when a nil or non method
is about to be executed.
In this case, the VM sends this to the bad method (the receiver).
Also, the Compiler creates methods with their code/bytecode set to
this method if - after a class change - a method cannot be compiled
and is therefore no longer executable (for example, after an instvar
has been removed, and a method still tries to access this instvar)
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
errorString:'invalid method - not executable'.
!
uncompiledCodeObject
"this method is invoked by methods which contain primitive code,
but have not been compiled to machine code (either due to an error
when compiling, or simply because no stc is available.
For those methods, the compiler generated a method object consisting
of the original source code, but with this methods machine/byte code.
Therefore, we patch (kludge) the lineNumber information, to show the
first line (instead of the real line below)"
thisContext setLineNumber:1.
^ InvalidCodeSignal
raiseRequestWith:self
errorString:'invalid method - not compiled'.
!
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
errorString:('method got ' , numberGiven printString ,
' args while ' , self numberOfMethodArgs printString , ' where expected')
!
privateMethodCalled
"this error is triggered, if a private or protected method is called from
outside.
If you continue in the debugger, the method will be called,
and further privacy exceptions will NOT be reported,
until any new method is compiled, or the privacy of any method changes,
or the caches are flushed.
(the reason is that after the continue, the method is enterred into the
calling cache, for which method privacy is not checked.
Any of the above actions flushes this cache and a privacy check
is performed again.)
Future versions may not enter private methods into the cache, to fix this
(unobvious) behavior. However, then you will get an exception for EVERY
call to a private method ...
Notice: method privacy is a nonstandard feature, not supported
by other smalltalk implementations and not specified in the ANSI spec.
This is EXPERIMENTAL - and being evaluated for usability.
It may change or even vanish (if it shows to be not useful)."
^ PrivateMethodSignal raise
! !
!Method methodsFor:'executing'!
valueWithReceiver:anObject arguments:argArray
"low level call of a methods code - BIG DANGER ALERT.
Perform the receiver-method on anObject as receiver and argArray as
arguments. This does NO message lookup at all and mimics a
traditional function call.
This method is provided for debugging- and breakpoint-support
(replacing a method by a stub and recalling the original), or to implement
experimental MI implementations - it is not for general use.
The receiver must be a method compiled in anObjects class or one of its
superclasses and also, the number of arguments given must match the methods
expectations -
- otherwise strange things (and also strange crashes) can occur.
The system is NOT always detecting a wrong method/receiver combination.
YOU HAVE BEEN WARNED."
^ self valueWithReceiver:anObject arguments:argArray selector:nil search:nil
!
valueWithReceiver:anObject arguments:argArray selector:aSymbol
"low level call of a methods code - BIG DANGER ALERT.
Perform the receiver-method on anObject as receiver and argArray as
arguments. This does NO message lookup at all and mimics a
traditional function call.
This method is provided for debugging- and breakpoint-support
(replacing a method by a stub and recalling the original), or to implement
experimental MI implementations - it is not for general use.
The receiver must be a method compiled in anObjects class or one of its
superclasses and also, the number of arguments given must match the methods
expectations -
- otherwise strange things (and also strange crashes) can occur.
The system is NOT always detecting a wrong method/receiver combination.
YOU HAVE BEEN WARNED."
^ self valueWithReceiver:anObject
arguments:argArray
selector:aSymbol
search:nil
sender:nil
!
valueWithReceiver:anObject arguments:argArray selector:aSymbol search:aClass
"low level call of a methods code - BIG DANGER ALERT.
Perform the receiver-method on anObject as receiver and argArray as
arguments. This does NO message lookup at all and mimics a
traditional function call.
This method is provided for debugging- and breakpoint-support
(replacing a method by a stub and recalling the original), or to implement
experimental MI implementations - it is not for general use.
The receiver must be a method compiled in anObjects class or one of its
superclasses and also, the number of arguments given must match the methods
expectations -
- otherwise strange things (and also strange crashes) can occur.
The system is NOT always detecting a wrong method/receiver combination.
YOU HAVE BEEN WARNED."
^ self valueWithReceiver:anObject
arguments:argArray
selector:aSymbol
search:nil
sender:nil
!
valueWithReceiver:anObject arguments:argArray selector:aSymbol search:aClass sender:virtualSender
"low level call of a methods code - BIG DANGER ALERT.
Perform the receiver-method on anObject as receiver and argArray as
arguments. This does NO message lookup at all and mimics a
traditional function call.
This method is provided for debugging- and breakpoint-support
(replacing a method by a stub and recalling the original), or to implement
experimental MI implementations - it is not for general use.
The receiver must be a method compiled in anObjects class or one of its
superclasses and also, the number of arguments given must match the methods
expectations -
- otherwise strange things (and also strange crashes) can occur.
The system is NOT always detecting a wrong method/receiver combination.
YOU HAVE BEEN WARNED."
%{
OBJFUNC code;
OBJ searchClass;
static struct inlineCache dummy = _DUMMYILC0;
int nargs;
OBJ *ap;
extern OBJ __interpret(), interpret();
if (__isArray(argArray)) {
nargs = _arraySize(argArray);
ap = _ArrayInstPtr(argArray)->a_element;
} else {
if (argArray == nil) {
nargs = 0;
} else
nargs = -1;
}
#ifdef F_NARGS
if (((_intVal(_INST(flags)) & F_NARGS) >> F_NARGSHIFT) == nargs)
#endif
{
code = _MethodInstPtr(self)->m_code;
if (aClass == nil) {
searchClass = dummy.ilc_class = __Class(anObject);
} else {
searchClass = dummy.ilc_class = aClass;
}
if (nargs <= 15) {
/*
* add virtual sender (unwinding) here later,
* to allow hiding contexts in lazy methods.
* (this is cosmetics only; therefore its done later)
*/
if (code) {
/* compiled code */
switch (nargs) {
case 0:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy) );
case 1:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0]) );
case 2:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
case 3:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
case 4:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
ap[0], ap[1], ap[2], ap[3]) );
case 5:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
ap[0], ap[1], ap[2], ap[3], ap[4]) );
case 6:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
case 7:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
case 8:
RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7]) );
case 9:
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]) );
case 10:
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[9]) );
case 11:
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[9], ap[10]) );
case 12:
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[9], ap[10], ap[11]) );
case 13:
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[9], ap[10], ap[11], ap[12]) );
case 14:
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[9], ap[10], ap[11], ap[12], ap[13]) );
case 15:
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[9], ap[10], ap[11], ap[12], ap[13], ap[14]) );
}
} else {
/* interpreted code */
#ifdef PASS_ARG_POINTER
RETURN ( __interpret(self, nargs, anObject, aSymbol, SND_COMMA searchClass, ap) );
#else
switch (nargs) {
case 0:
RETURN ( interpret(self, 0, anObject, aSymbol, SND_COMMA searchClass) );
case 1:
RETURN ( interpret(self, 1, anObject, aSymbol, SND_COMMA searchClass,
ap[0]) );
case 2:
RETURN ( interpret(self, 2, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1]) );
case 3:
RETURN ( interpret(self, 3, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2]) );
case 4:
RETURN ( interpret(self, 4, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3]) );
case 5:
RETURN ( interpret(self, 5, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4]) );
case 6:
RETURN ( interpret(self, 6, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
case 7:
RETURN ( interpret(self, 7, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
case 8:
RETURN ( interpret(self, 8, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7]) );
case 9:
RETURN ( interpret(self, 9, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7], ap[8]) );
case 10:
RETURN ( interpret(self, 10, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7], ap[8], ap[9]) );
case 11:
RETURN ( interpret(self, 11, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7], ap[8], ap[9], ap[10]) );
case 12:
RETURN ( interpret(self, 12, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7], ap[8], ap[9], ap[11]) );
case 13:
RETURN ( interpret(self, 13, anObject, aSymbol, SND_COMMA searchClass,
ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
ap[7], ap[8], ap[9], ap[11], ap[12]) );
case 14:
RETURN ( interpret(self, 14, anObject, aSymbol, SND_COMMA searchClass,
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]) );
case 15:
RETURN ( interpret(self, 15, anObject, aSymbol, SND_COMMA searchClass,
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]) );
}
#endif
}
}
}
%}
.
(argArray isMemberOf:Array) ifFalse:[
"
arguments must be either nil or an array
"
^ self badArgumentArray
].
(argArray size ~~ self numberOfMethodArgs) ifTrue:[
"
the method expects a different number of arguments
"
^ 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)
'the next example is a wrong one - which is detected by True's method ...'.
(True compiledMethodAt:#printString)
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
'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
'the next example is a wrong one - which is detected here ...'.
(Object compiledMethodAt:#printOn:)
valueWithReceiver:false arguments:nil
'the next example is a wrong one - which is detected here ...'.
(Object compiledMethodAt:#printOn:)
valueWithReceiver:false arguments:#()
"
! !
!Method methodsFor:'printing & storing'!
whoString
"return a string as className>>selector, if this is not an unbound
method. Otherwise return 'unbound'. Used with debugging."
|w|
w := self who.
w notNil ifTrue:[
^ (w at:1) name , '>>' , (w at:2)
].
^ 'unbound'
"
Method new whoString
(Method compiledMethodAt:#whoString) whoString
"
!
printOn:aStream
"put a printed representation of the receiver onto aStream.
Since methods do not store their class/selector, we have to search
for it here."
|classAndSelector m wrapped|
wrapped := false.
aStream nextPutAll:(self classNameWithArticle).
aStream nextPut:$(.
classAndSelector := self who.
classAndSelector isNil ifTrue:[
"
not anchored in any class.
check if wrapped (to be more informative in inspectors)
"
m := self wrapper.
m notNil ifTrue:[
classAndSelector := m who.
wrapped := true.
]
].
classAndSelector notNil ifTrue:[
(classAndSelector at:1) name printOn:aStream.
aStream nextPutAll:' '.
(classAndSelector at:2) printOn:aStream.
wrapped ifTrue:[
aStream nextPutAll:'; wrapped'
].
] ifFalse:[
"
sorry, a method which is nowhere anchored
"
aStream nextPutAll:'unbound'
].
aStream nextPut:$)
"
(Object compiledMethodAt:#at:) printOn:Transcript. Transcript cr.
(Object compiledMethodAt:#at:) copy printOn:Transcript. Transcript cr.
"
! !
!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
"if the receiver has no bytecodes, create & return a method having
the same semantics as the receiver, but uses interpreted bytecodes.
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 lazy|
byteCode notNil ifTrue:[
"
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.
^ nil
].
"
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.
[
|compiler|
compiler := cls compilerClass.
"/
"/ kludge - have to make ST/X's compiler protocol
"/ be compatible to ST-80's
"/
(compiler respondsTo:#compile:forClass:inCategory:notifying:install:skipIfSame:)
ifTrue:[
temporaryMethod := compiler
compile:sourceString
forClass:cls
inCategory:(self category)
notifying:nil
install:false.
] ifFalse:[
temporaryMethod := compiler new
compile:sourceString
in:cls
notifying:nil
ifFail:nil
].
] valueNowOrOnUnwindDo:[
Class updateChanges:upd.
Compiler compileLazy:lazy.
Smalltalk silentLoading:silent.
].
(temporaryMethod isNil or:[temporaryMethod == #Error]) ifTrue:[
'cannot generate bytecode (contains primitive code or error)' errorPrintNL.
^ nil.
].
"
try to save a bit of memory, by sharing the source (whatever it is)
"
temporaryMethod sourceFilename:source position:sourcePosition.
^ temporaryMethod
"
(LargeInteger compiledMethodAt:#normalize) asByteCodeMethod
(SmallInteger compiledMethodAt:#+) asByteCodeMethod
"
!
storeBinaryDefinitionOn:stream manager:manager
"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 who|
byteCode isNil ifTrue:[
self code notNil ifTrue:[
(who := self who) notNil ifTrue:[
"
machine code only - assume its a built-in method,
and store the class/selector information.
The restored method may not be exactly the same ...
"
manager putIdOfClass:(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 putIdOfClass:(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
! !