From 45147bd8a6a7103c0f65cb9901ba4c0948565ba2 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 02:49:16 +0000 Subject: [PATCH] smalltalk: doesNotUnderstand: + Message + 12 tests --- lib/smalltalk/eval.sx | 67 ++++++++++++++++++----- lib/smalltalk/runtime.sx | 10 ++++ lib/smalltalk/tests/dnu.sx | 107 +++++++++++++++++++++++++++++++++++++ plans/smalltalk-on-sx.md | 3 +- 4 files changed, 172 insertions(+), 15 deletions(-) create mode 100644 lib/smalltalk/tests/dnu.sx diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx index 12fce9ef..d64d1e4c 100644 --- a/lib/smalltalk/eval.sx +++ b/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 diff --git a/lib/smalltalk/runtime.sx b/lib/smalltalk/runtime.sx index 9693be25..75d61884 100644 --- a/lib/smalltalk/runtime.sx +++ b/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. diff --git a/lib/smalltalk/tests/dnu.sx b/lib/smalltalk/tests/dnu.sx new file mode 100644 index 00000000..edcb4cd4 --- /dev/null +++ b/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) diff --git a/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index e732d93f..eb574756 100644 --- a/plans/smalltalk-on-sx.md +++ b/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.