smalltalk: cannotReturn: stale-block detection + 5 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
This commit is contained in:
@@ -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)))))
|
||||
|
||||
96
lib/smalltalk/tests/cannot_return.sx
Normal file
96
lib/smalltalk/tests/cannot_return.sx
Normal 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)
|
||||
Reference in New Issue
Block a user