smalltalk: cannotReturn: stale-block detection + 5 tests

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)