!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: excepti.gs,v 1.10.2.4 2008-03-04 19:03:19 dhenrich Exp $
!
! Superclass Hierarchy:
!   Exception, Object.
!
!=========================================================================

removeallmethods Exception
removeallclassmethods Exception

category: 'For Documentation Installation only'
classmethod: Exception
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'An Exception is an object that represents a state to be invoked in the event
 of an error.'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The next exception to be invoked, if this exception is part of a chain.'.
doc documentInstVar: #next with: txt.

txt := (GsDocText new) details:
'A SymbolDictionary (such as GemStoneError) that represents the category that
 this exception traps.  If nil, all errors are trapped.'.
  doc documentInstVar: #category with: txt.

txt := (GsDocText new) details:
'A value that controls which errors are trapped.  If it is nil, all errors in
 the specified category are trapped.  If it is a SmallInteger, the error with
 that number is trapped.

 The following errors can never be caught with an Exception and are always
 given back to the controlling GemBuilder for C (GCI) interface:

 * ErrorSymbols at: #rtErrStackLimit
 * ErrorSymbols at: #bkupErrRestoreSuccessful
 * ErrorSymbols at: #abortErrObjAuditFail
 * ErrorSymbols at: #rtErrHardBreak
 * ErrorSymbols at: #rtErrCommitAbortPending
 * ErrorSymbols at: #rtErrUncontinuable
 * ErrorSymbols at: #rtErrStep
 * ErrorSymbols at: #abortErrFinishedMark.

 The following errors can only be caught with an Exception that explicitly specifies
 the error number and category. If no error handler is specified or the error
 handlers are wildcard handlers (at least one of the category  or error number 
 is nil), the error is :given back to the controlling GemBuilder for C (GCI) interface:

 * ErrorSymbols at: #objErrDoesNotExist
 * ErrorSymbols at: #objErrCorruptObj
 * ErrorSymbols at: #clientForwarderSend
 * ErrorSymbols at: #rtErrGsProcessTerminated
 * ErrorSymbols at: #rtErrSignalAlmostOutOfMemory.'.

doc documentInstVar: #number with: txt.

txt := (GsDocText new) details:
'A four-argument block to be executed.  The arguments are:

 * exception, the exception whose block this is.
 * errorDictionary, an error dictionary, instance of SymbolDictionary,
                   such as GemStoneError.
 * number, the error number (a SmallInteger).
 * args, error arguments (normally an Array).'.
doc documentInstVar: #theBlock with: txt.

txt := (GsDocText new) details:
'A code for further differentiating within a category, used by the
 floating-point exception mechanism.'.
doc documentInstVar: #subtype with: txt.

self description: doc.
%
! fix 9150

category: 'Creation'
classmethod: Exception
block: aBlock category: aCategory number: num subtype: atype

"Create an Exception.  This creates an Exception but does not install it in
 the virtual machine.  The resulting exception could be chained to an already
 installed exception by using the result as the argument to next: sent to the
 already installed exception.  Otherwise this method is only useful by other
 methods within this class.

 The block passed will receive four arguments when it is invoked:

 1.  This exception
 2.  The category of the error
 3.  The number of the error
 4.  An Array of the arguments to the error.

 If aCategory is nil, all exception will be trapped by the block.  If aCategory
 is not nil, but num is nil, all exceptions within the given category will be
 trapped.

 The subtype field is for user convenience.  It is used by the Float exception
 mechanism to distinguish different types of floating-point exceptions."

^ self new block: aBlock category: aCategory number: num subtype: atype
%

category: 'Installing'
classmethod: Exception
installStaticException: aBlock
category: category
number: num
subtype: atype

"Install the specified exception block as a static exception block 
 to field errors of the specified category, number, and subtype."

|prev newException|
aBlock numberArgs ~~ 4 ifTrue: [
  ^ self _error: #rtErrExceptBlockNumArgs args: #[4, aBlock numberArgs].
  ].
newException := self new
    block: aBlock category: category number: num subtype: atype.
prev := self _staticExceptions.
newException next: prev.
self _staticException: newException.
^newException
%

category: 'Installing'
classmethod: Exception
installStaticException: aBlock
category: category
number: num

"Install the specified exception block as a static exception block 
 to field errors of the specified category and number."

^ self installStaticException: aBlock category: category number: num
                      subtype: nil
%

category: 'Installing'
classmethod: Exception
installDebugException: aBlock
category: category
number: num
subtype: atype

"Install the specified exception block as a debug exception block 
 to field errors of the specified category, number, and subtype.

 This method is intended for future use in implementing GemStone Smalltalk
 debuggers, and is not applicable to normal application programming."

|prev newException|

aBlock numberArgs ~~ 4 ifTrue: [
  ^ self _error: #rtErrExceptBlockNumArgs args: #[4, aBlock numberArgs].
  ].
newException := self new
    block: aBlock category: category number: num subtype: atype.
prev := self _debuggerExceptions.
newException next: prev.
self _debuggerException: newException.
^newException
%

! fix 7736 ; delete installActivationException

category: 'Installing'
classmethod: Exception
category: aCategory number: aNumber do: aBlock

"This method installs an exception for the top method or block context in the
 current GemStone Smalltalk call stack.  Returns the new exception.  The block
 aBlock receives four arguments when it is invoked:

 1.  This exception
 2.  The category of the error
 3.  The number of the error
 4.  An Array of the arguments to the error.

 If aCategory is nil, all exceptions are trapped by the block.  If aCategory is
 not nil, but aNumber is nil, all exceptions within the given category are
 trapped.

 This method must be a primitive, in order for the exception to be installed in
 the method or block context of the sender.

 The subtype of the new exception is nil."

<primitive: 376>
aCategory ~~ nil ifTrue:[ aCategory _validateClass: SymbolDictionary ] .
aNumber ~~ nil ifTrue:[ aNumber _validateClass: SmallInteger ] .
aBlock _validateClass: ExecutableBlock .
aBlock numberArgs == 4 ifFalse:[ 
  aBlock _error: #rtErrBadBlockArgCount args: #[ 4, aBlock numberArgs ] .
  ] .
^ self _primitiveFailed: #category:number:do:
%

category: 'Management'
classmethod: Exception
removeActivationException: anException

"Search the current GemStone Smalltalk call stack for a method or block context
 that has anException installed, and remove it.  The stack is searched by
 starting with the top method or block context and moving down.  Generates an
 error if anException is not installed anywhere in the current GemStone
 Smalltalk call stack."

^ anException _remove: anException
%

category: 'Management'
method: Exception
remove

"Search the current GemStone Smalltalk call stack for a method or block context
 that has the receiver installed, and remove it.  The stack is searched by
 starting with the top method or block context and moving down.  Generates an
 error if the receiver is not installed anywhere in the current GemStone
 Smalltalk call stack."

self _remove: self
%

category: 'Management'
method: Exception
_remove: anException

"Private."

"Search the current GemStone Smalltalk call stack for a method or block context
 that has the receiver installed, and remove it.  The stack is searched by
 starting with the top method or block context and moving down.  Generates an
 error if the receiver is not installed anywhere in the current GemStone
 Smalltalk call stack."

"Returns the receiver."

<primitive: 375>

anException _validateClass: Exception.
anException _error: #rtErrExceptionNotLinked args:  #() 
%

category: 'Management'
classmethod: Exception
_remove: anException getter: getter putter: putter

"Remove a linked exception from a linked list.  Since this is called to prevent
 recursive errors, any generated error causes a resignal."

|this prev|

this := getter value.
this == nil ifTrue:[ ^ self _error: #rtErrExceptionNotLinked args:  #()  ].

"Take care of head of list"
this == anException ifTrue: [
  putter value: this next.
  ^self].

"Somewhere in middle?"
prev := this.
this := this next.
[this == nil] whileFalse: [
  this == anException ifTrue: [
    prev next: this next.
    ^self].
  prev := this.
  this := this next.
  ].
^ self _error: #rtErrExceptionNotLinked args:  #() 
%

category: 'Management'
classmethod: Exception
removeStaticException: anException

"Unlink a static exception."

^ self _remove: anException
    getter: [self _staticExceptions]
    putter: [:x | self _staticException: x]
%

category: 'Management'
classmethod: Exception
removeDebugException: anException

"Unlink a debug exception.

 This method is intended for future use in implementing GemStone Smalltalk
 debuggers, and is not applicable to normal application programming."

^self _remove: anException
   getter: [self _debuggerExceptions]
   putter: [:x | self _debuggerException: x]
%

category: 'Support'
classmethod: Exception
_staticExceptions

"Returns the head of the static exception list."

<primitive: 377>
^ self _primitiveFailed: #_staticExceptions
%

!  fix bug 7596
category: 'Support'
classmethod: Exception
_staticException: aBlock

"Set the head of the static exception list.  Returns the previous head."

<primitive: 378>
aBlock _validateClass: BlockClosure.
^ self _primitiveFailed: #_staticException:
%

category: 'Support'
classmethod: Exception
_debuggerExceptions

"Returns the head of the debugger exception list."

<primitive: 379>

^ self _primitiveFailed: #_debuggerExceptions
%

category: 'Support'
classmethod: Exception
_debuggerExceptions: aBlock

"Set the head of the debugger exception list.  Returns the previous head."

<primitive: 380>

aBlock _validateClass: BlockClosure.
^ self _primitiveFailed: #_debuggerExceptions:
%

category: 'Support'
classmethod: Exception
_debuggerException: aBlock

"Set the head of the debugger exception list.  Returns the previous head."

<primitive: 380>

aBlock _validateClass: BlockClosure.
^ self _primitiveFailed: #_debuggerException:
%

category: 'Accessing'
method: Exception
next

"Returns the next exception to be invoked (the value of the next instance
 variable)."

^next
%

category: 'Accessing'
method: Exception
next: anException

"Establishes the next exception to be invoked (sets the value of the next
 instance variable)."

anException ~~ nil ifTrue:[
  (anException isKindOf: Exception) ifFalse:[
    anException _validateClass: Exception .
  ].
].
next := anException
%

category: 'Accessing'
method: Exception
subtype

"Returns the value of the receiver's subtype instance variable."

^subtype
%

category: 'Accessing'
method: Exception
category

"Returns the value of the instance variable 'category'."

^category
%

category: 'Accessing'
method: Exception
number

"Returns the value of the instance variable 'number'."

^number
%

category: 'Accessing'
method: Exception
block

"Returns the value of the instance variable 'theBlock'."

^ theBlock
%

category: 'Invocation'
classmethod: Exception
_exceptionFor: anInteger signalDictionary: aSymbolDictionary

"Find the first exception which can field the
 specified error.  Returns nil if no exception found."
 
 "Also Clears protected mode counter to zero."

<primitive: 140>

anInteger _validateClass: SmallInteger.
anInteger < 1 ifTrue: [ 
  ^System _error: #rtErrBadErr
            args: #[ anInteger, nil , aSymbolDictionary ]
  ].

aSymbolDictionary _validateClass: SymbolDictionary .

self _primitiveFailed: #_exceptionFor:signalDictionary: .
^ nil
%

category: 'Invocation'
method: Exception
_nextExceptionFor: anInteger signalDictionary: aSymbolDictionary

"Find the next exception after the receiver which can field the
 specified error.  Returns nil if no such exception found."

<primitive: 140>

anInteger _validateClass: SmallInteger.
anInteger < 1 ifTrue: [ ^System _error: #rtErrBadErr
                 args: #[ anInteger, nil, aSymbolDictionary]].

aSymbolDictionary _validateClass: SymbolDictionary .

self _primitiveFailed: #_exceptionFor:signalDictionary:
%

category: 'Invocation'
method: Exception
_signal: aSymbolDictionary number: anInteger args: anArray

"Invoke the receiver by sending its block the standard exception handler args.
 Returns the value returned by the block."

  ^ self block
      value: self
      value: aSymbolDictionary 
      value: anInteger
      value: anArray.
%

category: 'Invocation'
method: Exception
resignal: aSymbolDictionary number: errNum args: args

"Resignal this exception down the line, as it were.  If execution is continued
 after a successful resignal, returns the receiver."

| nextEx |

nextEx := self _nextExceptionFor: errNum 
		signalDictionary: aSymbolDictionary .
nextEx ~~ nil ifTrue:[
  ^ nextEx _signal: aSymbolDictionary 
	         number: errNum args: args .
  ] .
^ System _signalGciError: errNum args: args 
         signalDictionary: aSymbolDictionary
%

!gemstone64, add explicit constraint enforcement .
category: 'Creation'
method: Exception
block: aBlock category: aSymbolDictionary number: num subtype: atype

"Initialize the receiver using the arguments.
 The block passed will receive four arguments when it is invoked:

 1.  This exception.
 2.  The category (a SymbolDictionary) of the error.
 3.  The number of the error.
 4.  An Array of the arguments to the error.

 If aSymbolDictionary is nil, all exceptions will be trapped by the block.  
 If aSymbolDictionary is not nil, but num is nil, all exceptions within 
 the given category will be trapped.

 The subtype field is for user convenience.  It is used by the Float exception
 mechanism to distinguish different types of float exceptions."

(aBlock isKindOf:ExecutableBlock) ifFalse:[
  aBlock _errorExpectedClass: ExecutableBlock . 
  self _uncontinuableError 
  ].
theBlock := aBlock.
aBlock numberArgs ~~ 4 ifTrue: [
  ^ self _error: #rtErrExceptBlockNumArgs args: #[4, aBlock numberArgs].
  ].
aSymbolDictionary ~~ nil ifTrue:[
  (aSymbolDictionary isKindOf: AbstractDictionary) ifFalse:[
    aSymbolDictionary _errorExpectedClass: ExecutableBlock .
    self _uncontinuableError
    ].
  ].
category := aSymbolDictionary.
num ~~ nil ifTrue:[
  num _isSmallInteger ifFalse:[
    num _errorExpectedClass: SmallInteger .
    self _uncontinuableError
    ].
  ].
number := num.
subtype := atype
%

