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)

plans/smalltalk-on-sx.md

@@ -59,7 +59,7 @@ Core mapping:
 - [x] Class table + bootstrap (`lib/smalltalk/runtime.sx`): canonical hierarchy installed (`Object`, `Behavior`, `ClassDescription`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Magnitude`/`Number`/`Integer`/`SmallInteger`/`Float`/`Character`, `Collection`/`SequenceableCollection`/`ArrayedCollection`/`Array`/`String`/`Symbol`/`OrderedCollection`/`Dictionary`, `BlockClosure`). User class definition via `st-class-define!`, methods via `st-class-add-method!` (stamps `:defining-class` for super), method lookup walks chain, ivars accumulated through superclass chain, native SX value types map to Smalltalk classes via `st-class-of`.
 - [x] `smalltalk-eval-ast` (`lib/smalltalk/eval.sx`): all literal kinds, ident resolution (locals → ivars → class refs), self/super/thisContext, assignment (locals or ivars, mutating), message send, cascade, sequence, and ^return via a sentinel marker (proper continuation-based escape is the Phase 3 showcase). Frames carry a parent chain so blocks close over outer locals. Primitive method tables for SmallInteger/Float, String/Symbol, Boolean, UndefinedObject, Array, BlockClosure (value/value:/whileTrue:/etc.), and class-side `new`/`name`/etc. Also satisfies "30+ tests" — 60 eval tests.
 - [x] Method lookup: walk class → superclass already in `st-method-lookup-walk`; new cached wrapper `st-method-lookup` keys on `(class, selector, side)` and stores `:not-found` for negative results so DNU paths don't re-walk. Cache invalidates on `st-class-define!`, `st-class-add-method!`, `st-class-add-class-method!`, `st-class-remove-method!`, and full bootstrap. Stats helpers `st-method-cache-stats` / `st-method-cache-reset-stats!` for tests + later debugging.
-- [ ] `doesNotUnderstand:` fallback constructing `Message` object
+- [x] `doesNotUnderstand:` fallback. `Message` class added at bootstrap with `selector`/`arguments` ivars and accessor methods. Primitive senders (Number/String/Boolean/Nil/Array/BlockClosure/class-side) now return the `:unhandled` sentinel for unknown selectors; `st-send` builds a `Message` via `st-make-message` and routes through `st-dnu`, which looks up `doesNotUnderstand:` on the receiver's class chain (instance- or class-side as appropriate). User overrides intercept unknowns and see the symbol selector + arguments array in the Message.
 - [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class)
 - [x] 30+ tests in `lib/smalltalk/tests/eval.sx` (60 tests, covering literals through user-class method dispatch with cascades and closures)
 
@@ -108,6 +108,7 @@ Core mapping:
 
 _Newest first. Agent appends on every commit._
 
+- 2026-04-25: `doesNotUnderstand:` + 12 DNU tests (`lib/smalltalk/tests/dnu.sx`). Bootstrap installs `Message` (with selector/arguments accessors). Primitives signal `:unhandled` instead of erroring; `st-dnu` builds a Message and walks `doesNotUnderstand:` lookup. User Object DNU intercepts unknown sends to native receivers (Number, String, Block) too. 267/267 total.
 - 2026-04-25: method-lookup cache (`st-method-cache` keyed by `class|selector|side`, stores `:not-found` for misses). Invalidation on define/add/remove + bootstrap. `st-class-remove-method!` added. Stats helpers + 10 cache tests; 255/255 total.
 - 2026-04-25: `smalltalk-eval-ast` + 60 eval tests (`lib/smalltalk/eval.sx`, `lib/smalltalk/tests/eval.sx`). Frame chain with mutable locals/ivars (via `dict-set!`), full literal eval, send dispatch (user methods + native primitive tables for Number/String/Boolean/Nil/Array/Block/Class), block closures, while/to:do:, cascades returning last, sentinel-based `^return`. User Point class round-trip works including `+` returning a fresh point. 245/245 total.
 - 2026-04-25: class table + bootstrap (`lib/smalltalk/runtime.sx`, `lib/smalltalk/tests/runtime.sx`). Canonical hierarchy, type→class mapping for native SX values, instance construction, ivar inheritance, method install with `:defining-class` stamp, instance- and class-side method lookup walking the superclass chain. 54 new tests, 185/185 total.