;; Code from https://github.com/KenDickey/Crosstalk
;; Core Smalltalk in Scheme w unit tests

;; from "st-error-obj.scm"

(define Exception
  (newSubclassName:iVars:cVars:
   Object
   'Exception
   '(receiver messageText myTag
     signalContext resignalContext signalExn
     handlerContext retryContext blockSetter
     conditionDict)
   '())
)

; receiver -- nil or the receiver
; signalContext  -- Continuation captured at point of #signal 
; handlerContext -- Continuation captured at handler invocation in #on:do:
;                   See "st-blockClosure.scm"
; conditionDict -- nil or an IdentityDictionary/eqHashtable of condition values

;;; Exception>>doesNotUnderstand:
; Allow conditionDict identifiers as selectors to Exceptions
(addSelector:withMethod:
     Exception
     'doesNotUnderstand:
     (lambda (self aMessageSend)
       (let (  (condDict ($ self 'conditionDict))
               (selector ($ aMessageSend 'selector))
              )
         (if (and (hashtable? condDict)
                  (hashtable-contains? condDict selector))
             (hashtable-ref condDict selector st-nil)
             (@:  self 'doesNotUnderstand: aMessageSend)))) ;; super send
)

(addSelector:withMethod:
     Exception
     'signal
     (lambda (self)
       ($: self 'signalExn: self)
       (call/cc
        (lambda (resignal)
          ($: self 'resignalContext: resignal)))
        (call/cc
         (lambda (returnToSignal)
           ($: ($ self 'signalExn) 'signalContext: returnToSignal)
;;@@@DEBUG{
(when (debug-st-runtime)
  (format #t "~a" ($ ($ self 'signalExn) 'printString)))
;;@@@DEBUG}
             (raise-continuable ($ self 'signalExn))
	)))
)

;;.... from "st-blockClosure.scm"

;; NB: (Scm) raise is non-continuable and a caught exception
;;   will cause a "handler returned" exception.
;; Use (Scm) raise-continuable for on:to: to enable
;; the handler to return a value.

(addSelector:withMethod:
 	BlockClosure
        'on:do:
        (lambda (self exceptionClassOrSet handler)
          (let ( (protectedBlock self)
                 (retry #f)
               )
            (call/cc
             (lambda (return-from-on:do:)

               (with-exception-handler
                
                (lambda (exceptionOrCondition)
                  (let ( (anException ($ exceptionOrCondition 'asException)) )
                    ;; Note file "st-conditions.scm"
                    (if (not ($: exceptionClassOrSet 'handles: anException))
                        ;; re-raise if not handled here
                        (raise-continuable anException)
                        (begin  ;; the exception carries the context
                          ($: anException
                              'handlerContext:
                              return-from-on:do:)
                          ($: anException
                              'retryContext:
                              retry)
                          ($: anException
                              'blockSetter:
                              (lambda (aBlock) (set! protectedBlock aBlock)))
                          (return-from-on:do:
                           (if (= 1 (procedure-arity handler))
                               ;; valueWithPossibleArgument:
                               (handler anException)
                               (handler)))))))
 
                (lambda ()
                  (call/cc
                   (lambda (retry-again)
                     (set! retry retry-again)))
                  (protectedBlock))
 ) ) ) ) ) )

;;    signalContext handlerContext retryContext blockSetter


(addSelector:withMethod:
	BlockClosure
        'ifCurtailed:
        (lambda (self action)
          ;;  to class based system
          (let ( (curtailed? #t)
                 (result '()) )
            (dynamic-wind
              (lambda () #f) ;; before
              (lambda ()
                (set! result (self))
                (set! curtailed? #f))
              (lambda ()
                (if curtailed? (action))))
            result)
          ))

(addSelector:withMethod:
	BlockClosure
        'ifError:
        (lambda (self errorHandlerBlock)
          ($:: self
               'on:do:
               Error
               (lambda (ex)
                 ($:: errorHandlerBlock
                      'valueWithPossibleArgument:and:
                      ($ ex 'description)
                      ($ ex 'receiver)))
       ) )
)

;; --- E O F ---  ;;
