smalltalk: non-local return via captured ^k + 14 nlr tests

lib/smalltalk/tests/nlr.sx

@@ -0,0 +1,152 @@
+;; 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)