From c33d03d2a29e4839f9fb0e30a82d2289a813d0fc Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 03:40:01 +0000 Subject: [PATCH] smalltalk: non-local return via captured ^k + 14 nlr tests --- lib/smalltalk/eval.sx | 175 ++++++++++++++++++------------------- lib/smalltalk/tests/nlr.sx | 152 ++++++++++++++++++++++++++++++++ plans/smalltalk-on-sx.md | 5 +- 3 files changed, 240 insertions(+), 92 deletions(-) create mode 100644 lib/smalltalk/tests/nlr.sx diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx index 772c83c6..89f09383 100644 --- a/lib/smalltalk/eval.sx +++ b/lib/smalltalk/eval.sx @@ -1,28 +1,28 @@ ;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the ;; class table from runtime.sx; native receivers fall back to a primitive -;; method table. Non-local return is implemented via a sentinel marker; the -;; full continuation-based escape is the Phase 3 showcase. +;; method table. Non-local return is implemented via captured continuations: +;; each method invocation wraps its body in `call/cc`, the captured k is +;; stored on the frame as `:return-k`, and `^expr` invokes that k. Blocks +;; capture their creating method's k so `^` from inside a block returns +;; from the *creating* method, not the invoking one — this is Smalltalk's +;; non-local return, the headline of Phase 3. ;; ;; Frame: ;; {:self V ; receiver ;; :method-class N ; defining class of the executing method ;; :locals (mutable dict) ; param + temp bindings -;; :parent P} ; outer frame for blocks (nil for top-level) -;; -;; `smalltalk-eval-ast(ast, frame)` returns the value or a return marker. -;; Method invocation unwraps return markers; sequences propagate them. +;; :parent P ; outer frame for blocks (nil for top-level) +;; :return-k K} ; the ^k that ^expr should invoke (define st-make-frame (fn - (self method-class parent) - {:self self :method-class method-class :locals {} :parent parent})) - -(define st-return-marker (fn (v) {:st-return true :value v})) - -(define - st-return-marker? - (fn (v) (and (dict? v) (has-key? v :st-return) (= (get v :st-return) true)))) + (self method-class parent return-k) + {:self self + :method-class method-class + :locals {} + :parent parent + :return-k return-k})) (define st-make-block @@ -32,7 +32,10 @@ :params (get ast :params) :temps (get ast :temps) :body (get ast :body) - :env frame})) + :env frame + ;; capture the creating method's return continuation so that `^expr` + ;; from inside this block always returns from that method + :return-k (if (= frame nil) nil (get frame :return-k))})) (define st-block? @@ -149,7 +152,12 @@ ((= ty "assign") (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame))) ((= ty "return") - (st-return-marker (smalltalk-eval-ast (get ast :expr) frame))) + (let ((v (smalltalk-eval-ast (get ast :expr) frame))) + (let ((k (get frame :return-k))) + (cond + ((= k nil) + (error "smalltalk-eval-ast: return outside method context")) + (else (k v)))))) ((= ty "block") (st-make-block ast frame)) ((= ty "seq") (st-eval-seq (get ast :exprs) frame)) ((= ty "send") @@ -157,43 +165,20 @@ ((= ty "cascade") (st-eval-cascade ast frame)) (else (error (str "smalltalk-eval-ast: unknown type '" ty "'"))))))))) +;; Evaluate a sequence; return the last expression's value. `^expr` +;; mid-sequence transfers control via the frame's :return-k and never +;; returns to this loop, so we don't need any return-marker plumbing. (define st-eval-seq (fn (exprs frame) (let ((result nil)) (begin - (define - sq-loop - (fn - (rest) - (cond - ((= (len rest) 0) nil) - (else - (let ((v (smalltalk-eval-ast (nth rest 0) frame))) - (cond - ((st-return-marker? v) (set! result v)) - ((= (len rest) 1) (set! result v)) - (else (sq-loop (rest-of rest))))))))) - (sq-loop exprs) + (for-each + (fn (e) (set! result (smalltalk-eval-ast e frame))) + exprs) result)))) -(define - rest-of - (fn - (lst) - (let ((out (list)) (i 1) (n (len lst))) - (begin - (define - ro-loop - (fn - () - (when - (< i n) - (begin (append! out (nth lst i)) (set! i (+ i 1)) (ro-loop))))) - (ro-loop) - out)))) - (define st-eval-send (fn @@ -333,6 +318,12 @@ (else p))))))))))))) ;; ── Method invocation ────────────────────────────────────────────────── +;; +;; Method body is wrapped in (call/cc (fn (k) ...)). The k is bound on the +;; method's frame as :return-k. `^expr` invokes k, which abandons the body +;; and resumes call/cc with v. Blocks that escape with `^` capture the +;; *creating* method's k, so non-local return reaches back through any +;; number of nested block.value calls. (define st-invoke (fn @@ -349,35 +340,35 @@ (get method :selector) " expected " (len params) " got " (len args)))) (else - (let - ((frame (st-make-frame receiver defining-class nil))) - (begin - ;; Bind params - (let ((i 0)) + (call/cc + (fn (k) + (let ((frame (st-make-frame receiver defining-class nil k))) (begin - (define - pb-loop - (fn - () - (when - (< i (len params)) - (begin - (dict-set! - (get frame :locals) - (nth params i) - (nth args i)) - (set! i (+ i 1)) - (pb-loop))))) - (pb-loop))) - ;; Bind temps to nil - (for-each - (fn (t) (dict-set! (get frame :locals) t nil)) - temps) - ;; Execute body - (let ((result (st-eval-seq body frame))) - (cond - ((st-return-marker? result) (get result :value)) - (else receiver)))))))))) + ;; Bind params + (let ((i 0)) + (begin + (define + pb-loop + (fn + () + (when + (< i (len params)) + (begin + (dict-set! + (get frame :locals) + (nth params i) + (nth args i)) + (set! i (+ i 1)) + (pb-loop))))) + (pb-loop))) + ;; Bind temps to nil + (for-each + (fn (t) (dict-set! (get frame :locals) t nil)) + temps) + ;; Execute body. If body finishes without ^, the implicit + ;; return value in Smalltalk is `self` — match that. + (st-eval-seq body frame) + receiver))))))))) ;; ── Block dispatch ───────────────────────────────────────────────────── (define @@ -429,7 +420,10 @@ ((frame (st-make-frame (if (= env nil) nil (get env :self)) (if (= env nil) nil (get env :method-class)) - env))) + env + ;; Use the block's captured ^k so `^expr` returns from + ;; the *creating* method, not whoever invoked the block. + (get block :return-k)))) (begin (let ((i 0)) (begin @@ -698,25 +692,26 @@ smalltalk-eval (fn (src) - (let - ((ast (st-parse-expr src)) - (frame (st-make-frame nil nil nil))) - (smalltalk-eval-ast ast frame)))) + (call/cc + (fn (k) + (let + ((ast (st-parse-expr src)) + (frame (st-make-frame nil nil nil k))) + (smalltalk-eval-ast ast frame)))))) ;; Evaluate a sequence of statements at the top level. (define smalltalk-eval-program (fn (src) - (let - ((ast (st-parse src)) (frame (st-make-frame nil nil nil))) - (begin - (when - (and (dict? ast) (has-key? ast :temps)) - (for-each - (fn (t) (dict-set! (get frame :locals) t nil)) - (get ast :temps))) - (let ((result (smalltalk-eval-ast ast frame))) - (cond - ((st-return-marker? result) (get result :value)) - (else result))))))) + (call/cc + (fn (k) + (let + ((ast (st-parse src)) (frame (st-make-frame nil nil nil k))) + (begin + (when + (and (dict? ast) (has-key? ast :temps)) + (for-each + (fn (t) (dict-set! (get frame :locals) t nil)) + (get ast :temps))) + (smalltalk-eval-ast ast frame))))))) diff --git a/lib/smalltalk/tests/nlr.sx b/lib/smalltalk/tests/nlr.sx new file mode 100644 index 00000000..e2214356 --- /dev/null +++ b/lib/smalltalk/tests/nlr.sx @@ -0,0 +1,152 @@ +;; Non-local return tests — the headline showcase. +;; +;; Method invocation captures `^k` via call/cc; blocks copy that k. `^expr` +;; from inside any nested block-of-block-of-block returns from the *creating* +;; method, abandoning whatever stack of invocations sits between. + +(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. Plain `^v` returns the value from a method ── +(st-class-define! "Plain" "Object" (list)) +(st-class-add-method! "Plain" "answer" + (st-parse-method "answer ^ 42")) +(st-class-add-method! "Plain" "fall" + (st-parse-method "fall 1. 2. 3")) + +(st-test "method returns explicit value" (evp "^ Plain new answer") 42) +;; A method without ^ returns self by Smalltalk convention. +(st-test "method without explicit return is self" + (st-instance? (evp "^ Plain new fall")) true) + +;; ── 2. `^v` from inside a block escapes the method ── +(st-class-define! "Searcher" "Object" (list)) +(st-class-add-method! "Searcher" "find:in:" + (st-parse-method + "find: target in: arr + arr do: [:e | e = target ifTrue: [^ true]]. + ^ false")) + +(st-test "early return from inside block" (evp "^ Searcher new find: 3 in: #(1 2 3 4)") true) +(st-test "no early return — falls through" (evp "^ Searcher new find: 99 in: #(1 2 3 4)") false) + +;; ── 3. Multi-level nested blocks ── +(st-class-add-method! "Searcher" "deep" + (st-parse-method + "deep + #(1 2 3) do: [:a | + #(10 20 30) do: [:b | + (a * b) > 50 ifTrue: [^ a -> b]]]. + ^ #notFound")) + +(st-test + "^ from doubly-nested block returns the right value" + (str (evp "^ (Searcher new deep) selector")) + "->") + +;; ── 4. Return value preserved through call/cc ── +(st-class-add-method! "Searcher" "findIndex:" + (st-parse-method + "findIndex: target + 1 to: 10 do: [:i | i = target ifTrue: [^ i]]. + ^ 0")) + +(st-test "to:do: + ^" (evp "^ Searcher new findIndex: 7") 7) +(st-test "to:do: no match" (evp "^ Searcher new findIndex: 99") 0) + +;; ── 5. ^ inside whileTrue: ── +(st-class-add-method! "Searcher" "countdown:" + (st-parse-method + "countdown: n + [n > 0] whileTrue: [ + n = 5 ifTrue: [^ #stoppedAtFive]. + n := n - 1]. + ^ #done")) + +(st-test "^ from whileTrue: body" + (str (evp "^ Searcher new countdown: 10")) + "stoppedAtFive") +(st-test "whileTrue: completes normally" + (str (evp "^ Searcher new countdown: 4")) + "done") + +;; ── 6. Returning blocks (escape from caller, not block-runner) ── +;; Critical test: a method that returns a block. Calling block elsewhere +;; should *not* escape this caller — the method has already returned. +;; Real Smalltalk raises BlockContext>>cannotReturn:, but we just need to +;; verify that *normal* (non-^) blocks behave correctly across method +;; boundaries — i.e., a value-returning block works post-method. +(st-class-add-method! "Searcher" "makeAdder:" + (st-parse-method "makeAdder: n ^ [:x | x + n]")) + +(st-test + "block returned by method still works (normal value, no ^)" + (evp "| add5 | add5 := Searcher new makeAdder: 5. ^ add5 value: 10") + 15) + +;; ── 7. `^` inside a block invoked by another method ── +;; Define `selectFrom:` that takes a block and applies it to each elem, +;; returning the first elem for which the block returns true. The block, +;; using `^`, can short-circuit *its caller* (not selectFrom:). +(st-class-define! "Helper" "Object" (list)) +(st-class-add-method! "Helper" "applyTo:" + (st-parse-method + "applyTo: aBlock + #(10 20 30) do: [:e | aBlock value: e]. + ^ #helperFinished")) + +(st-class-define! "Caller" "Object" (list)) +(st-class-add-method! "Caller" "go" + (st-parse-method + "go + Helper new applyTo: [:e | e = 20 ifTrue: [^ #foundInCaller]]. + ^ #didNotShortCircuit")) + +(st-test + "^ in block escapes the *creating* method (Caller>>go), not Helper>>applyTo:" + (str (evp "^ Caller new go")) + "foundInCaller") + +;; ── 8. Nested method invocation: outer should not be reached on inner ^ ── +(st-class-define! "Outer" "Object" (list)) +(st-class-add-method! "Outer" "outer" + (st-parse-method + "outer + Outer new inner. + ^ #outerFinished")) + +(st-class-add-method! "Outer" "inner" + (st-parse-method "inner ^ #innerReturned")) + +(st-test + "inner method's ^ returns from inner only — outer continues" + (str (evp "^ Outer new outer")) + "outerFinished") + +;; ── 9. Detect.first-style patterns ── +(st-class-define! "Detector" "Object" (list)) +(st-class-add-method! "Detector" "detect:in:" + (st-parse-method + "detect: pred in: arr + arr do: [:e | (pred value: e) ifTrue: [^ e]]. + ^ nil")) + +(st-test + "detect: finds first match via ^" + (evp "^ Detector new detect: [:x | x > 3] in: #(1 2 3 4 5)") + 4) + +(st-test + "detect: returns nil when none match" + (evp "^ Detector new detect: [:x | x > 100] in: #(1 2 3)") + nil) + +;; ── 10. ^ at top level returns from the program ── +(st-test "top-level ^v" (evp "1. ^ 99. 100") 99) + +(list st-test-pass st-test-fail) diff --git a/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index b45229a3..d9817d24 100644 --- a/plans/smalltalk-on-sx.md +++ b/plans/smalltalk-on-sx.md @@ -64,8 +64,8 @@ Core mapping: - [x] 30+ tests in `lib/smalltalk/tests/eval.sx` (60 tests, covering literals through user-class method dispatch with cascades and closures) ### Phase 3 — blocks + non-local return (THE SHOWCASE) -- [ ] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape -- [ ] `^expr` from inside a block invokes that captured `^k` +- [x] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape. `st-invoke` wraps body in `(call/cc (fn (k) ...))`; the frame's `:return-k` is set to k. Block creation copies `(get frame :return-k)` onto the block. Block invocation sets the new frame's `:return-k` to the block's saved one — so non-local return reaches *back through* any number of intermediate block invocations. +- [x] `^expr` from inside a block invokes that captured `^k`. The "return" AST type evaluates the expression then calls `(k v)` on the frame's :return-k. Verified: `detect:in:` style early-exit, multi-level nested blocks, ^ from inside `to:do:`/`whileTrue:`, ^ from a block passed to a *different* method (Caller→Helper) returns from Caller. - [ ] `BlockContext>>value`, `value:`, `value:value:`, …, `valueWithArguments:` - [ ] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends — runtime intrinsifies the loop in the bytecode JIT - [ ] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` as block sends, similarly intrinsified @@ -108,6 +108,7 @@ Core mapping: _Newest first. Agent appends on every commit._ +- 2026-04-25: **THE SHOWCASE** — non-local return via captured method-return continuations + 14 NLR tests (`lib/smalltalk/tests/nlr.sx`). `st-invoke` wraps body in `call/cc`; blocks copy creating method's `^k`; `^expr` invokes that k. Verified across nested blocks, `to:do:` / `whileTrue:`, blocks passed to different methods (Caller→Helper escapes back to Caller), inner-vs-outer method nesting. Sentinel-based return removed. 301/301 total. - 2026-04-25: `super` send + 9 tests (`lib/smalltalk/tests/super.sx`). `st-super-send` walks from defining-class's superclass; class-side aware; primitives → DNU fallback. Also fixed top-level `| temps |` parsing in `st-parse` (the absence of which was silently aborting earlier eval/dnu tests — counts go from 274 → 287, with previously-skipped tests now actually running). - 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.