"

 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.

'!

!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

! !