smalltalk: doesNotUnderstand: + Message + 12 tests

lib/smalltalk/eval.sx

@@ -244,8 +244,49 @@
           (cond
             ((not (= method nil))
               (st-invoke method receiver args))
-            ((st-block? receiver) (st-block-dispatch receiver selector args))
-            (else (st-primitive-send receiver selector args))))))))
+            ((st-block? receiver)
+              (let ((bd (st-block-dispatch receiver selector args)))
+                (cond
+                  ((= bd :unhandled) (st-dnu receiver selector args))
+                  (else bd))))
+            (else
+              (let ((primitive-result (st-primitive-send receiver selector args)))
+                (cond
+                  ((= primitive-result :unhandled)
+                    (st-dnu receiver selector args))
+                  (else primitive-result))))))))))
+
+;; Construct a Message object for doesNotUnderstand:.
+(define
+  st-make-message
+  (fn
+    (selector args)
+    (let ((msg (st-make-instance "Message")))
+      (begin
+        (dict-set! (get msg :ivars) "selector" (make-symbol selector))
+        (dict-set! (get msg :ivars) "arguments" args)
+        msg))))
+
+;; Trigger doesNotUnderstand:. If the receiver's class chain defines an
+;; override, invoke it with a freshly-built Message; otherwise raise.
+(define
+  st-dnu
+  (fn
+    (receiver selector args)
+    (let
+      ((cls (st-class-of-for-send receiver))
+        (class-side? (st-class-ref? receiver)))
+      (let
+        ((recv-class (if class-side? (get receiver :name) cls)))
+        (let
+          ((method (st-method-lookup recv-class "doesNotUnderstand:" class-side?)))
+          (cond
+            ((not (= method nil))
+              (let ((msg (st-make-message selector args)))
+                (st-invoke method receiver (list msg))))
+            (else
+              (error
+                (str "doesNotUnderstand: " recv-class " >> " selector)))))))))
 
 (define
   st-class-of-for-send
@@ -346,8 +387,7 @@
       ((= selector "class") (st-class-ref "BlockClosure"))
       ((= selector "==") (= block (nth args 0)))
       ((= selector "printString") "a BlockClosure")
-      (else
-        (error (str "BlockClosure doesNotUnderstand: " selector))))))
+      (else :unhandled))))
 
 (define
   st-block-apply
@@ -414,6 +454,8 @@
         last))))
 
 ;; ── Primitive method table for native receivers ────────────────────────
+;; Returns the result, or the sentinel :unhandled if no primitive matches —
+;; in which case st-send falls back to doesNotUnderstand:.
 (define
   st-primitive-send
   (fn
@@ -429,9 +471,7 @@
         ((= cls "UndefinedObject") (st-nil-send selector args))
         ((= cls "Array") (st-array-send receiver selector args))
         ((st-class-ref? receiver) (st-class-side-send receiver selector args))
-        (else
-          (error
-            (str "doesNotUnderstand: " cls " >> " selector)))))))
+        (else :unhandled)))))
 
 (define
   st-num-send
@@ -495,7 +535,7 @@
                     (tr-loop)))))
             (tr-loop)
             n)))
-      (else (error (str "doesNotUnderstand: Number >> " selector))))))
+      (else :unhandled))))
 
 (define
   st-string-send
@@ -516,7 +556,7 @@
       ((= selector "class") (st-class-ref (st-class-of s)))
       ((= selector "isNil") false)
       ((= selector "notNil") true)
-      (else (error (str "doesNotUnderstand: String >> " selector))))))
+      (else :unhandled))))
 
 (define
   st-bool-send
@@ -549,7 +589,7 @@
       ((= selector "class") (st-class-ref (if b "True" "False")))
       ((= selector "isNil") false)
       ((= selector "notNil") true)
-      (else (error (str "doesNotUnderstand: Boolean >> " selector))))))
+      (else :unhandled))))
 
 (define
   st-nil-send
@@ -567,7 +607,7 @@
       ((= selector "==") (= nil (nth args 0)))
       ((= selector "printString") "nil")
       ((= selector "class") (st-class-ref "UndefinedObject"))
-      (else (error (str "doesNotUnderstand: UndefinedObject >> " selector))))))
+      (else :unhandled))))
 
 (define
   st-array-send
@@ -609,7 +649,7 @@
       ((= selector "class") (st-class-ref "Array"))
       ((= selector "isNil") false)
       ((= selector "notNil") true)
-      (else (error (str "doesNotUnderstand: Array >> " selector))))))
+      (else :unhandled))))
 
 (define
   st-class-side-send
@@ -630,8 +670,7 @@
                                 (= name (get (nth args 0) :name))))
         ((= selector "isNil") false)
         ((= selector "notNil") true)
-        (else
-          (error (str "doesNotUnderstand: " name " class >> " selector)))))))
+        (else :unhandled)))))
 
 ;; Convenience: parse and evaluate a Smalltalk expression with no receiver.
 (define