rose-ash/lib/smalltalk/tests/nlr.sx

;; Non-local return tests — the headline showcase.
;;
;; Method invocation captures `^k` via call/cc; blocks copy that k. `^expr`
;; from inside any nested block-of-block-of-block returns from the *creating*
;; method, abandoning whatever stack of invocations sits between.

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

;; ── 1. Plain `^v` returns the value from a method ──
(st-class-define! "Plain" "Object" (list))
(st-class-add-method! "Plain" "answer"
  (st-parse-method "answer ^ 42"))
(st-class-add-method! "Plain" "fall"
  (st-parse-method "fall 1. 2. 3"))

(st-test "method returns explicit value" (evp "^ Plain new answer") 42)
;; A method without ^ returns self by Smalltalk convention.
(st-test "method without explicit return is self"
  (st-instance? (evp "^ Plain new fall")) true)

;; ── 2. `^v` from inside a block escapes the method ──
(st-class-define! "Searcher" "Object" (list))
(st-class-add-method! "Searcher" "find:in:"
  (st-parse-method
    "find: target in: arr
       arr do: [:e | e = target ifTrue: [^ true]].
       ^ false"))

(st-test "early return from inside block" (evp "^ Searcher new find: 3 in: #(1 2 3 4)") true)
(st-test "no early return — falls through" (evp "^ Searcher new find: 99 in: #(1 2 3 4)") false)

;; ── 3. Multi-level nested blocks ──
(st-class-add-method! "Searcher" "deep"
  (st-parse-method
    "deep
       #(1 2 3) do: [:a |
         #(10 20 30) do: [:b |
           (a * b) > 50 ifTrue: [^ a -> b]]].
       ^ #notFound"))

(st-test
  "^ from doubly-nested block returns the right value"
  (str (evp "^ (Searcher new deep) selector"))
  "->")

;; ── 4. Return value preserved through call/cc ──
(st-class-add-method! "Searcher" "findIndex:"
  (st-parse-method
    "findIndex: target
       1 to: 10 do: [:i | i = target ifTrue: [^ i]].
       ^ 0"))

(st-test "to:do: + ^" (evp "^ Searcher new findIndex: 7") 7)
(st-test "to:do: no match" (evp "^ Searcher new findIndex: 99") 0)

;; ── 5. ^ inside whileTrue: ──
(st-class-add-method! "Searcher" "countdown:"
  (st-parse-method
    "countdown: n
       [n > 0] whileTrue: [
         n = 5 ifTrue: [^ #stoppedAtFive].
         n := n - 1].
       ^ #done"))

(st-test "^ from whileTrue: body"
  (str (evp "^ Searcher new countdown: 10"))
  "stoppedAtFive")
(st-test "whileTrue: completes normally"
  (str (evp "^ Searcher new countdown: 4"))
  "done")

;; ── 6. Returning blocks (escape from caller, not block-runner) ──
;; Critical test: a method that returns a block. Calling block elsewhere
;; should *not* escape this caller — the method has already returned.
;; Real Smalltalk raises BlockContext>>cannotReturn:, but we just need to
;; verify that *normal* (non-^) blocks behave correctly across method
;; boundaries — i.e., a value-returning block works post-method.
(st-class-add-method! "Searcher" "makeAdder:"
  (st-parse-method "makeAdder: n ^ [:x | x + n]"))

(st-test
  "block returned by method still works (normal value, no ^)"
  (evp "| add5 | add5 := Searcher new makeAdder: 5. ^ add5 value: 10")
  15)

;; ── 7. `^` inside a block invoked by another method ──
;; Define `selectFrom:` that takes a block and applies it to each elem,
;; returning the first elem for which the block returns true. The block,
;; using `^`, can short-circuit *its caller* (not selectFrom:).
(st-class-define! "Helper" "Object" (list))
(st-class-add-method! "Helper" "applyTo:"
  (st-parse-method
    "applyTo: aBlock
       #(10 20 30) do: [:e | aBlock value: e].
       ^ #helperFinished"))

(st-class-define! "Caller" "Object" (list))
(st-class-add-method! "Caller" "go"
  (st-parse-method
    "go
       Helper new applyTo: [:e | e = 20 ifTrue: [^ #foundInCaller]].
       ^ #didNotShortCircuit"))

(st-test
  "^ in block escapes the *creating* method (Caller>>go), not Helper>>applyTo:"
  (str (evp "^ Caller new go"))
  "foundInCaller")

;; ── 8. Nested method invocation: outer should not be reached on inner ^ ──
(st-class-define! "Outer" "Object" (list))
(st-class-add-method! "Outer" "outer"
  (st-parse-method
    "outer
       Outer new inner.
       ^ #outerFinished"))

(st-class-add-method! "Outer" "inner"
  (st-parse-method "inner ^ #innerReturned"))

(st-test
  "inner method's ^ returns from inner only — outer continues"
  (str (evp "^ Outer new outer"))
  "outerFinished")

;; ── 9. Detect.first-style patterns ──
(st-class-define! "Detector" "Object" (list))
(st-class-add-method! "Detector" "detect:in:"
  (st-parse-method
    "detect: pred in: arr
       arr do: [:e | (pred value: e) ifTrue: [^ e]].
       ^ nil"))

(st-test
  "detect: finds first match via ^"
  (evp "^ Detector new detect: [:x | x > 3] in: #(1 2 3 4 5)")
  4)

(st-test
  "detect: returns nil when none match"
  (evp "^ Detector new detect: [:x | x > 100] in: #(1 2 3)")
  nil)

;; ── 10. ^ at top level returns from the program ──
(st-test "top-level ^v" (evp "1. ^ 99. 100") 99)

(list st-test-pass st-test-fail)