;; Inner-condition is really a standard class

(define-condition symbolic-smalltalk-condition (condition)
  ((inner-condition :initarg :inner-condition
                    :accessor inner-condition-of
                    :accessor #.(translate-selector-form "INNER-CONDITION" ))))

(define-condition symbolic-smalltalk-error (error symbolic-smalltalk-condition) ())
(define-condition symbolic-smalltalk-warning (warning symbolic-smalltalk-condition) ())
 
(defun symbolic-smalltalk-handler-case (inner-condition-class function handler)
  (let (condition)
    (tagbody
       (handler-bind ((symbolic-smalltalk-condition
                        (lambda (c)
                          ;; If inner-condition-class class matches,
                          ;; execute handler.
                          (when (typep (inner-condition-of c) inner-condition-class)
                            (setf condition c)
                            (go handler)))))
         (return-from symbolic-smalltalk-handler-case
           (funcall function)))
     handler
       (funcall handler condition))))

(defun symbolic-smalltalk-handler-bind (inner-condition-class function handler)
  (handler-bind ((symbolic-smalltalk-condition
                   (lambda (c)
                     ;; If inner-condition-class class matches,
                     ;; execute handler.                     
                     (when (typep (inner-condition-of c) inner-condition-class)
                       (funcall handler c)))))
    (return-from symbolic-smalltalk-handler-bind
      (funcall function))))

;; Example inner "condition" classes that should have a signal method
;; that does
;; (make-condition 'symbolic-smalltalk-condition :inner-condition ...)

[ Object :subclass 'condition/st ]
[ Condition/st :subclass 'error/st ]
[ Condition/st :subclass 'warning/st ]