"
 COPYRIGHT (c) 1989-93 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.
"

Object subclass:#Method
       instanceVariableNames:'code flags byteCode literals
                              source sourcePosition category'
       classVariableNames:''
       poolDictionaries:''
       category:'Kernel-Methods'
!

Method comment:'

COPYRIGHT (c) 1989-93 by Claus Gittinger
             All Rights Reserved

this class defines protocol for executable methods;
both compiled and interpreted methods are represented by this class.
Compiled code has a non-nil code field, while interpreted methods have
a nil code field and non-nil byteCode field.

The methods source-code 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.

The flags field defines things like the number of method-locals,
method arguments and stack size need (for interpreted methods).

WARNING: layout known by compiler and runtime system - dont change

$Header: /cvs/stx/stx/libbasic/Method.st,v 1.3 1993-10-13 00:16:33 claus Exp $
written spring 89 by claus
'!

!Method class methodsFor:'queries'!

isBuiltInClass
    "this class is known by the run-time-system"

    ^ self == Method
! !

!Method methodsFor:'accessing'!

instVarAt:index
    "redefined to catch access to code-field - it is a non-object"

    index == 1 ifTrue:[^ nil].
    ^ super instVarAt:index
!

instVarAt:index put:value
    "redefined to catch access to code-field - it is a non-object"

    index == 1 ifTrue:[^ nil].
    ^ super instVarAt:index put:value
!

code
    "return code field - since its a non-object return address as integer"
%{
    RETURN ( _MKSMALLINT((int)(_MethodInstPtr(self)->m_code)) );
%}
!

code:anAddress
    "set the code field - you should know what you do if doing this -
     should only be done by compiler.
     Smalltalk can crash badly if playing around here ..."
%{
    if (_isSmallInteger(anAddress)) {
        _MethodInstPtr(self)->m_code = (OBJFUNC)_intVal(anAddress);
        RETURN ( self );
    }
%}
.
    self primitiveFailed
!

source
    "return the sourcestring for the receiver"

    |aStream junk|

    source notNil ifTrue:[
        sourcePosition isNil ifTrue:[^ source].
        aStream := Smalltalk systemFileStreamFor:('source/' , source).
        aStream notNil ifTrue:[
            aStream position:sourcePosition.
            junk := aStream nextChunk.
            aStream close
        ]
    ].
    ^ 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
!

literals
    "return the methods literal array"

    ^ literals
!

literals:anArray
    "set the methods literal array"

    literals := anArray
!

byteCode
    "return the methods byteCode array"

    ^ byteCode
!

byteCode:aByteArray
    "set the methods byteCode array"

    byteCode := aByteArray
!

category
    "return the methods category or nil"

    ^ category
!

category:aStringOrSymbol
    "set the methods category"

    category := aStringOrSymbol asSymbol
!

flags
    "return the flags (number of method variables, stacksize)"

    ^ flags
!

flags:newFlags
    "set the flags (number of method variables, stacksize)
     - should only be done by the compiler"

    flags := newFlags
!

numberOfMethodVars:aNumber
    "set the number of method variables
     - should only be done by the compiler"

    |newFlags|

    newFlags := flags.
%{
    /* made this a primitive to get define in stc.h */
    newFlags = _MKSMALLINT((_intVal(newFlags) & ~F_NVARS)
                           | (_intVal(aNumber) << F_NVARSHIFT));
%}
.
    flags := newFlags
!

stackSize:aNumber
    "set the depth of the local stack
     - should only be done by the compiler"

    |newFlags|

    newFlags := flags.
%{
    /* made this a primitive to get define in stc.h */
    newFlags = _MKSMALLINT((_intVal(newFlags) & ~F_NSTACK) 
                           | (_intVal(aNumber) << F_NSTACKSHIFT));
%}
.
    flags := newFlags
! !

!Method methodsFor:'queries'!

containingClass
    "return the class I am defined in"

    Smalltalk allBehaviorsDo:[:aClass |
        (aClass containsMethod:self) ifTrue:[^ aClass]
    ].
    ^ nil
!

methodArgNames
    "return a collection with the methods argument names.
     Uses Parser to parse methods source."

    |parser sourceString|

    sourceString := self source.
    sourceString notNil ifTrue:[
        parser := Parser parseMethodSpecification:sourceString.
        parser isNil ifTrue:[^ nil].
        ^ parser methodArgs
    ].
    ^ nil

    "(Method compiledMethodAt:#printOn:) methodArgNames"
!

methodVarNames
    "return a collection with the methods local-variable names.
     Uses Parser to parse methods source."

    |parser sourceString|

    sourceString := self source.
    sourceString notNil ifTrue:[
        parser := Parser parseMethodArgAndVarSpecification:sourceString.
        parser isNil ifTrue:[^ nil].
        ^ parser methodVars
    ].
    ^ nil

    "(Method compiledMethodAt:#printOn:) methodVarNames"
!

methodArgAndVarNames
    "return a collection with the methods argument and variable names.
     Uses Parser to parse methods source."

    |parser sourceString argNames varNames|

    sourceString := self source.
    sourceString notNil ifTrue:[
        parser := Parser parseMethodArgAndVarSpecification:sourceString.
        parser isNil 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 comment, nil if there is none"

    |text line nQuote index qIndex qIndex2 comment|

    text := self source asText.
    (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."

    ^ self referencesGlobal:aSelectorSymbol
! !

!Method methodsFor:'error handling'!

invalidMethod
    "this error is triggered by the interpreter when an invalid method
     is about to be executed.
     When recompiling classes after a definition-change, all
     uncompilable methods will be bound to this method here,
     so that evaluating such an uncompilable method will trigger an error.
     Can also happen when Compiler/runtime system is broken."

    self error:'invalid method - not executable'
!

invalidByteCode
    "this error is triggered when the bytecode-interpreter tries to
     execute an invalid bytecode.
     Can only happen when Compiler/runtime system is broken."

    self error:'invalid byteCode in method - not executable'
!

receiverNotBoolean
    "this error is triggered when the bytecode-interpreter tries to
     execute ifTrue:/ifFalse or whileTrue: type of expressions where the
     receiver is neither true nor false."

    self error:'if/while on non-boolean receiver'
! !

!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;
     not for general use. The receiver must be a method compiled in
     anObjects class or one of its superclasses 
     - otherwise strange things (and also strange crashes) can occur. 
     Be warned."

    |a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12|

%{
    OBJFUNC code;
    OBJ searchClass;
    static struct inlineCache dummy = _DUMMYILC0;
    int nargs;
    OBJ *ap;

    if (_isArray(argArray)) {
        nargs = _arraySize(argArray);
	ap = _ArrayInstPtr(argArray)->a_element;
    } else {
	if (argArray == nil) {
	    nargs = 0;
	} else
	    nargs = -1;
    }

    code = _MethodInstPtr(self)->m_code;
    searchClass = dummy.ilc_class = _Class(anObject);
    switch (nargs) {
        case 0:
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy) );

        case 1:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1 );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0]) );
#endif

        case 2:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
#endif

        case 3:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
#endif

        case 4:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3]) );
#endif

        case 5:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4]) );
#endif

        case 6:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4], 
									   ap[5]) );
#endif

        case 7:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4], 
									   ap[5], ap[6]) );
#endif

        case 8:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            a8 = ap[7];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4], 
									   ap[5], ap[6], ap[7]) );
#endif

        case 9:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            a8 = ap[7];
            a9 = ap[8];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4], 
									   ap[5], ap[6], ap[7], ap[8]) );
#endif

        case 10:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            a8 = ap[7];
            a9 = ap[8];
            a10 = ap[9];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2], ap[3], ap[4], 
									   ap[5], ap[6], ap[7], ap[8], ap[9]) );
#endif

        case 11:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            a8 = ap[7];
            a9 = ap[8];
            a10 = ap[9];
            a11 = ap[10];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, 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]) );
#endif

        case 12:
#ifdef PASS_ARG_REF
            a1 = ap[0];
            a2 = ap[1];
            a3 = ap[2];
            a4 = ap[3];
            a5 = ap[4];
            a6 = ap[5];
            a7 = ap[6];
            a8 = ap[7];
            a9 = ap[8];
            a10 = ap[9];
            a11 = ap[10];
            a12 = ap[11];
            RETURN ( (*code)(anObject, nil, SND_COMMA searchClass, &dummy, &a1) );
#else
            RETURN ( (*code)(anObject, nil, 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]) );
#endif
    }
%}
.
    (argArray isMemberOf:Array) ifFalse:[
        ^ self error:'argumentArray must be an Array'
    ].
    ^ self error:'too many arguments'

    "(String compiledMethodAt:#print) valueWithReceiver:'hello' arguments:#()"
    "(Float compiledMethodAt:#+) valueWithReceiver:1.0 arguments:#(2.0)"
    "the next example is a wrong one - but will not crash the system ..."
    "(True compiledMethodAt:#printString) valueWithReceiver:false arguments:nil"
! !

!Method methodsFor:'printing'!

printOn:aStream
    "put a printed representation of the receiver onto aStream"

    |homeClass|

    homeClass := self containingClass.
    homeClass notNil ifTrue:[
        aStream nextPutAll:'a Method in '.
        homeClass name printOn:aStream.
        aStream nextPutAll:' '.
        (homeClass selectorForMethod:self) printOn:aStream
    ] ifFalse:[
        aStream nextPutAll:'a Method'
    ]
! !

!Method methodsFor:'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 isKindOf:Number) 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 "isKindOf:Class") ifTrue:[
                        aStream nextPutAll:'(Smalltalk at:#'.
                        n := lit name.
                        (lit isMeta "isKindOf:Metaclass") ifTrue:[
                            n := (n copyFrom:1 to:(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
! !