From c444bbe2561e9bf5f6b67cdf2baf115fd4ba264e Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 05:11:14 +0000 Subject: [PATCH] smalltalk: cannotReturn: stale-block detection + 5 tests --- lib/smalltalk/eval.sx | 141 +++++++++++++++++---------- lib/smalltalk/tests/cannot_return.sx | 96 ++++++++++++++++++ plans/smalltalk-on-sx.md | 3 +- 3 files changed, 188 insertions(+), 52 deletions(-) create mode 100644 lib/smalltalk/tests/cannot_return.sx diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx index 56d69500..a18dd410 100644 --- a/lib/smalltalk/eval.sx +++ b/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))))) diff --git a/lib/smalltalk/tests/cannot_return.sx b/lib/smalltalk/tests/cannot_return.sx new file mode 100644 index 00000000..e48baf59 --- /dev/null +++ b/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) diff --git a/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index 982db049..34110bfe 100644 --- a/plans/smalltalk-on-sx.md +++ b/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.