"

 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*'

       poolDictionaries:''

       category:'Kernel-Methods'

!

Context comment:'

COPYRIGHT (c) 1988 by Claus Gittinger

              All Rights Reserved

'!

!Context class methodsFor:'documentation'!

copyright

"

 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.

"

!

version

"

"

!

documentation

"

    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 (i.e. the context of the block, in which the receiving

    block was created, 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.

    instance variables:

        flags       <SmallInteger>          - used by the VM; never touch.

                                              contains info about number of args, locals and

                                              temporaries.

        sender      <Context>               - the 'calling' context

        home        <Context>               - the context, where this block was created, or nil

        receiver    <Object>                - the receiver of this message

        selector    <Symbol>                - the selector of this message

        searchClass <Class>                 - the class, where the message lookup started

                                              (for super sends) or nil, for regular sends.

        lineNr      <SmallInteger>          - the position where the context left off

                                              (kind of p-counter)

        retValTemp  nil                     - temporary - always nil, when you see the context

        handle      *noObject*              - used by the VM; not accessable, not an object

        <indexed>                           - arguments of the send followed by

                                              locals of the method/block followed by

                                              temporaries

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

"

! !

!Context class methodsFor:'queries'!

isBuiltInClass

    "this class & subclasses are 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

! 

isRecursive

    "return true, if this context is one of a recursive send of the same

     selector to the same receiver before. 

     Used to detect recursive errors - for example."

    |c rec cls1 cls2|

    rec := 0.

    c := self sender.

    [c notNil] whileTrue:[

        ((c selector == selector) 

        and:[(c receiver == receiver)]) ifTrue:[

            "

             stupid: the current ST/X context does not include

             the method, but the class, in which the search started ...

            "

            (c searchClass whichClassImplements:selector) == (self searchClass whichClassImplements:selector) ifTrue:[

                ^ true

            ]

        ].

        c := c sender.

        "

         this special test was added to get out after a while

         if the sender chain is corrupt - this gives us at least

         a chance to find those errors.

        "

        rec := rec + 1.

        rec >= 100000 ifTrue:[

            'bad context chain' errorPrintNewline.

            ^ true

        ]

    ].

    ^ false

! !

!Context methodsFor:'accessing'!

instVarAt:index

    "have to catch instVar access to retVal and handle - they are invalid.

     Notice, that one of the next ST/X versions will get some syntactic

     extension to get this automatically)."

    (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.

     Notice, that one of the next ST/X versions will get some syntactic

     extension to get this automatically)."

    (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 for which the receiver was created.

     To save time during normal execution, this information is not held in the

     context, but computed here on request."

    |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);

     actually, its cosmetics, to avoid a visible nil>>nil context in the debugger."

"

    (sender isNil or:[sender selector isNil and:[sender sender isNil]]) ifTrue:[^ nil].

"

    ^ sender

!

receiver

    "return the receiver of the context"

    ^ receiver

!

searchClass

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

     for normal sends, it is nil (or sometimes the receivers class).

     For supersends, its the superclass of the one, in which the

     caller was defined."

    searchClass notNil ifTrue:[^ searchClass].

    ^ receiver class

!

selector

    "return the selector of the method for which the context was created"

    ^ 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 local variables of the Block/Method"

%{  /* NOCONTEXT */

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

%}

!

ntemp

    "return the number of temporary variables of the Block/Method.

     (for debugging only)"

    ^ self size - self nargs - self nvars

!

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 continued"

    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 & storing'!

argsDisplayString

    |fullString n "{ Class: SmallInteger }" |

    fullString := ''.

    n := self nargs.

    1 to:n do:[:index |

        fullString := fullString , (' ' , (self at:index) displayString)

    ].

    ^ fullString

!

printReceiver

    "print the receiver of the context - used for MiniDebugger only"

    |class implementorClass|

    class := receiver class.

    (class == SmallInteger) ifTrue:[

        '(' print. receiver print. ') ' print

    ].

    class name print.

    selector notNil ifTrue:[

        implementorClass := self searchClass whichClassImplements:selector.

        implementorClass notNil ifTrue: [

            (implementorClass ~= receiver class) ifTrue: [

                '>>>' print.

                implementorClass name print

            ]

        ] ifFalse:[

            self searchClass ~~ receiver class ifTrue:[

                '>>>' print. self searchClass name print

            ].

            '>>>**NONE**' print

        ]

    ]

!

fullPrint

    "print the receiver, selector and args of the context 

     - used for MiniDebuggers walkback print only"

    self printReceiver.

    ' ' print.

    selector print.

    self size ~~ 0 ifTrue: [

        ' ' print.

        self argsDisplayString print

    ].

    ' [' print. lineNr print. ']' printNewline

!

receiverPrintString

    "return a string describing the receiver of the context" 

    |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:[

            self searchClass ~~ receiver class ifTrue:[

                newString := newString , '>>>' , self searchClass name

            ].

            newString := newString , '>>>**NONE**'

        ]

    ].

    ^ newString

!

printString

    "return a string describing the context" 

    ^ self receiverPrintString , ' ' , self selector printString

!

displayString

    "return a string describing the context - for display in Inspector" 

    ^ self class name , '(' , self printString , ')'

!

printOn:aStream

    "append a printed description of the receiver onto aStream"

    aStream nextPutAll:(self receiverPrintString).

    aStream space.

    self selector printOn:aStream

!

fullPrintAll

    "print a full walkback starting at the receiver

     - for MiniDebugger only"

    |context|

    context := self.

    [context notNil] whileTrue: [

        context fullPrint.

        context := context sender

    ]

! !

!Context methodsFor:'error handling'!

invalidReturn:returnValue

    "this message is sent by the VM, when a methods context

     which has already returned is about to return again.

     (i.e. about to execute a return from an already returned

     comment out the error to get that (old) behavior

    " 

" "

" "

    ^ returnValue

! !

!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.

     LIMITATION: currently a context can only be restarted by

     the owning process - not from outside."

    sender isNil ifTrue:[^ nil].

%{

    __RESUMECONTEXT(SND_COMMA self, RESTART_VALUE);

    /* when we reach here, something went wrong */

%}

.

    'restart: context not on calling chain' errorPrintNewline.

    "

     debugging ...

    "

    self error:'restart: context not on calling chain'.

    ^ nil

!

return

    "return from this context with nil.

     NO unwind actions are performed.

     LIMITATION: currently a context can only be returned by

     the owning process - not from outside."

    self return:nil

!

return:value

    "return from this context as if it did a '^ value'.

     NO unwind actions are performed.

     LIMITATION: currently a context can only be returned by

     the owning process - not from outside."

    sender isNil ifTrue:[^ nil].

%{

    __RESUMECONTEXT(SND_COMMA self, value);