smalltalk: cannotReturn: stale-block detection + 5 tests

lib/smalltalk/eval.sx

@@ -17,12 +17,18 @@
 (define
   st-make-frame
   (fn
-    (self method-class parent return-k)
+    (self method-class parent return-k active-cell)
     {:self self
      :method-class method-class
      :locals {}
      :parent parent
-     :return-k return-k}))
+     :return-k return-k
+     ;; A small mutable dict shared between the method-frame and any
+     ;; block created in its scope. While the method is on the stack
+     ;; :active is true; once st-invoke finishes (normally or via the
+     ;; captured ^k) it flips to false. ^expr from a block whose
+     ;; active-cell is dead raises cannotReturn:.
+     :active-cell active-cell}))
 
 (define
   st-make-block
@@ -35,7 +41,10 @@
      :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))}))
+     :return-k (if (= frame nil) nil (get frame :return-k))
+     ;; Pair the captured ^k with the active-cell — invoking ^k after
+     ;; the originating method has returned must raise cannotReturn:.
+     :active-cell (if (= frame nil) nil (get frame :active-cell))}))
 
 (define
   st-block?
@@ -153,10 +162,19 @@
               (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
             ((= ty "return")
               (let ((v (smalltalk-eval-ast (get ast :expr) frame)))
-                (let ((k (get frame :return-k)))
+                (let
+                  ((k (get frame :return-k))
+                    (cell (get frame :active-cell)))
                   (cond
                     ((= k nil)
                       (error "smalltalk-eval-ast: return outside method context"))
+                    ((and (not (= cell nil))
+                          (not (get cell :active)))
+                      (error
+                        (str
+                          "BlockContext>>cannotReturn: — ^expr after the "
+                          "creating method has already returned (value was "
+                          v ")")))
                     (else (k v))))))
             ((= ty "block") (st-make-block ast frame))
             ((= ty "seq") (st-eval-seq (get ast :exprs) frame))
@@ -340,35 +358,43 @@
               (get method :selector)
               " expected " (len params) " got " (len args))))
         (else
-          (call/cc
-            (fn (k)
-              (let ((frame (st-make-frame receiver defining-class nil k)))
-                (begin
-                  ;; 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)))))))))
+          (let ((cell {:active true}))
+            (let
+              ((result
+                (call/cc
+                  (fn (k)
+                    (let ((frame (st-make-frame receiver defining-class nil k cell)))
+                      (begin
+                        ;; 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))))))
+              (begin
+                ;; Method invocation is finished — flip the cell so any block
+                ;; that captured this method's ^k can no longer return.
+                (dict-set! cell :active false)
+                result))))))))
 
 ;; ── Block dispatch ─────────────────────────────────────────────────────
 (define
@@ -423,7 +449,11 @@
                      env
                      ;; Use the block's captured ^k so `^expr` returns from
                      ;; the *creating* method, not whoever invoked the block.
-                     (get block :return-k))))
+                     (get block :return-k)
+                     ;; Same active-cell as the creating method's frame; if
+                     ;; the method has returned, ^expr through this frame
+                     ;; raises cannotReturn:.
+                     (get block :active-cell))))
             (begin
               (let ((i 0))
                 (begin
@@ -694,26 +724,35 @@
   smalltalk-eval
   (fn
     (src)
-    (call/cc
-      (fn (k)
-        (let
-          ((ast (st-parse-expr src))
-            (frame (st-make-frame nil nil nil k)))
-          (smalltalk-eval-ast ast frame))))))
+    (let ((cell {:active true}))
+      (let
+        ((result
+           (call/cc
+             (fn (k)
+               (let
+                 ((ast (st-parse-expr src))
+                   (frame (st-make-frame nil nil nil k cell)))
+                 (smalltalk-eval-ast ast frame))))))
+        (begin (dict-set! cell :active false) result)))))
 
 ;; Evaluate a sequence of statements at the top level.
 (define
   smalltalk-eval-program
   (fn
     (src)
-    (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)))))))
+    (let ((cell {:active true}))
+      (let
+        ((result
+           (call/cc
+             (fn (k)
+               (let
+                 ((ast (st-parse src))
+                   (frame (st-make-frame nil nil nil k cell)))
+                 (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)))))))
+        (begin (dict-set! cell :active false) result)))))

lib/smalltalk/tests/cannot_return.sx

@@ -0,0 +1,96 @@
+;; cannotReturn: tests — escape past a returned-from method must error.
+;;
+;; A block stored or invoked after its creating method has returned
+;; carries a stale ^k. Invoking ^expr through that k must raise (in real
+;; Smalltalk: BlockContext>>cannotReturn:; here: an SX error tagged
+;; with that selector). A normal value-returning block (no ^) is fine.
+
+(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)))
+
+;; helper: substring check on actual SX strings
+(define
+  str-contains?
+  (fn (s sub)
+    (let ((n (len s)) (m (len sub)) (i 0) (found false))
+      (begin
+        (define
+          sc-loop
+          (fn ()
+            (when
+              (and (not found) (<= (+ i m) n))
+              (cond
+                ((= (slice s i (+ i m)) sub) (set! found true))
+                (else (begin (set! i (+ i 1)) (sc-loop)))))))
+        (sc-loop)
+        found))))
+
+;; ── 1. Block kept past method return — invocation with ^ must fail ──
+(st-class-define! "BlockBox" "Object" (list "block"))
+(st-class-add-method! "BlockBox" "block:"
+  (st-parse-method "block: aBlock block := aBlock. ^ self"))
+(st-class-add-method! "BlockBox" "block"
+  (st-parse-method "block ^ block"))
+
+;; A method whose return-value is a block that does ^ inside.
+;; Once `escapingBlock` returns, its ^k is dead.
+(st-class-define! "Trapper" "Object" (list))
+(st-class-add-method! "Trapper" "stash"
+  (st-parse-method "stash | b | b := [^ #shouldNeverHappen]. ^ b"))
+
+(define stale-block-test
+  (guard
+    (c (true {:caught true :msg (str c)}))
+    (let ((b (evp "^ Trapper new stash")))
+      (begin
+        (st-block-apply b (list))
+        {:caught false :msg nil}))))
+
+(st-test
+  "invoking ^block from a returned method raises"
+  (get stale-block-test :caught)
+  true)
+
+(st-test
+  "error message mentions cannotReturn:"
+  (let ((m (get stale-block-test :msg)))
+    (or
+      (and (string? m) (> (len m) 0) (str-contains? m "cannotReturn"))
+      false))
+  true)
+
+;; ── 2. A normal (non-^) block survives just fine across methods ──
+(st-class-add-method! "Trapper" "stashAdder"
+  (st-parse-method "stashAdder ^ [:x | x + 100]"))
+
+(st-test
+  "non-^ block keeps working after creating method returns"
+  (let ((b (evp "^ Trapper new stashAdder")))
+    (st-block-apply b (list 5)))
+  105)
+
+;; ── 3. Active-cell threading: ^ from a block invoked synchronously inside
+;;     the creating method's own activation works fine.
+(st-class-add-method! "Trapper" "syncFlow"
+  (st-parse-method "syncFlow #(1 2 3) do: [:e | e = 2 ifTrue: [^ #foundTwo]]. ^ #notFound"))
+(st-test "synchronous ^ from block still works"
+  (str (evp "^ Trapper new syncFlow"))
+  "foundTwo")
+
+;; ── 4. Active-cell flips back to live for re-invocations ──
+;; Calling the same method twice creates two independent cells; the second
+;; call's block is fresh.
+(st-class-add-method! "Trapper" "secondOK"
+  (st-parse-method "secondOK ^ #ok"))
+(st-test "method called twice in sequence still works"
+  (let ((a (evp "^ Trapper new secondOK"))
+        (b (evp "^ Trapper new secondOK")))
+    (str (str a b)))
+  "okok")
+
+(list st-test-pass st-test-fail)

plans/smalltalk-on-sx.md

@@ -69,7 +69,7 @@ Core mapping:
 - [x] `BlockContext>>value`, `value:`, `value:value:`, `value:value:value:`, `value:value:value:value:`, `valueWithArguments:`. Implemented in `st-block-dispatch` + `st-block-apply` (eval iteration); pinned by 19 dedicated tests in `lib/smalltalk/tests/blocks.sx` covering arity through 4, valueWithArguments: with empty/non-empty arg arrays, closures over outer locals (read + mutate + later-mutation re-read), nested blocks, blocks as method arguments, `numArgs`, and `class`.
 - [x] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends. `st-block-while` re-evaluates the receiver cond each iteration; with-arg form runs body each iteration; without-arg form is a side-effect loop. Now returns `nil` per ANSI/Pharo. JIT intrinsification is a future Tier-1 optimization (already covered by the bytecode-expansion infra in MEMORY.md). 14 dedicated while-loop tests including 0-iteration, body-less variants, nested loops, captured locals (read + write), `^` short-circuit through the loop, and instance-state preservation across calls.
 - [x] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` / `ifFalse:ifTrue:` as block sends, plus `and:`/`or:` short-circuit, eager `&`/`|`, `not`. Implemented in `st-bool-send` (eval iteration); pinned by 24 tests in `lib/smalltalk/tests/conditional.sx` covering laziness of the non-taken branch, every keyword variant, return type generality, nested ifs, closures over outer locals, and an idiomatic `myMax:and:` method. Parser now also accepts a bare `|` as a binary selector (it was emitted by the tokenizer as `bar` and unhandled by `parse-binary-message`, which silently truncated `false | true` to `false`).
-- [ ] Escape past returned-from method raises `BlockContext>>cannotReturn:`
+- [x] Escape past returned-from method raises (the SX-level analogue of `BlockContext>>cannotReturn:`). Each method invocation allocates a small `:active-cell` `{:active true}` shared between the method-frame and any block created in its scope. `st-invoke` flips `:active false` after `call/cc` returns; `^expr` checks the captured frame's cell before invoking k and raises with a "BlockContext>>cannotReturn:" message if dead. Verified by `lib/smalltalk/tests/cannot_return.sx` (5 tests using SX `guard` to catch the raise). A normal value-returning block (no `^`) still survives across method boundaries.
 - [ ] Classic programs in `lib/smalltalk/tests/programs/`:
   - [ ] `eight-queens.st`
   - [ ] `quicksort.st`
@@ -108,6 +108,7 @@ Core mapping:
 
 _Newest first. Agent appends on every commit._
 
+- 2026-04-25: cannotReturn: implemented (`lib/smalltalk/tests/cannot_return.sx`, 5 tests). Each method-invocation gets an `{:active true}` cell shared with its blocks; `st-invoke` flips it on exit; `^expr` raises if the cell is dead. Tests use SX `guard` to catch the raise. Non-`^` blocks unaffected. 364/364 total.
 - 2026-04-25: `ifTrue:` / `ifFalse:` family pinned (`lib/smalltalk/tests/conditional.sx`, 24 tests) + parser fix: `|` is now accepted as a binary selector in expression position (tokenizer still emits it as `bar` for block param/temp delimiting; `parse-binary-message` accepts both). Caught by `false | true` truncating silently to `false`. 359/359 total.
 - 2026-04-25: `whileTrue:` / `whileFalse:` / no-arg variants pinned (`lib/smalltalk/tests/while.sx`, 14 tests). `st-block-while` returns nil per ANSI; behaviour verified under captured locals, nesting, early `^`, and zero/many iterations. 334/334 total.
 - 2026-04-25: BlockContext value family pinned (`lib/smalltalk/tests/blocks.sx`, 19 tests). Each value/valueN/valueWithArguments: variant verified plus closure semantics (read, write, later-mutation re-read), nested blocks, and block-as-arg. 320/320 total.