"
 COPYRIGHT (c) 1988 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 variableSubclass:#Context
       instanceVariableNames:'flags sender home receiver selector searchClass
                              lineNr retvalTemp handle'
       classVariableNames:''
       poolDictionaries:''
       category:'Kernel-Methods'
!

Context comment:'

COPYRIGHT (c) 1988 by Claus Gittinger
              All Rights Reserved

Context represents the stack context objects; each message send adds a context
to a chain, which can be traced back via the sender field. (The actual implementation
uses the machines stack for this, building real contexts when needed only).
For both method- and block-contexts, the layout is the same. For method contexts, the 
home-field is nil, while for blockcontexts the home-field is either the context of its
surrounding block (if its a nested block) or of its method. Contexts of cheap blocks do not
have a home context - their home field is also nil.

Warning: layout and size known by the compiler and runtime system - do not change.

$Header: /cvs/stx/stx/libbasic/Context.st,v 1.6 1993-12-11 00:45:34 claus Exp $
'!

!Context class methodsFor:'queries'!

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

    ^ true
! !

!Context methodsFor:'testing'!

isContext
    "return true, iff the receiver is a Context, false otherwise"

    ^ true
!

isBlockContext
    "return true, iff the receiver is a BlockContext, false otherwise"

    ^ false
! !

!Context methodsFor:'accessing'!

instVarAt:index
    "have to catch instVar access to retVal and handle - they are invalid"

    (index == 8) ifTrue:[^ nil].
    (index == 9) ifTrue:[^ nil].
    ^ super instVarAt:index
!

instVarAt:index put:value
    "have to catch instVar access to retVal and handle - they are invalid"

    (index == 8) ifTrue:[^ nil].
    (index == 9) ifTrue:[^ nil].
    ^ super instVarAt:index put:value
!

methodHome
    "return the method-home - for method contexts this is the receiver"

    ^ self
!

home
    "return the immediate home of the receiver.
     for block contexts, this is the methodcontext, where the block was created,
     for nested block contexts, its the surrounding blocks context.
     for method-contexts this is nil."

    ^ nil "home"
!

method
    "return the method which corresponds to the receiver"

    |c|

    c := self searchClass whichClassImplements:selector.
    c notNil ifTrue:[
        ^ c compiledMethodAt:selector
    ].
    ^ nil
!

sender
    "return the sender of the context"

    "this special test is for the very first context (startup-context)"
    (sender isNil or:[sender selector isNil]) ifTrue:[^ nil].

    ^ sender
!

receiver
    "return the receiver of the context"

    ^ receiver
!

searchClass
    "this is the class where the method-lookup started"

    searchClass notNil ifTrue:[^ searchClass].
    ^ receiver class
!

selector
    "return the selector of the context"

    ^ selector
!

nargs
    "return the number of arguments to the Block/Method"

%{  /* NOCONTEXT */

    RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NARG_SHIFT) & __NARG_MASK) );
%}
!

nvars
    "return the number of variables to the Block/Method"

%{  /* NOCONTEXT */

    RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NVAR_SHIFT) & __NVAR_MASK) );
%}
!

args
    "return an array filled with the arguments of this context"

    |newArray n "{ Class: SmallInteger }" |

    n := self nargs.
    newArray := Array new:n.
    1 to:n do:[:index |
        newArray at:index put:(self at:index)
    ].
    ^ newArray
!

argsAndVars
    "return an array filled with the arguments and variables of this context"

    |newArray mySize "{ Class: SmallInteger }" |

    mySize := self nargs + self nvars.
    newArray := Array new:mySize.
    1 to:mySize do:[:index |
        newArray at:index put:(self at:index)
    ].
    ^ newArray
!

argAt:n
    "return the n'th argument"

    ^ self at:n
!

argAt:n put:value
    "set the n'th argument - useful when the receiver should be restarted"

    ^ self at:n put:value
!

varAt:n
    "return the n'th local variable"

    ^ self at:(n + self nargs)
!

varAt:n put:value
    "set the n'th local variable - useful when the receiver should be restarted
     or resumed"

    self at:(n + self nargs) put:value
!

lineNumber
    "this returns the lineNumber within the methods source, where the context was
     interrupted or called another method. (currently, sometimes this information
     is not available - in this case 0 is returned)"

    ^ lineNr
! !

!Context methodsFor:'printing'!

argsPrintString
    |fullString n "{ Class: SmallInteger }" |

    fullString := ''.
    n := self nargs.
    1 to:n do:[:index |
        fullString := fullString , (' ' , (self at:index) printString)
    ].
    ^ fullString
!

printReceiver
    |implementorClass|

    (receiver class == SmallInteger "isKindOf:Number") ifTrue:[
        '(' print. receiver print. ') ' print
    ].
    receiver class name print.

    selector notNil ifTrue:[
        implementorClass := self searchClass whichClassImplements:selector.
        implementorClass notNil ifTrue: [
            (implementorClass ~= receiver class) ifTrue: [
                '>>>' print.
                implementorClass name print
            ]
        ] ifFalse:[
            '>>>**NONE**' print
        ]
    ]
!
    
receiverPrintString
    |newString receiverClassName implementorClass|

    receiverClassName := receiver class name.
    (receiver class == SmallInteger) ifTrue:[
        newString := '(' , receiver printString , ') ' , receiverClassName
    ] ifFalse:[
        newString := receiverClassName
    ].

    selector notNil ifTrue:[
        implementorClass := self searchClass whichClassImplements:selector.
        implementorClass notNil ifTrue: [
            (implementorClass ~~ receiver class) ifTrue: [
                newString := newString , '>>>',
                             implementorClass name printString
            ]
        ] ifFalse:[
            newString := newString , '>>>**NONE**'
        ]
    ].

    ^ newString
!
    
printString
    ^ self receiverPrintString , ' ' , self selector printString
!

displayString
    ^ self class name , '(' , self receiverPrintString , ' ' , self selector printString, ')'
!

printOn:aStream
    aStream nextPutAll:(self receiverPrintString).
    aStream space.
    self selector printOn:aStream
!

fullPrint
    self printReceiver.
    ' ' print.
    selector print.
    self size ~~ 0 ifTrue: [
        ' ' print.
        self argsPrintString print
    ].
    ' [' print. lineNr print. ']' printNewline
!

fullPrintOn:aStream
    aStream nextPutAll:self receiverPrintString.
    aStream space.
    aStream nextPutAll:selector printString.
    self size ~~ 0 ifTrue: [
        aStream space.
        aStream nextPutAll:self argsPrintString
    ]
!

debugPrint
    | n "{ Class: SmallInteger }" |

    'context ' print. self address printNewline.
    'receiver: ' print. receiver address printNewline.
    'selector: ' print. selector address printNewline.
    n := self size.
    n ~~ 0 ifTrue:[
        1 to:n do:[:index |
            'arg ' print. index print. '   : ' print.
             (self at:index) address printNewline
        ]
    ].
    '' printNewline
!

fullPrintString
    |aString|

    aString := self receiverPrintString , ' ' , selector printString.
    self size ~~ 0 ifTrue: [
        aString := aString , ' ' , (self argsPrintString)
    ].
    ^ aString
!

printAll
    |context|
    context := self.
    [context notNil] whileTrue: [
        context print.
        context := context sender
    ]
!

fullPrintAll
    |context|
    context := self.
    [context notNil] whileTrue: [
        context fullPrint.
        context := context sender
    ]
!

debugPrintAll
    |context|
    context := self.
    [context notNil] whileTrue:[
        context debugPrint.
        context := context sender
    ]
! !

!Context methodsFor:'non local control flow'!

restart
    "restart the receiver - i.e. the method is evaluated again.
     if the context to restart already died - do nothing"

    sender isNil ifTrue:[^ nil].
%{
    __RESUMECONTEXT(SND_COMMA self, RESTART_VALUE);

    /* when we reach here, something went wrong */
    printf("restart failed\n");
%}
.
    ^ nil
!

resume
    "resume the receiver with nil - i.e. return nil from the receiver.
     if the context to resume already died - do nothing"

    self resume:nil
!

resume:value
    "resume the receiver - i.e. return value from the receiver.
     if the context to resume already died - do nothing. No unwind
     blocks are evaluated (see unwind: in this class)."

    sender isNil ifTrue:[^ nil].
%{
    __RESUMECONTEXT(SND_COMMA self, value);

    /* when we reach here, something went wrong */
    printf("resume failed\n");
%}
.
    ^ nil
!

unwind
    "resume the receiver - i.e. return nil from the receiver.
     if the context to resume already died - do nothing.
     Evaluate all unwind-blocks as specified in Block>>valueNowOrOnUnwind:
     and Block>>valueOnUnwindDo: on the way."

    self unwind:nil
!

unwind:value
    "resume the receiver - i.e. return value from the receiver.
     if the context to resume already died - do nothing.
     Evaluate all unwind-blocks as specified in Block>>valueNowOrOnUnwind:
     and Block>>valueOnUnwindDo: on the way."

    |con sel|

    sender isNil ifTrue:[^ nil].

    "start with this context, moving up"
    con := thisContext.
    [con ~~ self] whileTrue:[
        con isBlockContext ifFalse:[
            "the way we find those unwind contexts seems kludgy ..."
            sel := con selector.
            ((sel == #valueNowOrOnUnwindDo:) or:[sel == #valueOnUnwindDo:]) ifTrue:[
                "... the way we evaluate the unwind blocks too"
                (con argAt:1) value
            ]
        ].
        con := con sender
    ].
    self resume:value
! !