giles
f09a712666
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
93 lines
3.0 KiB
Plaintext
93 lines
3.0 KiB
Plaintext
;; BlockContext>>value family tests.
|
|
;;
|
|
;; The runtime already implements value, value:, value:value:, value:value:value:,
|
|
;; value:value:value:value:, and valueWithArguments: in st-block-dispatch.
|
|
;; This file pins each variant down with explicit tests + closure semantics.
|
|
|
|
(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. The value/valueN family ──
|
|
(st-test "value: zero-arg block" (ev "[42] value") 42)
|
|
(st-test "value: one-arg block" (ev "[:a | a + 1] value: 10") 11)
|
|
(st-test "value:value: two-arg" (ev "[:a :b | a * b] value: 3 value: 4") 12)
|
|
(st-test "value:value:value: three" (ev "[:a :b :c | a + b + c] value: 1 value: 2 value: 3") 6)
|
|
(st-test "value:value:value:value: four"
|
|
(ev "[:a :b :c :d | a + b + c + d] value: 1 value: 2 value: 3 value: 4") 10)
|
|
|
|
;; ── 2. valueWithArguments: ──
|
|
(st-test "valueWithArguments: zero-arg"
|
|
(ev "[99] valueWithArguments: #()") 99)
|
|
(st-test "valueWithArguments: one-arg"
|
|
(ev "[:x | x * x] valueWithArguments: #(7)") 49)
|
|
(st-test "valueWithArguments: many"
|
|
(ev "[:a :b :c | a , b , c] valueWithArguments: #('foo' '-' 'bar')") "foo-bar")
|
|
|
|
;; ── 3. Block returns last expression ──
|
|
(st-test "block last-expression result" (ev "[1. 2. 3] value") 3)
|
|
(st-test "block with temps initial state"
|
|
(ev "[| t u | t := 5. u := t * 2. u] value") 10)
|
|
|
|
;; ── 4. Closure over outer locals ──
|
|
(st-test
|
|
"block reads outer let temps"
|
|
(evp "| n | n := 5. ^ [n * n] value")
|
|
25)
|
|
(st-test
|
|
"block writes outer locals (mutating)"
|
|
(evp "| n | n := 10. [:x | n := n + x] value: 5. ^ n")
|
|
15)
|
|
|
|
;; ── 5. Block sees later mutation of captured local ──
|
|
(st-test
|
|
"block re-reads outer local on each invocation"
|
|
(evp
|
|
"| n b r1 r2 |
|
|
n := 1. b := [n].
|
|
r1 := b value.
|
|
n := 99.
|
|
r2 := b value.
|
|
^ r1 + r2")
|
|
100)
|
|
|
|
;; ── 6. Re-entrant invocations ──
|
|
(st-test
|
|
"calling same block twice independent results"
|
|
(evp
|
|
"| sq |
|
|
sq := [:x | x * x].
|
|
^ (sq value: 3) + (sq value: 4)")
|
|
25)
|
|
|
|
;; ── 7. Nested blocks ──
|
|
(st-test
|
|
"nested block closes over both scopes"
|
|
(evp
|
|
"| a |
|
|
a := [:x | [:y | x + y]].
|
|
^ ((a value: 10) value: 5)")
|
|
15)
|
|
|
|
;; ── 8. Block as method argument ──
|
|
(st-class-define! "BlockUser" "Object" (list))
|
|
(st-class-add-method! "BlockUser" "apply:to:"
|
|
(st-parse-method "apply: aBlock to: x ^ aBlock value: x"))
|
|
|
|
(st-test
|
|
"method invokes block argument"
|
|
(evp "^ BlockUser new apply: [:n | n * n] to: 9")
|
|
81)
|
|
|
|
;; ── 9. numArgs + class ──
|
|
(st-test "numArgs zero" (ev "[] numArgs") 0)
|
|
(st-test "numArgs three" (ev "[:a :b :c | a] numArgs") 3)
|
|
(st-test "block class is BlockClosure"
|
|
(str (ev "[1] class name")) "BlockClosure")
|
|
|
|
(list st-test-pass st-test-fail)
|