"======================================================================
|
|   ContextPart Method Definitions
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Paolo Bonzini.
|
| This file is part of the GNU Smalltalk class library.
|
| The GNU Smalltalk class library is free software; you can redistribute it
| and/or modify it under the terms of the GNU Lesser General Public License
| as published by the Free Software Foundation; either version 2.1, or (at
| your option) any later version.
| 
| The GNU Smalltalk class library is distributed in the hope that it will be
| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
| General Public License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LESSER.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"



Object variableSubclass: #ContextPart
       instanceVariableNames: 'parent ip sp receiver method '
       classVariableNames: 'UnwindPoints'
       poolDictionaries: ''
       category: 'Language-Implementation'
!

ContextPart comment: 
'My instances represent executing Smalltalk code, which represent the local
environment of executable code. They contain a stack and also provide some
methods that can be used in inspection or debugging.' !


!ContextPart class methodsFor: 'exception handling'!

backtrace
    "Print a backtrace from the caller to the bottom of the stack on the
     Transcript"
    thisContext parentContext backtraceOn: Transcript
!

backtraceOn: aStream
    "Print a backtrace from the caller to the bottom of the stack on aStream"
    thisContext parentContext backtraceOn: aStream
!

removeLastUnwindPoint
    "Private - Return and remove the last context marked as an unwind point,
     or our environment if the last unwind point belongs to another
     environment."

    | point environment |
    environment := thisContext environment.
    self unwindPoints isEmpty ifTrue: [ ^environment ].

    point := self unwindPoints removeLast.
    ^point value = environment
	ifTrue: [ point key ] ifFalse: [ environment ].
!

lastUnwindPoint
    "Private - Return the last context marked as an unwind point, or our en-
     vironment if the last unwind point belongs to another environment."

    | point environment |
    environment := thisContext environment.
    self unwindPoints isEmpty ifTrue: [ ^environment ].

    point := self unwindPoints at: self unwindPoints size.
    ^point value = environment
	ifTrue: [ point key ] ifFalse: [ environment ].
!

unwind
    "Return execution to the last context marked as an unwind point, returning
     nil on that stack."
    self unwind: nil
!

unwind: returnValue
    "Return execution to the last context marked as an unwind point, returning
     returnValue on that stack."
    | point |
    point := self removeLastUnwindPoint.
    point isProcess ifTrue: [
	Processor terminateActive
	"Bye bye, we never get past here."
    ].
    thisContext returnTo: point.
    ^returnValue
!

unwindPoints
    "Answer an OrderedCollection of contexts marked as unwind points."
    UnwindPoints isNil ifTrue: [ ^UnwindPoints := OrderedCollection new ].
    ^UnwindPoints
! !


!ContextPart methodsFor: 'printing'!

backtrace
    "Print a backtrace from the receiver to the bottom of the stack on the
     Transcript."
    self backtraceOn: Transcript
!

backtraceOn: aStream
    "Print a backtrace from the caller to the bottom of the stack on aStream."
    | ctx |
    ctx := self.
    [ ctx isNil or: [ ctx isEnvironment ] ] whileFalse: [
	ctx printOn: aStream.
	aStream nl.
	ctx := ctx parentContext
    ]
! !


!ContextPart methodsFor: 'accessing'!

client
    "Answer the client of this context, that is, the object that sent the
     message that created this context. Fail if the receiver has no parent"

    ^self parentContext receiver
!

environment
    "To create a valid execution environment for the interpreter even before
     it starts, GST creates a fake context whose selector is nil and which
     can be used as a marker for the current execution environment. This
     method answers that context.
     For processes, it answers the process block itself"
    | ctx next |
    ctx := self.
    [   next := ctx parentContext.
	ctx isEnvironment | next isNil
    ]   whileFalse: [ ctx := next ].

    ^ctx
!

initialIP
    "Answer the value of the instruction pointer when execution starts
     in the current context"
    ^0
!

isEnvironment
    "To create a valid execution environment for the interpreter even before
     it starts, GST creates a fake context whose selector is nil and which
     can be used as a marker for the current execution environment.  Answer
     whether the receiver is that kind of context."
    self subclassResponsibility
!

isProcess
    "Answer whether the receiver represents a process context, i.e. a context
     created by BlockClosure>>#newProcess. Such a context can be recognized
     because it has no parent but its flags are different from those of the
     contexts created by the VM's prepareExecutionEnvironment function."
    ^self parentContext isNil & self isEnvironment not
!

parentContext
    "Answer the context that called the receiver"
    ^parent
!

ip
    "Answer the current instruction pointer into the receiver"
    "This funny implementation thwarts the interpreter's optimizing effort"
    ^ip yourself
!

ip: newIP
    "Set the instruction pointer for the receiver"
    "Fixed typing isn't usually good, but this is too important"
    newIP isSmallInteger
	ifFalse: [ ^self error: 'invalid new ip' ].
    ip := newIP
!

size
    "Answer the number of valid fields for the receiver. Any read
     access from (self size + 1) to (self basicSize) has undefined
     results - even crashing"
    ^self sp
!

sp
    "Answer the current stack pointer into the receiver"
    "This funny implementation thwarts the interpreter's optimizing effort"
    ^sp yourself
!

validSize
    "Answer how many elements in the receiver should be inspected"
    ^self size
!

numArgs
    "Answer the number of arguments passed to the receiver"
    ^self method numArgs
!

numTemps
    "Answer the number of temporaries used by the receiver"
    ^self method numTemps
!

sp: newSP
    "Set the stack pointer for the receiver.  Storing into the stack pointer
     is a potentially dangerous thing, so this code tests that sp is
     effectively a number.  Also, since the newly accessible slots may have
     contained garbage, this method stores nil into any cells that become
     accessible as a result."

    newSP isSmallInteger ifFalse: [ ^self error: 'invalid new sp' ].
    newSP > sp ifFalse: [ sp := newSP ].

    sp + 1 to: newSP do: [ :i | self at: i put: nil ].
    sp := newSP
!

method
    "Return the CompiledMethod being executed"
    ^method
!

methodClass
    "Return the class in which the CompiledMethod being executed is defined"
    ^self method methodClass
!

isBlock
    "Answer whether the receiver is a block context"
    self subclassResponsibility
!

receiver
    "Return the receiver (self) for the method being executed"
    "This funny implementation thwarts the interpreter's optimizing effort"
    ^receiver yourself
!

selector
    "Return the selector for the method being executed"
    ^self method selector
!

home
    "Answer the MethodContext to which the receiver refers"
    self subclassResponsibility
! !


!ContextPart methodsFor: 'exception handling'!

mark
    "Add the receiver as a possible unwind point"
    ^self class unwindPoints addLast: self -> self environment
!

returnTo: aContext
    "Set the context to which the receiver will return"
    
    "Fixed typing isn't usually good, but this is too important"
    (aContext class superclass == ContextPart) & (aContext notNil)
	ifFalse: [ ^self error: 'invalid returning context' ].
    parent := aContext
!

unmark
    "Remove the receiver from the contexts to which an unwind operation
     might return"
    | index |
    index := self class unwindPoints findLast: [ :each | each key == self ].
    index = 0 ifTrue: [ ^self ].

    self class unwindPoints size to: index do: [ :i |
	self class unwindPoints removeLast
    ]
! !
