smalltalk: Exception/on:do:/ensure:/ifCurtailed: + 15 tests

lib/smalltalk/eval.sx

@@ -440,8 +440,66 @@
       ((= selector "class") (st-class-ref "BlockClosure"))
       ((= selector "==") (= block (nth args 0)))
       ((= selector "printString") "a BlockClosure")
+      ;; Smalltalk exception machinery on top of SX guard/raise.
+      ((= selector "on:do:")
+        (st-block-on-do block (nth args 0) (nth args 1)))
+      ((= selector "ensure:")
+        (st-block-ensure block (nth args 0)))
+      ((= selector "ifCurtailed:")
+        (st-block-if-curtailed block (nth args 0)))
       (else :unhandled))))
 
+;; on: ExceptionClass do: aHandler — run the receiver block, catching
+;; raised st-instances whose class isKindOf: the given Exception class.
+;; Other raises propagate. The handler receives the caught exception.
+(define
+  st-block-on-do
+  (fn
+    (block exc-class-ref handler)
+    (let
+      ((target-name
+         (cond
+           ((st-class-ref? exc-class-ref) (get exc-class-ref :name))
+           (else "Exception"))))
+      (guard
+        (caught
+          ((and (st-instance? caught)
+                (st-class-inherits-from? (get caught :class) target-name))
+            (st-block-apply handler (list caught))))
+        (st-block-apply block (list))))))
+
+;; ensure: cleanup — run the receiver block, then run cleanup whether the
+;; receiver completed normally or raised. On raise, cleanup runs and the
+;; exception propagates. The side-effect predicate pattern lets cleanup
+;; run inside the guard clause without us needing to call (raise c)
+;; explicitly (which has issues in nested handlers).
+(define
+  st-block-ensure
+  (fn
+    (block cleanup)
+    (let ((result nil) (raised false))
+      (begin
+        (guard
+          (caught
+            ((begin
+               (set! raised true)
+               (st-block-apply cleanup (list))
+               false)
+              nil))
+          (set! result (st-block-apply block (list))))
+        (when (not raised) (st-block-apply cleanup (list)))
+        result))))
+
+;; ifCurtailed: cleanup — run cleanup ONLY if the receiver block raises.
+(define
+  st-block-if-curtailed
+  (fn
+    (block cleanup)
+    (guard
+      (caught
+        ((begin (st-block-apply cleanup (list)) false) nil))
+      (st-block-apply block (list)))))
+
 (define
   st-block-apply
   (fn
@@ -565,6 +623,31 @@
             (cond
               ((not (st-class-ref? arg)) false)
               (else (= target-cls (get arg :name))))))
+        ;; Smalltalk Exception system — `signal` raises the receiver via
+        ;; SX raise. The argument to signal: sets messageText.
+        ;; on:do: / ensure: / ifCurtailed: are implemented on BlockClosure
+        ;; in `st-block-dispatch`.
+        ((and (= selector "signal")
+              (st-instance? receiver)
+              (st-class-inherits-from? cls "Exception"))
+          (raise receiver))
+        ((and (= selector "signal:")
+              (st-instance? receiver)
+              (st-class-inherits-from? cls "Exception"))
+          (begin
+            (dict-set! (get receiver :ivars) "messageText" (nth args 0))
+            (raise receiver)))
+        ((and (= selector "signal")
+              (st-class-ref? receiver)
+              (st-class-inherits-from? (get receiver :name) "Exception"))
+          (raise (st-make-instance (get receiver :name))))
+        ((and (= selector "signal:")
+              (st-class-ref? receiver)
+              (st-class-inherits-from? (get receiver :name) "Exception"))
+          (let ((inst (st-make-instance (get receiver :name))))
+            (begin
+              (dict-set! (get inst :ivars) "messageText" (nth args 0))
+              (raise inst))))
         ;; Object>>becomeForward: aReceiver — one-way become. The receiver's
         ;; class and ivars are mutated in place to match the target. Every
         ;; existing reference to the receiver dict sees the new identity.