"

 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:'InvalidReturnSignal'

       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 home method. 

    Contexts of cheap blocks do not have a home context - their home field is 

    also nil.

    Currently, contexts do not contain a reference to the method or block which

    created it - this is not needed for program execution, but could get the debugger

    somewhat into trouble: it has to search the class hierarchy for receiver/selector

    combinations to find the method. This usually works, but fails in case of methods

    which are not anchored in any class - especially leading to problems with wrapper-

    and lazy methods. Also, Method>>valueWithReceiver - type of invocations cannot

    be easily debugged.

    Therefore, the implementation will be changed in the near future, to include a

    field for the method/block, and set it in the VM during program execution.

    (there may be some small performance penalty for this, though).

    Notice: due to the compilation to machine code, methods and/or block do not

    always (actually: do seldom) contain bytecodes. Thus, there is no such concept

    as a bytecode p-counter. To support debugging, the linenumber within the

    original source is instead remembered when a send or loop entry is performed.

    Since linenumbers are not always sufficient for debugging (multiple sends in one

    line), this will be changed in future versions to a character offset, giving

    the position of the selector in the source.

    instance variables:

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

					    contains info about number of args, 

					    locals and temporaries.

	sender      <Context>               the 'calling / sending' context

	home        <Context>               the context, where this block was 

					    created, or nil if its a method context

					    There are also cheap blocks, which do

					    not need a reference to the home context,

					    for those, its nil too.

	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). Only the low 16bits

					     are valid.

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

					    (used in the VM as temporary)

	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.

    class variables:

	InvalidReturnSignal                 signal raised when a block tries

					    to return ('^') from a method context

					    which itself has already returned

					    (i.e. there is no place to return to)

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

"

! !

!Context class methodsFor:'initialization'!

initialize

    InvalidReturnSignal isNil ifTrue:[

	InvalidReturnSignal := ErrorSignal newSignalMayProceed:true.

	InvalidReturnSignal nameClass:self message:#invalidReturnSignal.

	InvalidReturnSignal notifierString:'invalid return; method cannot return twice'.

    ]

! !

!Context class methodsFor:'Signal constants'!

invalidReturnSignal

    "return the signal used when a method is tried to be returned twice

     or, when some dead context is unwound or restarted."

    ^ InvalidReturnSignal

! !

!Context class methodsFor:'queries'!

isBuiltInClass

    "this class & subclasses are known by the run-time-system"

    ^ true

! !

!Context methodsFor:'copying'!

deepCopy

    "raise an error - deepCopy is not allowed for contexts"

    ^ self deepCopyError

! !

!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 and same arguments to the same receiver before. 

     Used to detect recursive errors or recursive printing - for example."

    |c rec "numArgs" "{Class: SmallInteger }"|

    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 whichClassIncludesSelector:selector) == (self searchClass whichClassIncludesSelector:selector) ifTrue:[

	      c methodClass == self methodClass ifTrue:[

"/              "

"/               finally, look for different arguments

"/              "

"/              numArgs := self numArgs.

"/              1 to:numArgs do:[:argIndex |

"/                  (self argAt:argIndex) == (c argAt:argIndex) ifFalse:[^ false]

"/              ]. 

		^ 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' errorPrintNL.

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

    "

     the below cannot happen in normal circumstances

     (added to avoid recursive errors in case of a broken sender chain)

    "

    c isBehavior ifFalse:[

	'OOPS: non class in searchClass' errorPrintNL.

	'      selector: ' errorPrint. selector errorPrint.

	' receiver: ' errorPrint. receiver errorPrintNL.

	^ nil

    ].

    c := c whichClassIncludesSelector:selector.

    c notNil ifTrue:[

	^ c compiledMethodAt:selector

    ].

    "mhmh - seems to be a context for an unbound method;

     look in the senders context. Consider this a kludge.

     (maybe it was not too good of an idea to not keep the current

      method in the context ....

      future versions of ST/X's message lookup may store the method in

      the context.)

    "

    (sender notNil and:[sender selector startsWith:'valueWithReceiver:']) ifTrue:[

	^ sender receiver

    ].

    ^ nil

!

methodClass

    "return the class in which the method for which the receiver was created is."

    ^ self searchClass whichClassIncludesSelector:selector.

!

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

!

numArgs

    "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 numArgs - self nvars

!

args

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

    |n|

    n := self numArgs.

    ^ (Array new:n) replaceFrom:1 to:n with:self.

!

argsAndVars

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

    |n|

    n := self numArgs + self nvars.

    ^ (Array new:n) replaceFrom:1 to:n with:self.

!

vars 

    "return an array filled with the local variables of this context"

    |nonVars mySize|

    nonVars := self numArgs.

    mySize := self nvars.

    ^ (Array new:mySize) replaceFrom:1 to:mySize with:self startingAt:nonVars+1

!

temporaries 

    "return an array filled with the temporaries of this context"

    |nonTemps mySize|

    nonTemps := self numArgs + self nvars.

    mySize := self ntemp.

    ^ (Array new:mySize) replaceFrom:1 to:mySize with:self startingAt:nonTemps+1

!

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

!

varAt:n put:value

    "set the n'th local variable - useful when the receiver should be restarted

     or continued"

    self at:(n + self numArgs) 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 isNil ifTrue:[^ nil].

    ^ lineNr bitAnd:16rFFFF

!

setLineNumber:aNumber

    "private entry for uncompiledCodeObject ..."

    lineNr := aNumber

!

canReturn

    "return true, if the receiver allows returning through it.

     For normal method contexts, this returns true;

     for blocks, it (currently) always returns false.

     However, the system can be compiled (for production code), to create

     contexts which cannot be returned or restarted

     (except, if the method contains a returning block). 

     This saves some administrative work in every method

     invocation and makes overall execution faster. However, it limits

     the debugger, in that it cannot return from or restart those contexts.

     (unwinding and termination is not affected by this optimization)

     Currently, the system as delivered has this optimization disabled."

%{  /* NOCONTEXT */

    RETURN ( (_intVal(_INST(flags)) & __CANNOT_RETURN) ? false : true );

%}

! !

!Context methodsFor:'printing & storing'!

argsDisplayString

    |fullString n "{ Class: SmallInteger }" |

    fullString := ''.

    n := self numArgs.

    1 to:n do:[:index |

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

    ].

    ^ fullString

!

receiverPrintString

    "return a string describing the receiver of the context" 

    |receiverClass receiverClassName newString implementorClass|

    receiverClass := receiver class.

    receiverClassName := receiverClass name.

    (receiverClass == SmallInteger) ifTrue:[

	newString := '(' , receiver printString , ') ' , receiverClassName

    ] ifFalse:[

	newString := receiverClassName

    ].

    selector notNil ifTrue:[

"/        implementorClass := self searchClass whichClassIncludesSelector:selector.

	"

	 kludge to avoid slow search for containing class

	"

	selector ~~ #doIt ifTrue:[

	    implementorClass := self methodClass. 

	].

	implementorClass notNil ifTrue: [

	    (implementorClass ~~ receiverClass) ifTrue: [