smalltalk: non-local return via captured ^k + 14 nlr tests

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)))))))

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)

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.