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

lib/smalltalk/runtime.sx

@@ -381,6 +381,16 @@
       (st-class-define! "Dictionary" "Collection" (list))
       ;; Blocks / contexts
       (st-class-define! "BlockClosure" "Object" (list))
+      ;; Reflection support — Message holds the selector/args for a DNU send.
+      (st-class-define! "Message" "Object" (list "selector" "arguments"))
+      (st-class-add-method! "Message" "selector"
+        (st-parse-method "selector ^ selector"))
+      (st-class-add-method! "Message" "arguments"
+        (st-parse-method "arguments ^ arguments"))
+      (st-class-add-method! "Message" "selector:"
+        (st-parse-method "selector: aSym selector := aSym"))
+      (st-class-add-method! "Message" "arguments:"
+        (st-parse-method "arguments: anArray arguments := anArray"))
       "ok")))
 
 ;; Initialise on load. Tests can re-bootstrap to reset state.

lib/smalltalk/tests/dnu.sx

@@ -0,0 +1,107 @@
+;; doesNotUnderstand: tests.
+
+(set! st-test-pass 0)
+(set! st-test-fail 0)
+(set! st-test-fails (list))
+
+(st-bootstrap-classes!)
+
+(define ev (fn (src) (smalltalk-eval src)))
+(define evp (fn (src) (smalltalk-eval-program src)))
+
+;; ── 1. Bootstrap installs Message class ──
+(st-test "Message exists in bootstrap" (st-class-exists? "Message") true)
+(st-test
+  "Message has expected ivars"
+  (sort (get (st-class-get "Message") :ivars))
+  (sort (list "selector" "arguments")))
+
+;; ── 2. Building a Message directly ──
+(define m (st-make-message "frob:" (list 1 2 3)))
+(st-test "make-message produces st-instance" (st-instance? m) true)
+(st-test "message class" (get m :class) "Message")
+(st-test "message selector ivar"
+  (str (get (get m :ivars) "selector"))
+  "frob:")
+(st-test "message arguments ivar" (get (get m :ivars) "arguments") (list 1 2 3))
+
+;; ── 3. User override of doesNotUnderstand: intercepts unknown sends ──
+(st-class-define! "Logger" "Object" (list "log"))
+(st-class-add-method! "Logger" "log"
+  (st-parse-method "log ^ log"))
+(st-class-add-method! "Logger" "init"
+  (st-parse-method "init log := nil. ^ self"))
+(st-class-add-method! "Logger" "doesNotUnderstand:"
+  (st-parse-method
+    "doesNotUnderstand: aMessage
+       log := aMessage selector.
+       ^ #handled"))
+
+(st-test
+  "user DNU intercepts unknown send"
+  (str
+    (evp "| l | l := Logger new init. l frobnicate. ^ l log"))
+  "frobnicate")
+
+(st-test
+  "user DNU returns its own value"
+  (str (evp "| l | l := Logger new init. ^ l frobnicate"))
+  "handled")
+
+;; Arguments are captured.
+(st-class-add-method! "Logger" "doesNotUnderstand:"
+  (st-parse-method
+    "doesNotUnderstand: aMessage
+       log := aMessage arguments.
+       ^ #handled"))
+
+(st-test
+  "user DNU sees args in Message"
+  (evp "| l | l := Logger new init. l zip: 1 zap: 2. ^ l log")
+  (list 1 2))
+
+;; ── 4. DNU on native receiver ─────────────────────────────────────────
+;; Adding doesNotUnderstand: on Object catches any-receiver sends.
+(st-class-add-method! "Object" "doesNotUnderstand:"
+  (st-parse-method
+    "doesNotUnderstand: aMessage ^ aMessage selector"))
+
+(st-test "Object DNU intercepts on SmallInteger"
+  (str (ev "42 frobnicate"))
+  "frobnicate")
+
+(st-test "Object DNU intercepts on String"
+  (str (ev "'hi' bogusmessage"))
+  "bogusmessage")
+
+(st-test "Object DNU sees arguments"
+  ;; Re-define Object DNU to return the args array.
+  (begin
+    (st-class-add-method! "Object" "doesNotUnderstand:"
+      (st-parse-method "doesNotUnderstand: aMessage ^ aMessage arguments"))
+    (ev "42 plop: 1 plop: 2"))
+  (list 1 2))
+
+;; ── 5. Subclass DNU overrides Object DNU ──────────────────────────────
+(st-class-define! "Proxy" "Object" (list))
+(st-class-add-method! "Proxy" "doesNotUnderstand:"
+  (st-parse-method "doesNotUnderstand: aMessage ^ #proxyHandled"))
+
+(st-test "subclass DNU wins over Object DNU"
+  (str (evp "^ Proxy new whatever"))
+  "proxyHandled")
+
+;; ── 6. Defined methods bypass DNU ─────────────────────────────────────
+(st-class-add-method! "Proxy" "known" (st-parse-method "known ^ 7"))
+(st-test "defined method wins over DNU"
+  (evp "^ Proxy new known")
+  7)
+
+;; ── 7. Block doesNotUnderstand: routes via Object ─────────────────────
+(st-class-add-method! "Object" "doesNotUnderstand:"
+  (st-parse-method "doesNotUnderstand: aMessage ^ #blockDnu"))
+(st-test "block unknown selector goes to DNU"
+  (str (ev "[1] frobnicate"))
+  "blockDnu")
+
+(list st-test-pass st-test-fail)