coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

smalltalk: cannotReturn: stale-block detection + 5 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-25 05:11:14 +00:00
parent c7d0801850
commit c444bbe256
3 changed files with 188 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files

141
lib/smalltalk/eval.sx
View File

@@ -17,12 +17,18 @@
(define (define
st-make-frame st-make-frame
(fn (fn
(self method-class parent return-k) (self method-class parent return-k active-cell)
{:self self {:self self
:method-class method-class :method-class method-class
:locals {} :locals {}
:parent parent :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 (define
st-make-block st-make-block
@@ -35,7 +41,10 @@
:env frame :env frame
;; capture the creating method's return continuation so that `^expr` ;; capture the creating method's return continuation so that `^expr`
;; from inside this block always returns from that method ;; 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 (define
st-block? st-block?
@@ -153,10 +162,19 @@
(st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame))) (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
((= ty "return") ((= ty "return")
(let ((v (smalltalk-eval-ast (get ast :expr) frame))) (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 (cond
((= k nil) ((= k nil)
(error "smalltalk-eval-ast: return outside method context")) (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)))))) (else (k v))))))
((= ty "block") (st-make-block ast frame)) ((= ty "block") (st-make-block ast frame))
((= ty "seq") (st-eval-seq (get ast :exprs) frame)) ((= ty "seq") (st-eval-seq (get ast :exprs) frame))
@@ -340,35 +358,43 @@
(get method :selector) (get method :selector)
" expected " (len params) " got " (len args)))) " expected " (len params) " got " (len args))))
(else (else
(call/cc (let ((cell {:active true}))
(fn (k) (let
(let ((frame (st-make-frame receiver defining-class nil k))) ((result
(begin (call/cc
;; Bind params (fn (k)
(let ((i 0)) (let ((frame (st-make-frame receiver defining-class nil k cell)))
(begin (begin
(define ;; Bind params
pb-loop (let ((i 0))
(fn (begin
() (define
(when pb-loop
(< i (len params)) (fn
(begin ()
(dict-set! (when
(get frame :locals) (< i (len params))
(nth params i) (begin
(nth args i)) (dict-set!
(set! i (+ i 1)) (get frame :locals)
(pb-loop))))) (nth params i)
(pb-loop))) (nth args i))
;; Bind temps to nil (set! i (+ i 1))
(for-each (pb-loop)))))
(fn (t) (dict-set! (get frame :locals) t nil)) (pb-loop)))
temps) ;; Bind temps to nil
;; Execute body. If body finishes without ^, the implicit (for-each
;; return value in Smalltalk is `self` — match that. (fn (t) (dict-set! (get frame :locals) t nil))
(st-eval-seq body frame) temps)
receiver))))))))) ;; 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 ───────────────────────────────────────────────────── ;; ── Block dispatch ─────────────────────────────────────────────────────
(define (define
@@ -423,7 +449,11 @@
env env
;; Use the block's captured ^k so `^expr` returns from ;; Use the block's captured ^k so `^expr` returns from
;; the *creating* method, not whoever invoked the block. ;; 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 (begin
(let ((i 0)) (let ((i 0))
(begin (begin
@@ -694,26 +724,35 @@
smalltalk-eval smalltalk-eval
(fn (fn
(src) (src)
(call/cc (let ((cell {:active true}))
(fn (k) (let
(let ((result
((ast (st-parse-expr src)) (call/cc
(frame (st-make-frame nil nil nil k))) (fn (k)
(smalltalk-eval-ast ast frame)))))) (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. ;; Evaluate a sequence of statements at the top level.
(define (define
smalltalk-eval-program smalltalk-eval-program
(fn (fn
(src) (src)
(call/cc (let ((cell {:active true}))
(fn (k) (let
(let ((result
((ast (st-parse src)) (frame (st-make-frame nil nil nil k))) (call/cc
(begin (fn (k)
(when (let
(and (dict? ast) (has-key? ast :temps)) ((ast (st-parse src))
(for-each (frame (st-make-frame nil nil nil k cell)))
(fn (t) (dict-set! (get frame :locals) t nil)) (begin
(get ast :temps))) (when
(smalltalk-eval-ast ast frame))))))) (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)))))

96
lib/smalltalk/tests/cannot_return.sx Normal file
View File

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

3
plans/smalltalk-on-sx.md
View File

@@ -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] `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] `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`). - [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/`: - [ ] Classic programs in `lib/smalltalk/tests/programs/`:
- [ ] `eight-queens.st` - [ ] `eight-queens.st`
- [ ] `quicksort.st` - [ ] `quicksort.st`
@@ -108,6 +108,7 @@ Core mapping:
_Newest first. Agent appends on every commit._ _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: `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: `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. - 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.