Move stdlib out of spec — clean spec/library boundary
spec/ now contains only the language definition (5 files): evaluator.sx, parser.sx, primitives.sx, render.sx, special-forms.sx lib/ contains code written IN the language (8 files): stdlib.sx, types.sx, freeze.sx, content.sx, bytecode.sx, compiler.sx, vm.sx, callcc.sx Test files follow source: spec/tests/ for core language tests, lib/tests/ for library tests (continuations, freeze, types, vm). Updated all consumers: - JS/Python/OCaml bootstrappers: added lib/ to source search paths - OCaml bridge: spec_dir for parser/render, lib_dir for compiler/freeze - JS test runner: scans spec/tests/ (always) + lib/tests/ (--full) - OCaml test runner: scans spec/tests/, lib tests via explicit request - Docker dev mounts: added ./lib:/app/lib:ro Tests: 1041 JS standard, 1322 JS full, 1101 OCaml — all pass Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
368
lib/tests/test-continuations-advanced.sx
Normal file
368
lib/tests/test-continuations-advanced.sx
Normal file
@@ -0,0 +1,368 @@
|
||||
;; ==========================================================================
|
||||
;; test-continuations-advanced.sx — Stress tests for multi-shot continuations
|
||||
;; and frame-based dynamic scope
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded, continuations + scope extensions enabled.
|
||||
;;
|
||||
;; Tests the CEK continuation + ProvideFrame/ScopeAccFrame system under:
|
||||
;; - Multi-shot (k invoked 0, 1, 2, 3+ times)
|
||||
;; - Continuation composition across nested resets
|
||||
;; - provide/context: dynamic variable binding via kont walk
|
||||
;; - provide values preserved across shift/resume
|
||||
;; - scope/emit!/emitted: accumulator frames in kont
|
||||
;; - Accumulator frames preserved across shift/resume
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Multi-shot continuations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "multi-shot-continuations"
|
||||
(deftest "k invoked 3 times returns list of results"
|
||||
;; Each (k N) resumes (+ 1 N) independently.
|
||||
;; Shift body collects all three results into a list.
|
||||
(assert-equal (list 11 21 31)
|
||||
(reset (+ 1 (shift k (list (k 10) (k 20) (k 30)))))))
|
||||
|
||||
(deftest "k invoked via map over input list"
|
||||
;; map applies k to each element; each resume computes (+ 1 elem).
|
||||
(assert-equal (list 11 21 31)
|
||||
(reset (+ 1 (shift k (map k (list 10 20 30)))))))
|
||||
|
||||
(deftest "k invoked zero times — abort with plain value"
|
||||
;; Shift body ignores k and returns 42 directly.
|
||||
;; The outer (+ 1 ...) hole is never filled.
|
||||
(assert-equal 42
|
||||
(reset (+ 1 (shift k 42)))))
|
||||
|
||||
(deftest "k invoked conditionally — true branch calls k"
|
||||
;; Only the true branch calls k; result is (+ 1 10) = 11.
|
||||
(assert-equal 11
|
||||
(reset (+ 1 (shift k (if true (k 10) 99))))))
|
||||
|
||||
(deftest "k invoked conditionally — false branch skips k"
|
||||
;; False branch returns 99 directly without invoking k.
|
||||
(assert-equal 99
|
||||
(reset (+ 1 (shift k (if false (k 10) 99))))))
|
||||
|
||||
(deftest "k invoked inside let binding"
|
||||
;; (k 5) = (+ 1 5) = 6; x is bound to 6; (* x 2) = 12.
|
||||
(assert-equal 12
|
||||
(reset (+ 1 (shift k (let ((x (k 5))) (* x 2)))))))
|
||||
|
||||
(deftest "nested shift — inner k2 called by outer k1"
|
||||
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 2 v))
|
||||
;; (k2 3) = 5, (k1 5) = 6
|
||||
;; inner reset returns 6 to shift-k1 body; (+ 10 6) = 16
|
||||
;; outer reset returns 16
|
||||
(assert-equal 16
|
||||
(reset (+ 1 (shift k1 (+ 10 (reset (+ 2 (shift k2 (k1 (k2 3)))))))))))
|
||||
|
||||
(deftest "k called twice accumulates both results"
|
||||
;; Two invocations in a list: (k 1) = 2, (k 2) = 3.
|
||||
(assert-equal (list 2 3)
|
||||
(reset (+ 1 (shift k (list (k 1) (k 2)))))))
|
||||
|
||||
(deftest "multi-shot k is idempotent — same arg gives same result"
|
||||
;; Calling k with the same argument twice should yield equal values.
|
||||
(let ((results (reset (+ 1 (shift k (list (k 5) (k 5)))))))
|
||||
(assert-equal (nth results 0) (nth results 1)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Continuation composition
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-composition"
|
||||
(deftest "two independent resets have isolated continuations"
|
||||
;; Each reset is entirely separate — the two k values are unrelated.
|
||||
(let ((r1 (reset (+ 1 (shift k1 (k1 10)))))
|
||||
(r2 (reset (+ 100 (shift k2 (k2 5))))))
|
||||
(assert-equal 11 r1)
|
||||
(assert-equal 105 r2)))
|
||||
|
||||
(deftest "continuation passed to helper function and invoked there"
|
||||
;; apply-k is a plain lambda; it calls the continuation it receives.
|
||||
(let ((apply-k (fn (k v) (k v))))
|
||||
(assert-equal 15
|
||||
(reset (+ 5 (shift k (apply-k k 10)))))))
|
||||
|
||||
(deftest "continuation stored in variable and invoked later"
|
||||
;; reset returns k itself; we then invoke it outside the reset form.
|
||||
(let ((k (reset (shift k k))))
|
||||
;; k = identity continuation for (reset _), so (k v) = v
|
||||
(assert-true (continuation? k))
|
||||
(assert-equal 42 (k 42))
|
||||
(assert-equal 7 (k 7))))
|
||||
|
||||
(deftest "continuation stored then called with multiple values"
|
||||
;; k from (+ 1 hole); invoking k with different args gives different results.
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-equal 11 (k 10))
|
||||
(assert-equal 21 (k 20))
|
||||
(assert-equal 31 (k 30))))
|
||||
|
||||
(deftest "continuation as argument to map — applied to a list"
|
||||
;; k = (fn (v) (+ 10 v)); map applies it to each element.
|
||||
(let ((k (reset (+ 10 (shift k k)))))
|
||||
(assert-equal (list 11 12 13)
|
||||
(map k (list 1 2 3)))))
|
||||
|
||||
(deftest "compose two continuations from nested resets"
|
||||
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 10 v))
|
||||
;; (k2 0) = 10, (k1 10) = 11; outer reset returns 11.
|
||||
(assert-equal 11
|
||||
(reset (+ 1 (shift k1 (reset (+ 10 (shift k2 (k1 (k2 0))))))))))
|
||||
|
||||
(deftest "continuation predicate holds inside and after capture"
|
||||
;; k captured inside shift is a continuation; so is one returned by reset.
|
||||
(assert-true
|
||||
(reset (shift k (continuation? k))))
|
||||
(assert-true
|
||||
(continuation? (reset (shift k k))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. provide / context — basic dynamic scope
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "provide-context-basic"
|
||||
(deftest "simple provide and context"
|
||||
;; (context \"x\") walks the kont and finds the ProvideFrame for \"x\".
|
||||
(assert-equal 42
|
||||
(provide "x" 42 (context "x"))))
|
||||
|
||||
(deftest "nested provide — inner shadows outer"
|
||||
;; The nearest ProvideFrame wins when searching kont.
|
||||
(assert-equal 2
|
||||
(provide "x" 1
|
||||
(provide "x" 2
|
||||
(context "x")))))
|
||||
|
||||
(deftest "outer provide visible after inner scope exits"
|
||||
;; After the inner provide's body finishes, its frame is gone.
|
||||
;; The next (context \"x\") walks past it to the outer frame.
|
||||
(assert-equal 1
|
||||
(provide "x" 1
|
||||
(do
|
||||
(provide "x" 2 (context "x"))
|
||||
(context "x")))))
|
||||
|
||||
(deftest "multiple provide names are independent"
|
||||
;; Each name has its own ProvideFrame; they don't interfere.
|
||||
(assert-equal 3
|
||||
(provide "a" 1
|
||||
(provide "b" 2
|
||||
(+ (context "a") (context "b"))))))
|
||||
|
||||
(deftest "context with default — provider present returns provided value"
|
||||
;; Second arg to context is the default; present provider overrides it.
|
||||
(assert-equal 42
|
||||
(provide "x" 42 (context "x" 0))))
|
||||
|
||||
(deftest "context with default — no provider returns default"
|
||||
;; When no ProvideFrame exists for the name, the default is returned.
|
||||
(assert-equal 0
|
||||
(provide "y" 99 (context "x" 0))))
|
||||
|
||||
(deftest "provide with computed value"
|
||||
;; The value expression is evaluated before pushing the frame.
|
||||
(assert-equal 6
|
||||
(provide "n" (* 2 3) (context "n"))))
|
||||
|
||||
(deftest "provide value is the exact bound value (no double-eval)"
|
||||
;; Passing a list as the provided value should return that list.
|
||||
(let ((result (provide "items" (list 1 2 3) (context "items"))))
|
||||
(assert-equal (list 1 2 3) result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. provide across shift — scope survives continuation capture/resume
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "provide-across-shift"
|
||||
(deftest "provide value preserved across shift and k invocation"
|
||||
;; The ProvideFrame lives in the kont beyond the ResetFrame.
|
||||
;; When k resumes, the frame is still there — context finds it.
|
||||
(assert-equal "dark"
|
||||
(reset
|
||||
(provide "theme" "dark"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "theme")))))
|
||||
|
||||
(deftest "two provides both preserved across shift"
|
||||
;; Both ProvideFrames must survive the shift/resume round-trip.
|
||||
(assert-equal 3
|
||||
(reset
|
||||
(provide "a" 1
|
||||
(provide "b" 2
|
||||
(+ 0 (shift k (k 0)))
|
||||
(+ (context "a") (context "b")))))))
|
||||
|
||||
(deftest "context visible inside provide but not in shift body"
|
||||
;; shift body runs OUTSIDE the reset boundary — provide is not in scope.
|
||||
;; But context with a default should return the default.
|
||||
(assert-equal "fallback"
|
||||
(reset
|
||||
(provide "theme" "light"
|
||||
(shift k (context "theme" "fallback"))))))
|
||||
|
||||
(deftest "context after k invocation restores scope frame"
|
||||
;; k was captured with the ProvideFrame in its saved kont.
|
||||
;; After (k v) resumes, context finds the frame again.
|
||||
(let ((result
|
||||
(reset
|
||||
(provide "color" "red"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "color")))))
|
||||
(assert-equal "red" result)))
|
||||
|
||||
(deftest "multi-shot: each k invocation reinstates captured ProvideFrame"
|
||||
;; k captures the ProvideFrame for "n" (it's inside the reset delimiter).
|
||||
;; Invoking k twice: each time (context "n") in the resumed body is valid.
|
||||
;; The shift body collects (context "n") from each resumed branch.
|
||||
(let ((readings
|
||||
(reset
|
||||
(provide "n" 10
|
||||
(+ 0 (shift k
|
||||
(list
|
||||
(k 0)
|
||||
(k 0))))
|
||||
(context "n")))))
|
||||
;; Each (k 0) resumes and returns (context "n") = 10.
|
||||
(assert-equal (list 10 10) readings))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. scope / emit! / emitted — accumulator frames
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "scope-emit-basic"
|
||||
(deftest "simple scope: emit two items and read emitted list"
|
||||
;; emit! appends to the nearest ScopeAccFrame; emitted returns the list.
|
||||
(assert-equal (list "a" "b")
|
||||
(scope "css"
|
||||
(emit! "css" "a")
|
||||
(emit! "css" "b")
|
||||
(emitted "css"))))
|
||||
|
||||
(deftest "empty scope returns empty list for emitted"
|
||||
;; No emit! calls means the accumulator stays empty.
|
||||
(assert-equal (list)
|
||||
(scope "css"
|
||||
(emitted "css"))))
|
||||
|
||||
(deftest "emit! order is preserved"
|
||||
;; Items appear in emission order, not reverse.
|
||||
(assert-equal (list 1 2 3 4 5)
|
||||
(scope "nums"
|
||||
(emit! "nums" 1)
|
||||
(emit! "nums" 2)
|
||||
(emit! "nums" 3)
|
||||
(emit! "nums" 4)
|
||||
(emit! "nums" 5)
|
||||
(emitted "nums"))))
|
||||
|
||||
(deftest "nested scopes: inner does not see outer's emitted"
|
||||
;; The inner scope has its own ScopeAccFrame; kont-find-scope-acc
|
||||
;; stops at the first matching name, so inner is fully isolated.
|
||||
(let ((inner-emitted
|
||||
(scope "css"
|
||||
(emit! "css" "outer")
|
||||
(scope "css"
|
||||
(emit! "css" "inner")
|
||||
(emitted "css")))))
|
||||
(assert-equal (list "inner") inner-emitted)))
|
||||
|
||||
(deftest "two differently-named scopes are independent"
|
||||
;; emit! to \"a\" must not appear in emitted \"b\" and vice versa.
|
||||
(let ((result-a nil) (result-b nil))
|
||||
(scope "a"
|
||||
(scope "b"
|
||||
(emit! "a" "for-a")
|
||||
(emit! "b" "for-b")
|
||||
(set! result-b (emitted "b")))
|
||||
(set! result-a (emitted "a")))
|
||||
(assert-equal (list "for-a") result-a)
|
||||
(assert-equal (list "for-b") result-b)))
|
||||
|
||||
(deftest "scope body returns last expression value"
|
||||
;; scope itself returns the last body expression, not the emitted list.
|
||||
(assert-equal 42
|
||||
(scope "x"
|
||||
(emit! "x" "ignored")
|
||||
42)))
|
||||
|
||||
(deftest "scope with :value acts as provide for context"
|
||||
;; When :value is given, the ScopeAccFrame also carries the value.
|
||||
;; context should be able to read it (if the evaluator searches scope-acc
|
||||
;; frames the same way as provide frames).
|
||||
;; NOTE: this tests the :value keyword path in step-sf-scope.
|
||||
;; If context only walks ProvideFrames, use provide directly instead.
|
||||
;; We verify at minimum that :value does not crash.
|
||||
(let ((r (try-call (fn ()
|
||||
(scope "x" :value 42
|
||||
(emitted "x"))))))
|
||||
(assert-true (get r "ok")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. scope / emit! across shift — accumulator frames survive continuation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "scope-emit-across-shift"
|
||||
(deftest "emit before and after shift both appear in emitted"
|
||||
;; The ScopeAccFrame is in the kont beyond the ResetFrame.
|
||||
;; After k resumes, the frame is still present; the second emit!
|
||||
;; appends to it.
|
||||
(assert-equal (list "a" "b")
|
||||
(reset
|
||||
(scope "acc"
|
||||
(emit! "acc" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "acc" "b")
|
||||
(emitted "acc")))))
|
||||
|
||||
(deftest "emit only before shift — one item in emitted"
|
||||
;; emit! before shift commits to the frame; shift/resume preserves it.
|
||||
(assert-equal (list "only")
|
||||
(reset
|
||||
(scope "log"
|
||||
(emit! "log" "only")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emitted "log")))))
|
||||
|
||||
(deftest "emit only after shift — one item in emitted"
|
||||
;; No emit! before shift; the frame starts empty; post-resume emit! adds one.
|
||||
(assert-equal (list "after")
|
||||
(reset
|
||||
(scope "log"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "log" "after")
|
||||
(emitted "log")))))
|
||||
|
||||
(deftest "emits on both sides of single shift boundary"
|
||||
;; Single shift/resume; emits before and after are preserved.
|
||||
(assert-equal (list "a" "b")
|
||||
(reset
|
||||
(scope "trace"
|
||||
(emit! "trace" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "trace" "b")
|
||||
(emitted "trace")))))
|
||||
|
||||
(deftest "emitted inside shift body reads current accumulator"
|
||||
;; kont in the shift body is rest-kont (outer kont beyond the reset).
|
||||
;; The ScopeAccFrame should be present if it was installed before reset.
|
||||
;; emit! and emitted inside shift body use that outer frame.
|
||||
(let ((outer-acc nil))
|
||||
(scope "outer"
|
||||
(reset
|
||||
(shift k
|
||||
(do
|
||||
(emit! "outer" "from-shift")
|
||||
(set! outer-acc (emitted "outer")))))
|
||||
nil)
|
||||
(assert-equal (list "from-shift") outer-acc))))
|
||||
|
||||
140
lib/tests/test-continuations.sx
Normal file
140
lib/tests/test-continuations.sx
Normal file
@@ -0,0 +1,140 @@
|
||||
;; ==========================================================================
|
||||
;; test-continuations.sx — Tests for delimited continuations (shift/reset)
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded, continuations extension enabled.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Basic shift/reset
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "basic-shift-reset"
|
||||
(deftest "reset passthrough"
|
||||
(assert-equal 42 (reset 42)))
|
||||
|
||||
(deftest "reset evaluates expression"
|
||||
(assert-equal 3 (reset (+ 1 2))))
|
||||
|
||||
(deftest "shift aborts to reset"
|
||||
(assert-equal 42 (reset (+ 1 (shift k 42)))))
|
||||
|
||||
(deftest "shift with single invoke"
|
||||
(assert-equal 11 (reset (+ 1 (shift k (k 10))))))
|
||||
|
||||
(deftest "shift with multiple invokes"
|
||||
(assert-equal (list 11 21)
|
||||
(reset (+ 1 (shift k (list (k 10) (k 20)))))))
|
||||
|
||||
(deftest "shift returns string"
|
||||
(assert-equal "aborted"
|
||||
(reset (+ 1 (shift k "aborted")))))
|
||||
|
||||
(deftest "shift returns nil"
|
||||
(assert-nil (reset (+ 1 (shift k nil)))))
|
||||
|
||||
(deftest "nested expression with shift"
|
||||
(assert-equal 16
|
||||
(+ 1 (reset (+ 10 (shift k (k 5))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Continuation predicates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-predicates"
|
||||
(deftest "k is a continuation inside shift"
|
||||
(assert-true
|
||||
(reset (shift k (continuation? k)))))
|
||||
|
||||
(deftest "number is not a continuation"
|
||||
(assert-false (continuation? 42)))
|
||||
|
||||
(deftest "function is not a continuation"
|
||||
(assert-false (continuation? (fn (x) x))))
|
||||
|
||||
(deftest "nil is not a continuation"
|
||||
(assert-false (continuation? nil)))
|
||||
|
||||
(deftest "string is not a continuation"
|
||||
(assert-false (continuation? "hello"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Continuation as value
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-as-value"
|
||||
(deftest "k returned from reset"
|
||||
;; shift body returns k itself — reset returns the continuation
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-true (continuation? k))
|
||||
(assert-equal 11 (k 10))))
|
||||
|
||||
(deftest "invoke returned k multiple times"
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-equal 11 (k 10))
|
||||
(assert-equal 21 (k 20))
|
||||
(assert-equal 2 (k 1))))
|
||||
|
||||
(deftest "pass k to another function"
|
||||
(let ((apply-k (fn (k v) (k v))))
|
||||
(assert-equal 15
|
||||
(reset (+ 5 (shift k (apply-k k 10)))))))
|
||||
|
||||
(deftest "k in data structure"
|
||||
(let ((result (reset (+ 1 (shift k (list k 42))))))
|
||||
(assert-equal 42 (nth result 1))
|
||||
(assert-equal 100 ((first result) 99)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Nested reset
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "nested-reset"
|
||||
(deftest "inner reset captures independently"
|
||||
(assert-equal 12
|
||||
(reset (+ 1 (reset (+ 10 (shift k (k 1))))))))
|
||||
|
||||
(deftest "inner abort outer continues"
|
||||
(assert-equal 43
|
||||
(reset (+ 1 (reset (+ 10 (shift k 42)))))))
|
||||
|
||||
(deftest "outer shift captures outer reset"
|
||||
(assert-equal 100
|
||||
(reset (+ 1 (shift k (k 99)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Interaction with scoped effects
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuations-with-scopes"
|
||||
(deftest "provide survives resume"
|
||||
(assert-equal "dark"
|
||||
(reset (provide "theme" "dark"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "theme")))))
|
||||
|
||||
(deftest "scope and emit across shift"
|
||||
(assert-equal (list "a")
|
||||
(reset (scope "acc"
|
||||
(emit! "acc" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emitted "acc"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. TCO interaction
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "tco-interaction"
|
||||
(deftest "shift in tail position"
|
||||
(assert-equal 42
|
||||
(reset (if true (shift k (k 42)) 0))))
|
||||
|
||||
(deftest "shift in let body"
|
||||
(assert-equal 10
|
||||
(reset (let ((x 5))
|
||||
(+ x (shift k (k 5))))))))
|
||||
75
lib/tests/test-freeze.sx
Normal file
75
lib/tests/test-freeze.sx
Normal file
@@ -0,0 +1,75 @@
|
||||
;; ==========================================================================
|
||||
;; test-freeze.sx — Freeze scope and content addressing tests
|
||||
;; ==========================================================================
|
||||
|
||||
(defsuite "freeze-scope"
|
||||
(deftest "freeze captures signal values"
|
||||
(let ((s (signal 42)))
|
||||
(freeze-scope "t1" (fn ()
|
||||
(freeze-signal "val" s)))
|
||||
(let ((frozen (cek-freeze-scope "t1")))
|
||||
(assert-equal "t1" (get frozen "name"))
|
||||
(assert-equal 42 (get (get frozen "signals") "val")))))
|
||||
|
||||
(deftest "thaw restores signal values"
|
||||
(let ((s (signal 10)))
|
||||
(freeze-scope "t2" (fn ()
|
||||
(freeze-signal "x" s)))
|
||||
(let ((sx (freeze-to-sx "t2")))
|
||||
(reset! s 999)
|
||||
(assert-equal 999 (deref s))
|
||||
(thaw-from-sx sx)
|
||||
(assert-equal 10 (deref s)))))
|
||||
|
||||
(deftest "multiple signals in scope"
|
||||
(let ((a (signal "hello"))
|
||||
(b (signal 42))
|
||||
(c (signal true)))
|
||||
(freeze-scope "t3" (fn ()
|
||||
(freeze-signal "a" a)
|
||||
(freeze-signal "b" b)
|
||||
(freeze-signal "c" c)))
|
||||
(let ((frozen (cek-freeze-scope "t3")))
|
||||
(assert-equal "hello" (get (get frozen "signals") "a"))
|
||||
(assert-equal 42 (get (get frozen "signals") "b"))
|
||||
(assert-equal true (get (get frozen "signals") "c")))))
|
||||
|
||||
(deftest "freeze-to-sx round trip"
|
||||
(let ((s (signal "data")))
|
||||
(freeze-scope "t4" (fn ()
|
||||
(freeze-signal "s" s)))
|
||||
(let ((sx (freeze-to-sx "t4")))
|
||||
(assert-true (string? sx))
|
||||
(assert-true (contains? sx "data"))
|
||||
(reset! s "changed")
|
||||
(thaw-from-sx sx)
|
||||
(assert-equal "data" (deref s))))))
|
||||
|
||||
(defsuite "content-addressing"
|
||||
(deftest "content-hash deterministic"
|
||||
(assert-equal (content-hash "hello") (content-hash "hello")))
|
||||
|
||||
(deftest "content-hash different for different input"
|
||||
(assert-false (= (content-hash "hello") (content-hash "world"))))
|
||||
|
||||
(deftest "content-put and get"
|
||||
(let ((cid (content-put "test data")))
|
||||
(assert-equal "test data" (content-get cid))))
|
||||
|
||||
(deftest "freeze-to-cid round trip"
|
||||
(let ((s (signal 77)))
|
||||
(freeze-scope "t5" (fn ()
|
||||
(freeze-signal "v" s)))
|
||||
(let ((cid (freeze-to-cid "t5")))
|
||||
(assert-true (string? cid))
|
||||
(reset! s 0)
|
||||
(assert-true (thaw-from-cid cid))
|
||||
(assert-equal 77 (deref s)))))
|
||||
|
||||
(deftest "same state same cid"
|
||||
(let ((s (signal 42)))
|
||||
(freeze-scope "t6" (fn ()
|
||||
(freeze-signal "n" s)))
|
||||
(let ((cid1 (freeze-to-cid "t6"))
|
||||
(cid2 (freeze-to-cid "t6")))
|
||||
(assert-equal cid1 cid2)))))
|
||||
348
lib/tests/test-signals-advanced.sx
Normal file
348
lib/tests/test-signals-advanced.sx
Normal file
@@ -0,0 +1,348 @@
|
||||
;; ==========================================================================
|
||||
;; test-signals-advanced.sx — Stress tests for the reactive signal system
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: signals.sx (signal, deref, reset!, swap!, computed,
|
||||
;; effect, batch)
|
||||
;;
|
||||
;; Note: Multi-expression lambda bodies are wrapped in (do ...) for
|
||||
;; compatibility with evaluators that support only single-expression bodies.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Signal basics extended
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "signal-basics-extended"
|
||||
(deftest "signal with nil initial value"
|
||||
(let ((s (signal nil)))
|
||||
(assert-true (signal? s))
|
||||
(assert-nil (deref s))))
|
||||
|
||||
(deftest "signal with list value"
|
||||
(let ((s (signal (list 1 2 3))))
|
||||
(assert-equal (list 1 2 3) (deref s))
|
||||
(reset! s (list 4 5 6))
|
||||
(assert-equal (list 4 5 6) (deref s))))
|
||||
|
||||
(deftest "signal with dict value"
|
||||
(let ((s (signal {:name "alice" :score 42})))
|
||||
(assert-equal "alice" (get (deref s) "name"))
|
||||
(assert-equal 42 (get (deref s) "score"))))
|
||||
|
||||
(deftest "signal with lambda value"
|
||||
(let ((fn-val (fn (x) (* x 2)))
|
||||
(s (signal nil)))
|
||||
(reset! s fn-val)
|
||||
;; The stored lambda should be callable
|
||||
(assert-equal 10 ((deref s) 5))))
|
||||
|
||||
(deftest "multiple signals independent of each other"
|
||||
(let ((a (signal 1))
|
||||
(b (signal 2))
|
||||
(c (signal 3)))
|
||||
(reset! a 10)
|
||||
;; b and c must be unchanged
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 2 (deref b))
|
||||
(assert-equal 3 (deref c))
|
||||
(reset! b 20)
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 20 (deref b))
|
||||
(assert-equal 3 (deref c))))
|
||||
|
||||
(deftest "deref returns current value not a stale snapshot"
|
||||
(let ((s (signal "first")))
|
||||
(let ((snap1 (deref s)))
|
||||
(reset! s "second")
|
||||
(let ((snap2 (deref s)))
|
||||
;; snap1 holds the string "first" (immutable), snap2 is "second"
|
||||
(assert-equal "first" snap1)
|
||||
(assert-equal "second" snap2))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Computed chains
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "computed-chains"
|
||||
(deftest "chain of three computed signals"
|
||||
(let ((base (signal 2))
|
||||
(doubled (computed (fn () (* 2 (deref base)))))
|
||||
(tripled (computed (fn () (* 3 (deref doubled))))))
|
||||
;; Initial: base=2 → doubled=4 → tripled=12
|
||||
(assert-equal 4 (deref doubled))
|
||||
(assert-equal 12 (deref tripled))
|
||||
;; Update propagates through the entire chain
|
||||
(reset! base 5)
|
||||
(assert-equal 10 (deref doubled))
|
||||
(assert-equal 30 (deref tripled))))
|
||||
|
||||
(deftest "computed depending on multiple signals"
|
||||
(let ((x (signal 3))
|
||||
(y (signal 4))
|
||||
(hypo (computed (fn ()
|
||||
;; sqrt(x^2 + y^2) — Pythagorean hypotenuse (integer approx)
|
||||
(+ (* (deref x) (deref x))
|
||||
(* (deref y) (deref y)))))))
|
||||
(assert-equal 25 (deref hypo))
|
||||
(reset! x 0)
|
||||
(assert-equal 16 (deref hypo))
|
||||
(reset! y 0)
|
||||
(assert-equal 0 (deref hypo))))
|
||||
|
||||
(deftest "computed with conditional logic"
|
||||
(let ((flag (signal true))
|
||||
(a (signal 10))
|
||||
(b (signal 99))
|
||||
(result (computed (fn ()
|
||||
(if (deref flag) (deref a) (deref b))))))
|
||||
(assert-equal 10 (deref result))
|
||||
(reset! flag false)
|
||||
(assert-equal 99 (deref result))
|
||||
(reset! b 42)
|
||||
(assert-equal 42 (deref result))
|
||||
(reset! flag true)
|
||||
(assert-equal 10 (deref result))))
|
||||
|
||||
(deftest "diamond dependency: A->B, A->C, B+C->D"
|
||||
;; A change in A must propagate via both B and C to D,
|
||||
;; but D must still hold a coherent (not intermediate) value.
|
||||
(let ((A (signal 1))
|
||||
(B (computed (fn () (* 2 (deref A)))))
|
||||
(C (computed (fn () (* 3 (deref A)))))
|
||||
(D (computed (fn () (+ (deref B) (deref C))))))
|
||||
;; A=1 → B=2, C=3 → D=5
|
||||
(assert-equal 2 (deref B))
|
||||
(assert-equal 3 (deref C))
|
||||
(assert-equal 5 (deref D))
|
||||
;; A=4 → B=8, C=12 → D=20
|
||||
(reset! A 4)
|
||||
(assert-equal 8 (deref B))
|
||||
(assert-equal 12 (deref C))
|
||||
(assert-equal 20 (deref D))))
|
||||
|
||||
(deftest "computed returns nil when source signal is nil"
|
||||
(let ((s (signal nil))
|
||||
(c (computed (fn ()
|
||||
(let ((v (deref s)))
|
||||
(when (not (nil? v)) (* v 2)))))))
|
||||
(assert-nil (deref c))
|
||||
(reset! s 7)
|
||||
(assert-equal 14 (deref c))
|
||||
(reset! s nil)
|
||||
(assert-nil (deref c)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Effect patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "effect-patterns"
|
||||
(deftest "effect runs immediately on creation"
|
||||
(let ((ran (signal false)))
|
||||
(effect (fn () (reset! ran true)))
|
||||
(assert-true (deref ran))))
|
||||
|
||||
(deftest "effect re-runs when dependency changes"
|
||||
(let ((n (signal 0))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do (deref n) (swap! calls inc))))
|
||||
;; Initial run counts as 1
|
||||
(assert-equal 1 (deref calls))
|
||||
(reset! n 1)
|
||||
(assert-equal 2 (deref calls))
|
||||
(reset! n 2)
|
||||
(assert-equal 3 (deref calls))))
|
||||
|
||||
(deftest "effect with multiple dependencies"
|
||||
(let ((a (signal "x"))
|
||||
(b (signal "y"))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do (deref a) (deref b) (swap! calls inc))))
|
||||
(assert-equal 1 (deref calls))
|
||||
;; Changing a triggers re-run
|
||||
(reset! a "x2")
|
||||
(assert-equal 2 (deref calls))
|
||||
;; Changing b also triggers re-run
|
||||
(reset! b "y2")
|
||||
(assert-equal 3 (deref calls))))
|
||||
|
||||
(deftest "effect cleanup function called on re-run"
|
||||
(let ((trigger (signal 0))
|
||||
(cleanups (signal 0)))
|
||||
(effect (fn () (do
|
||||
(deref trigger)
|
||||
;; Return a cleanup function
|
||||
(fn () (swap! cleanups inc)))))
|
||||
;; First run — no previous cleanup to call
|
||||
(assert-equal 0 (deref cleanups))
|
||||
;; Second run — previous cleanup fires first
|
||||
(reset! trigger 1)
|
||||
(assert-equal 1 (deref cleanups))
|
||||
;; Third run — second cleanup fires
|
||||
(reset! trigger 2)
|
||||
(assert-equal 2 (deref cleanups))))
|
||||
|
||||
(deftest "effect tracks only actually-deref'd signals"
|
||||
;; An effect that conditionally reads signal B should only re-run
|
||||
;; for B changes when B is actually read (flag=true).
|
||||
(let ((flag (signal true))
|
||||
(b (signal 0))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do
|
||||
(deref flag)
|
||||
(when (deref flag) (deref b))
|
||||
(swap! calls inc))))
|
||||
;; Initial run reads both flag and b
|
||||
(assert-equal 1 (deref calls))
|
||||
;; flip flag to false — re-run, but now b is NOT deref'd
|
||||
(reset! flag false)
|
||||
(assert-equal 2 (deref calls))
|
||||
;; Changing b should NOT trigger another run (b wasn't deref'd last time)
|
||||
(reset! b 99)
|
||||
(assert-equal 2 (deref calls)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Batch behavior
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "batch-behavior"
|
||||
(deftest "batch coalesces multiple signal updates into one effect run"
|
||||
(let ((a (signal 0))
|
||||
(b (signal 0))
|
||||
(run-count (signal 0)))
|
||||
(effect (fn () (do (deref a) (deref b) (swap! run-count inc))))
|
||||
;; Initial run
|
||||
(assert-equal 1 (deref run-count))
|
||||
;; Two writes inside a single batch → one effect run, not two
|
||||
(batch (fn () (do
|
||||
(reset! a 1)
|
||||
(reset! b 2))))
|
||||
(assert-equal 2 (deref run-count))))
|
||||
|
||||
(deftest "nested batch — inner batch does not flush, outer batch does"
|
||||
(let ((s (signal 0))
|
||||
(run-count (signal 0)))
|
||||
(effect (fn () (do (deref s) (swap! run-count inc))))
|
||||
(assert-equal 1 (deref run-count))
|
||||
(batch (fn ()
|
||||
(batch (fn ()
|
||||
(reset! s 1)))
|
||||
;; Still inside outer batch — should not have fired yet
|
||||
(reset! s 2)))
|
||||
;; Outer batch ends → exactly one more run
|
||||
(assert-equal 2 (deref run-count))
|
||||
;; Final value is the last write
|
||||
(assert-equal 2 (deref s))))
|
||||
|
||||
(deftest "batch with computed — computed updates once not per signal write"
|
||||
(let ((x (signal 0))
|
||||
(y (signal 0))
|
||||
(sum (computed (fn () (+ (deref x) (deref y)))))
|
||||
(recomps (signal 0)))
|
||||
;; Track recomputations by wrapping via an effect
|
||||
(effect (fn () (do (deref sum) (swap! recomps inc))))
|
||||
;; Initial: effect + computed both ran once
|
||||
(assert-equal 1 (deref recomps))
|
||||
(batch (fn () (do
|
||||
(reset! x 10)
|
||||
(reset! y 20))))
|
||||
;; sum must reflect both changes
|
||||
(assert-equal 30 (deref sum))
|
||||
;; effect re-ran at most once more (not twice)
|
||||
(assert-equal 2 (deref recomps))))
|
||||
|
||||
(deftest "batch executes the thunk"
|
||||
;; batch runs the thunk for side effects; return value is implementation-defined
|
||||
(let ((s (signal 0)))
|
||||
(batch (fn () (reset! s 42)))
|
||||
(assert-equal 42 (deref s)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Swap patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "swap-patterns"
|
||||
(deftest "swap! with increment function"
|
||||
(let ((n (signal 0)))
|
||||
(swap! n inc)
|
||||
(assert-equal 1 (deref n))
|
||||
(swap! n inc)
|
||||
(assert-equal 2 (deref n))))
|
||||
|
||||
(deftest "swap! with list append"
|
||||
(let ((items (signal (list))))
|
||||
(swap! items (fn (l) (append l "a")))
|
||||
(swap! items (fn (l) (append l "b")))
|
||||
(swap! items (fn (l) (append l "c")))
|
||||
(assert-equal (list "a" "b" "c") (deref items))))
|
||||
|
||||
(deftest "swap! with dict assoc"
|
||||
(let ((store (signal {})))
|
||||
(swap! store (fn (d) (assoc d "x" 1)))
|
||||
(swap! store (fn (d) (assoc d "y" 2)))
|
||||
(assert-equal 1 (get (deref store) "x"))
|
||||
(assert-equal 2 (get (deref store) "y"))))
|
||||
|
||||
(deftest "multiple swap! in sequence build up correct value"
|
||||
(let ((acc (signal 0)))
|
||||
(swap! acc + 10)
|
||||
(swap! acc + 5)
|
||||
(swap! acc - 3)
|
||||
(assert-equal 12 (deref acc)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; call-lambda + trampoline — event handler pattern
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: dom-on wraps Lambda event handlers in JS functions that
|
||||
;; call callLambda. callLambda returns a Thunk (TCO), but the wrapper
|
||||
;; never trampolined it, so the handler body (swap!, reset!, etc.)
|
||||
;; never executed. Buttons rendered but clicks had no effect.
|
||||
;;
|
||||
;; These tests verify the pattern that dom-on uses:
|
||||
;; (trampoline (call-lambda handler (list arg)))
|
||||
;; must resolve thunks and execute side effects.
|
||||
|
||||
(defsuite "call-lambda-trampoline-handlers"
|
||||
(deftest "call-lambda + trampoline executes signal mutation"
|
||||
(let ((count (signal 0))
|
||||
(handler (fn () (swap! count + 1))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 1 (deref count))))
|
||||
|
||||
(deftest "call-lambda + trampoline with event arg"
|
||||
(let ((last-val (signal nil))
|
||||
(handler (fn (e) (reset! last-val e))))
|
||||
(trampoline (call-lambda handler (list "click-event")))
|
||||
(assert-equal "click-event" (deref last-val))))
|
||||
|
||||
(deftest "call-lambda + trampoline executes multi-statement body"
|
||||
(let ((a (signal 0))
|
||||
(b (signal 0))
|
||||
(handler (fn ()
|
||||
(reset! a 10)
|
||||
(reset! b 20))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 20 (deref b))))
|
||||
|
||||
(deftest "repeated call-lambda accumulates side effects"
|
||||
(let ((count (signal 0))
|
||||
(handler (fn () (swap! count + 1))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 3 (deref count))))
|
||||
|
||||
(deftest "call-lambda handler calling another lambda"
|
||||
(let ((log (signal (list)))
|
||||
(inner (fn (msg) (reset! log (append (deref log) (list msg)))))
|
||||
(outer (fn () (inner "hello") (inner "world"))))
|
||||
(trampoline (call-lambda outer (list)))
|
||||
(assert-equal (list "hello" "world") (deref log)))))
|
||||
649
lib/tests/test-types.sx
Normal file
649
lib/tests/test-types.sx
Normal file
@@ -0,0 +1,649 @@
|
||||
;; ==========================================================================
|
||||
;; test-types.sx — Tests for the SX gradual type system
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: types.sx (subtype?, infer-type, check-component, etc.)
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; All type system functions from types.sx must be loaded.
|
||||
;; test-prim-types — a dict of primitive return types for testing.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Subtype checking
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "subtype-basics"
|
||||
(deftest "any accepts everything"
|
||||
(assert-true (subtype? "number" "any"))
|
||||
(assert-true (subtype? "string" "any"))
|
||||
(assert-true (subtype? "nil" "any"))
|
||||
(assert-true (subtype? "boolean" "any"))
|
||||
(assert-true (subtype? "any" "any")))
|
||||
|
||||
(deftest "never is subtype of everything"
|
||||
(assert-true (subtype? "never" "number"))
|
||||
(assert-true (subtype? "never" "string"))
|
||||
(assert-true (subtype? "never" "any"))
|
||||
(assert-true (subtype? "never" "nil")))
|
||||
|
||||
(deftest "identical types"
|
||||
(assert-true (subtype? "number" "number"))
|
||||
(assert-true (subtype? "string" "string"))
|
||||
(assert-true (subtype? "boolean" "boolean"))
|
||||
(assert-true (subtype? "nil" "nil")))
|
||||
|
||||
(deftest "different base types are not subtypes"
|
||||
(assert-false (subtype? "number" "string"))
|
||||
(assert-false (subtype? "string" "number"))
|
||||
(assert-false (subtype? "boolean" "number"))
|
||||
(assert-false (subtype? "string" "boolean")))
|
||||
|
||||
(deftest "any is not subtype of specific type"
|
||||
(assert-false (subtype? "any" "number"))
|
||||
(assert-false (subtype? "any" "string"))))
|
||||
|
||||
|
||||
(defsuite "subtype-nullable"
|
||||
(deftest "nil is subtype of nullable types"
|
||||
(assert-true (subtype? "nil" "string?"))
|
||||
(assert-true (subtype? "nil" "number?"))
|
||||
(assert-true (subtype? "nil" "dict?"))
|
||||
(assert-true (subtype? "nil" "boolean?")))
|
||||
|
||||
(deftest "base is subtype of its nullable"
|
||||
(assert-true (subtype? "string" "string?"))
|
||||
(assert-true (subtype? "number" "number?"))
|
||||
(assert-true (subtype? "dict" "dict?")))
|
||||
|
||||
(deftest "nullable is not subtype of base"
|
||||
(assert-false (subtype? "string?" "string"))
|
||||
(assert-false (subtype? "number?" "number")))
|
||||
|
||||
(deftest "different nullable types are not subtypes"
|
||||
(assert-false (subtype? "number" "string?"))
|
||||
(assert-false (subtype? "string" "number?"))))
|
||||
|
||||
|
||||
(defsuite "subtype-unions"
|
||||
(deftest "member is subtype of union"
|
||||
(assert-true (subtype? "number" (list "or" "number" "string")))
|
||||
(assert-true (subtype? "string" (list "or" "number" "string"))))
|
||||
|
||||
(deftest "non-member is not subtype of union"
|
||||
(assert-false (subtype? "boolean" (list "or" "number" "string"))))
|
||||
|
||||
(deftest "union is subtype if all members are"
|
||||
(assert-true (subtype? (list "or" "number" "string")
|
||||
(list "or" "number" "string" "boolean")))
|
||||
(assert-true (subtype? (list "or" "number" "string") "any")))
|
||||
|
||||
(deftest "union is not subtype if any member is not"
|
||||
(assert-false (subtype? (list "or" "number" "string") "number"))))
|
||||
|
||||
|
||||
(defsuite "subtype-list-of"
|
||||
(deftest "list-of covariance"
|
||||
(assert-true (subtype? (list "list-of" "number") (list "list-of" "number")))
|
||||
(assert-true (subtype? (list "list-of" "number") (list "list-of" "any"))))
|
||||
|
||||
(deftest "list-of is subtype of list"
|
||||
(assert-true (subtype? (list "list-of" "number") "list")))
|
||||
|
||||
(deftest "list is subtype of list-of any"
|
||||
(assert-true (subtype? "list" (list "list-of" "any")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type union
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "type-union"
|
||||
(deftest "same types"
|
||||
(assert-equal "number" (type-union "number" "number"))
|
||||
(assert-equal "string" (type-union "string" "string")))
|
||||
|
||||
(deftest "any absorbs"
|
||||
(assert-equal "any" (type-union "any" "number"))
|
||||
(assert-equal "any" (type-union "number" "any")))
|
||||
|
||||
(deftest "never is identity"
|
||||
(assert-equal "number" (type-union "never" "number"))
|
||||
(assert-equal "string" (type-union "string" "never")))
|
||||
|
||||
(deftest "nil + base creates nullable"
|
||||
(assert-equal "string?" (type-union "nil" "string"))
|
||||
(assert-equal "number?" (type-union "number" "nil")))
|
||||
|
||||
(deftest "subtype collapses"
|
||||
(assert-equal "string?" (type-union "string" "string?"))
|
||||
(assert-equal "string?" (type-union "string?" "string")))
|
||||
|
||||
(deftest "incompatible creates union"
|
||||
(let ((result (type-union "number" "string")))
|
||||
(assert-true (= (type-of result) "list"))
|
||||
(assert-equal "or" (first result))
|
||||
(assert-true (contains? result "number"))
|
||||
(assert-true (contains? result "string")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type narrowing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "type-narrowing"
|
||||
(deftest "nil? narrows to nil in then branch"
|
||||
(let ((result (narrow-type "string?" "nil?")))
|
||||
(assert-equal "nil" (first result))
|
||||
(assert-equal "string" (nth result 1))))
|
||||
|
||||
(deftest "nil? narrows any stays any"
|
||||
(let ((result (narrow-type "any" "nil?")))
|
||||
(assert-equal "nil" (first result))
|
||||
(assert-equal "any" (nth result 1))))
|
||||
|
||||
(deftest "string? narrows to string in then branch"
|
||||
(let ((result (narrow-type "any" "string?")))
|
||||
(assert-equal "string" (first result))
|
||||
;; else branch — can't narrow any
|
||||
(assert-equal "any" (nth result 1))))
|
||||
|
||||
(deftest "nil? on nil type narrows to never in else"
|
||||
(let ((result (narrow-type "nil" "nil?")))
|
||||
(assert-equal "nil" (first result))
|
||||
(assert-equal "never" (nth result 1)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type inference
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "infer-literals"
|
||||
(deftest "number literal"
|
||||
(assert-equal "number" (infer-type 42 (dict) (test-prim-types))))
|
||||
|
||||
(deftest "string literal"
|
||||
(assert-equal "string" (infer-type "hello" (dict) (test-prim-types))))
|
||||
|
||||
(deftest "boolean literal"
|
||||
(assert-equal "boolean" (infer-type true (dict) (test-prim-types))))
|
||||
|
||||
(deftest "nil"
|
||||
(assert-equal "nil" (infer-type nil (dict) (test-prim-types)))))
|
||||
|
||||
|
||||
(defsuite "infer-calls"
|
||||
(deftest "known primitive return type"
|
||||
;; (+ 1 2) → number
|
||||
(let ((expr (sx-parse "(+ 1 2)")))
|
||||
(assert-equal "number"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "str returns string"
|
||||
(let ((expr (sx-parse "(str 1 2)")))
|
||||
(assert-equal "string"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "comparison returns boolean"
|
||||
(let ((expr (sx-parse "(= 1 2)")))
|
||||
(assert-equal "boolean"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "component call returns element"
|
||||
(let ((expr (sx-parse "(~card :title \"hi\")")))
|
||||
(assert-equal "element"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "unknown function returns any"
|
||||
(let ((expr (sx-parse "(unknown-fn 1 2)")))
|
||||
(assert-equal "any"
|
||||
(infer-type (first expr) (dict) (test-prim-types))))))
|
||||
|
||||
|
||||
(defsuite "infer-special-forms"
|
||||
(deftest "if produces union of branches"
|
||||
(let ((expr (sx-parse "(if true 42 \"hello\")")))
|
||||
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
|
||||
;; number | string — should be a union
|
||||
(assert-true (or (equal? t (list "or" "number" "string"))
|
||||
(= t "any"))))))
|
||||
|
||||
(deftest "if with no else includes nil"
|
||||
(let ((expr (sx-parse "(if true 42)")))
|
||||
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
|
||||
(assert-equal "number?" t))))
|
||||
|
||||
(deftest "when includes nil"
|
||||
(let ((expr (sx-parse "(when true 42)")))
|
||||
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
|
||||
(assert-equal "number?" t))))
|
||||
|
||||
(deftest "do returns last type"
|
||||
(let ((expr (sx-parse "(do 1 2 \"hello\")")))
|
||||
(assert-equal "string"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "let infers binding types"
|
||||
(let ((expr (sx-parse "(let ((x 42)) x)")))
|
||||
(assert-equal "number"
|
||||
(infer-type (first expr) (dict) (test-prim-types)))))
|
||||
|
||||
(deftest "lambda returns lambda"
|
||||
(let ((expr (sx-parse "(fn (x) (+ x 1))")))
|
||||
(assert-equal "lambda"
|
||||
(infer-type (first expr) (dict) (test-prim-types))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component call checking
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "check-component-calls"
|
||||
(deftest "type mismatch produces error"
|
||||
;; Create a component with typed params, then check a bad call
|
||||
(let ((env (test-env)))
|
||||
;; Define a typed component
|
||||
(do
|
||||
(define dummy-env env)
|
||||
(defcomp ~typed-card (&key title price) (div title price))
|
||||
(component-set-param-types! ~typed-card
|
||||
{:title "string" :price "number"}))
|
||||
;; Check a call with wrong type
|
||||
(let ((diagnostics
|
||||
(check-component-call "~typed-card" ~typed-card
|
||||
(rest (first (sx-parse "(~typed-card :title 42 :price \"bad\")")))
|
||||
(dict) (test-prim-types))))
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "error" (dict-get (first diagnostics) "level")))))
|
||||
|
||||
(deftest "correct call produces no errors"
|
||||
(let ((env (test-env)))
|
||||
(do
|
||||
(define dummy-env env)
|
||||
(defcomp ~ok-card (&key title price) (div title price))
|
||||
(component-set-param-types! ~ok-card
|
||||
{:title "string" :price "number"}))
|
||||
(let ((diagnostics
|
||||
(check-component-call "~ok-card" ~ok-card
|
||||
(rest (first (sx-parse "(~ok-card :title \"hi\" :price 42)")))
|
||||
(dict) (test-prim-types))))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "unknown kwarg produces warning"
|
||||
(let ((env (test-env)))
|
||||
(do
|
||||
(define dummy-env env)
|
||||
(defcomp ~warn-card (&key title) (div title))
|
||||
(component-set-param-types! ~warn-card
|
||||
{:title "string"}))
|
||||
(let ((diagnostics
|
||||
(check-component-call "~warn-card" ~warn-card
|
||||
(rest (first (sx-parse "(~warn-card :title \"hi\" :colour \"red\")")))
|
||||
(dict) (test-prim-types))))
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "warning" (dict-get (first diagnostics) "level"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Annotation syntax: (name :as type) in defcomp params
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "typed-defcomp"
|
||||
(deftest "typed params are parsed and stored"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~typed-widget (&key (title :as string) (count :as number)) (div title count))
|
||||
(let ((pt (component-param-types ~typed-widget)))
|
||||
(assert-true (not (nil? pt)))
|
||||
(assert-equal "string" (dict-get pt "title"))
|
||||
(assert-equal "number" (dict-get pt "count")))))
|
||||
|
||||
(deftest "mixed typed and untyped params"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~mixed-widget (&key (title :as string) subtitle) (div title subtitle))
|
||||
(let ((pt (component-param-types ~mixed-widget)))
|
||||
(assert-true (not (nil? pt)))
|
||||
(assert-equal "string" (dict-get pt "title"))
|
||||
;; subtitle has no annotation — should not be in param-types
|
||||
(assert-false (has-key? pt "subtitle")))))
|
||||
|
||||
(deftest "untyped defcomp has nil param-types"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~plain-widget (&key title subtitle) (div title subtitle))
|
||||
(assert-true (nil? (component-param-types ~plain-widget)))))
|
||||
|
||||
(deftest "typed component catches type error on call"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~strict-card (&key (title :as string) (price :as number)) (div title price))
|
||||
;; Call with wrong types
|
||||
(let ((diagnostics
|
||||
(check-component-call "~strict-card" ~strict-card
|
||||
(rest (first (sx-parse "(~strict-card :title 42 :price \"bad\")")))
|
||||
(dict) (test-prim-types))))
|
||||
;; Should have errors for both wrong-type args
|
||||
(assert-true (>= (len diagnostics) 1))
|
||||
(assert-equal "error" (dict-get (first diagnostics) "level")))))
|
||||
|
||||
(deftest "typed component passes correct call"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~ok-widget (&key (name :as string) (age :as number)) (div name age))
|
||||
(let ((diagnostics
|
||||
(check-component-call "~ok-widget" ~ok-widget
|
||||
(rest (first (sx-parse "(~ok-widget :name \"Alice\" :age 30)")))
|
||||
(dict) (test-prim-types))))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "nullable type accepts nil"
|
||||
(let ((env (test-env)))
|
||||
(defcomp ~nullable-widget (&key (title :as string) (subtitle :as string?)) (div title subtitle))
|
||||
;; Passing nil for nullable param should be fine
|
||||
(let ((diagnostics
|
||||
(check-component-call "~nullable-widget" ~nullable-widget
|
||||
(rest (first (sx-parse "(~nullable-widget :title \"hi\" :subtitle nil)")))
|
||||
(dict) (test-prim-types))))
|
||||
(assert-equal 0 (len diagnostics))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Primitive call checking (Phase 5)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "check-primitive-calls"
|
||||
(deftest "correct types produce no errors"
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 2 3)")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "string arg to numeric primitive produces error"
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 \"hello\")")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "error" (get (first diagnostics) "level")))))
|
||||
|
||||
(deftest "number arg to string primitive produces error"
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "upper" (rest (first (sx-parse "(upper 42)")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "error" (get (first diagnostics) "level")))))
|
||||
|
||||
(deftest "positional and rest params both checked"
|
||||
;; (- "bad" 1) — first positional arg is string, expects number
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "-" (rest (first (sx-parse "(- \"bad\" 1)")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-true (> (len diagnostics) 0)))))
|
||||
|
||||
(deftest "dict arg to keys is valid"
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "keys" (rest (first (sx-parse "(keys {:a 1})")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "number arg to keys produces error"
|
||||
(let ((ppt (test-prim-param-types)))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "keys" (rest (first (sx-parse "(keys 42)")))
|
||||
(dict) (test-prim-types) ppt nil)))
|
||||
(assert-true (> (len diagnostics) 0)))))
|
||||
|
||||
(deftest "variable with known type passes check"
|
||||
;; Variable n is known to be number in type-env
|
||||
(let ((ppt (test-prim-param-types))
|
||||
(tenv {"n" "number"}))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "inc" (rest (first (sx-parse "(inc n)")))
|
||||
tenv (test-prim-types) ppt nil)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "variable with wrong type fails check"
|
||||
;; Variable s is known to be string in type-env
|
||||
(let ((ppt (test-prim-param-types))
|
||||
(tenv {"s" "string"}))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "inc" (rest (first (sx-parse "(inc s)")))
|
||||
tenv (test-prim-types) ppt nil)))
|
||||
(assert-true (> (len diagnostics) 0)))))
|
||||
|
||||
(deftest "any-typed variable skips check"
|
||||
;; Variable x has type any — should not produce errors
|
||||
(let ((ppt (test-prim-param-types))
|
||||
(tenv {"x" "any"}))
|
||||
(let ((diagnostics
|
||||
(check-primitive-call "upper" (rest (first (sx-parse "(upper x)")))
|
||||
tenv (test-prim-types) ppt nil)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "body-walk catches primitive errors in component"
|
||||
;; Manually build a component and check it via check-body-walk directly
|
||||
(let ((ppt (test-prim-param-types))
|
||||
(body (first (sx-parse "(div (+ name 1))")))
|
||||
(type-env {"name" "string"})
|
||||
(diagnostics (list)))
|
||||
(check-body-walk body "~bad-math" type-env (test-prim-types) ppt (test-env) diagnostics nil nil)
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "error" (get (first diagnostics) "level")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; deftype — type aliases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deftype-alias"
|
||||
(deftest "simple alias resolves"
|
||||
(let ((registry {"price" {:name "price" :params () :body "number"}}))
|
||||
(assert-equal "number" (resolve-type "price" registry))))
|
||||
|
||||
(deftest "alias chain resolves"
|
||||
(let ((registry {"price" {:name "price" :params () :body "number"}
|
||||
"cost" {:name "cost" :params () :body "price"}}))
|
||||
(assert-equal "number" (resolve-type "cost" registry))))
|
||||
|
||||
(deftest "unknown type passes through"
|
||||
(let ((registry {"price" {:name "price" :params () :body "number"}}))
|
||||
(assert-equal "string" (resolve-type "string" registry))))
|
||||
|
||||
(deftest "subtype-resolved? works through alias"
|
||||
(let ((registry {"price" {:name "price" :params () :body "number"}}))
|
||||
(assert-true (subtype-resolved? "price" "number" registry))
|
||||
(assert-true (subtype-resolved? "number" "price" registry)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; deftype — union types
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deftype-union"
|
||||
(deftest "union resolves"
|
||||
(let ((registry {"status" {:name "status" :params (list) :body (list "or" "string" "number")}}))
|
||||
(let ((resolved (resolve-type "status" registry)))
|
||||
(assert-true (= (type-of resolved) "list"))
|
||||
(assert-equal "or" (first resolved)))))
|
||||
|
||||
(deftest "subtype through named union"
|
||||
(let ((registry {"status" {:name "status" :params (list) :body (list "or" "string" "number")}}))
|
||||
(assert-true (subtype-resolved? "string" "status" registry))
|
||||
(assert-true (subtype-resolved? "number" "status" registry))
|
||||
(assert-false (subtype-resolved? "boolean" "status" registry)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; deftype — record types
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deftype-record"
|
||||
(deftest "record resolves to dict"
|
||||
(let ((registry {"card-props" {:name "card-props" :params ()
|
||||
:body {"title" "string" "price" "number"}}}))
|
||||
(let ((resolved (resolve-type "card-props" registry)))
|
||||
(assert-equal "dict" (type-of resolved))
|
||||
(assert-equal "string" (get resolved "title"))
|
||||
(assert-equal "number" (get resolved "price")))))
|
||||
|
||||
(deftest "record structural subtyping"
|
||||
(let ((registry {"card-props" {:name "card-props" :params ()
|
||||
:body {"title" "string" "price" "number"}}
|
||||
"titled" {:name "titled" :params ()
|
||||
:body {"title" "string"}}}))
|
||||
;; card-props has title+price, titled has just title
|
||||
;; card-props <: titled (has all required fields)
|
||||
(assert-true (subtype-resolved? "card-props" "titled" registry))))
|
||||
|
||||
(deftest "get infers field type from record"
|
||||
(let ((registry {"card-props" {:name "card-props" :params (list)
|
||||
:body {"title" "string" "price" "number"}}})
|
||||
(type-env {"d" "card-props"})
|
||||
(expr (first (sx-parse "(get d :title)"))))
|
||||
(assert-equal "string"
|
||||
(infer-type expr type-env (test-prim-types) registry)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; deftype — parameterized types
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deftype-parameterized"
|
||||
(deftest "maybe instantiation"
|
||||
(let ((registry {"maybe" {:name "maybe" :params (list "a")
|
||||
:body (list "or" "a" "nil")}}))
|
||||
(let ((resolved (resolve-type (list "maybe" "string") registry)))
|
||||
(assert-true (= (type-of resolved) "list"))
|
||||
(assert-equal "or" (first resolved))
|
||||
(assert-true (contains? resolved "string"))
|
||||
(assert-true (contains? resolved "nil")))))
|
||||
|
||||
(deftest "subtype through parameterized type"
|
||||
(let ((registry {"maybe" {:name "maybe" :params (list "a")
|
||||
:body (list "or" "a" "nil")}}))
|
||||
(assert-true (subtype-resolved? "string" (list "maybe" "string") registry))
|
||||
(assert-true (subtype-resolved? "nil" (list "maybe" "string") registry))
|
||||
(assert-false (subtype-resolved? "number" (list "maybe" "string") registry))))
|
||||
|
||||
(deftest "substitute-type-vars works"
|
||||
(let ((result (substitute-type-vars (list "or" "a" "nil") (list "a") (list "number"))))
|
||||
(assert-equal "or" (first result))
|
||||
(assert-true (contains? result "number"))
|
||||
(assert-true (contains? result "nil")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defeffect — effect basics
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defeffect-basics"
|
||||
(deftest "get-effects returns nil for unannotated"
|
||||
(let ((anns {"fetch" ("io")}))
|
||||
(assert-true (nil? (get-effects "unknown" anns)))))
|
||||
|
||||
(deftest "get-effects returns effects for annotated"
|
||||
(let ((anns {"fetch" ("io")}))
|
||||
(assert-equal (list "io") (get-effects "fetch" anns))))
|
||||
|
||||
(deftest "nil annotations returns nil"
|
||||
(assert-true (nil? (get-effects "anything" nil)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defeffect — effect checking
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "effect-checking"
|
||||
(deftest "pure cannot call io"
|
||||
(let ((anns {"~pure-comp" () "fetch" ("io")}))
|
||||
(let ((diagnostics (check-effect-call "fetch" (list) anns "~pure-comp")))
|
||||
(assert-true (> (len diagnostics) 0))
|
||||
(assert-equal "error" (get (first diagnostics) "level")))))
|
||||
|
||||
(deftest "io context allows io"
|
||||
(let ((anns {"~io-comp" ("io") "fetch" ("io")}))
|
||||
(let ((diagnostics (check-effect-call "fetch" (list "io") anns "~io-comp")))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "unannotated caller allows everything"
|
||||
(let ((anns {"fetch" ("io")}))
|
||||
(let ((diagnostics (check-effect-call "fetch" nil anns "~unknown")))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "unannotated callee skips check"
|
||||
(let ((anns {"~pure-comp" ()}))
|
||||
(let ((diagnostics (check-effect-call "unknown-fn" (list) anns "~pure-comp")))
|
||||
(assert-equal 0 (len diagnostics))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defeffect — subset checking
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "effect-subset"
|
||||
(deftest "empty is subset of anything"
|
||||
(assert-true (effects-subset? (list) (list "io")))
|
||||
(assert-true (effects-subset? (list) (list))))
|
||||
|
||||
(deftest "io is subset of io"
|
||||
(assert-true (effects-subset? (list "io") (list "io" "async"))))
|
||||
|
||||
(deftest "io is not subset of pure"
|
||||
(assert-false (effects-subset? (list "io") (list))))
|
||||
|
||||
(deftest "nil callee skips check"
|
||||
(assert-true (effects-subset? nil (list))))
|
||||
|
||||
(deftest "nil caller allows all"
|
||||
(assert-true (effects-subset? (list "io") nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-effect-annotations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "build-effect-annotations"
|
||||
(deftest "builds annotations from io declarations"
|
||||
(let ((decls (list {"name" "fetch"} {"name" "save!"}))
|
||||
(anns (build-effect-annotations decls)))
|
||||
(assert-equal (list "io") (get anns "fetch"))
|
||||
(assert-equal (list "io") (get anns "save!"))))
|
||||
|
||||
(deftest "skips entries without name"
|
||||
(let ((decls (list {"name" "fetch"} {"other" "x"}))
|
||||
(anns (build-effect-annotations decls)))
|
||||
(assert-true (has-key? anns "fetch"))
|
||||
(assert-false (has-key? anns "other"))))
|
||||
|
||||
(deftest "empty declarations produce empty dict"
|
||||
(let ((anns (build-effect-annotations (list))))
|
||||
(assert-equal 0 (len (keys anns))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; check-component-effects
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "check-component-effects"
|
||||
(deftest "pure component calling io produces diagnostic"
|
||||
;; Define component in a local env so check-component-effects can find it
|
||||
(let ((e (env-extend (test-env))))
|
||||
(eval-expr-cek (sx-parse-one "(defcomp ~eff-pure-card () :effects [] (div (fetch \"url\")))") e)
|
||||
(let ((anns {"~eff-pure-card" () "fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-pure-card" e anns)))
|
||||
(assert-true (> (len diagnostics) 0)))))
|
||||
|
||||
(deftest "io component calling io produces no diagnostic"
|
||||
(let ((e (env-extend (test-env))))
|
||||
(eval-expr-cek (sx-parse-one "(defcomp ~eff-io-card () :effects [io] (div (fetch \"url\")))") e)
|
||||
(let ((anns {"~eff-io-card" ("io") "fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-io-card" e anns)))
|
||||
(assert-equal 0 (len diagnostics)))))
|
||||
|
||||
(deftest "unannotated component skips check"
|
||||
(let ((e (env-extend (test-env))))
|
||||
(eval-expr-cek (sx-parse-one "(defcomp ~eff-unannot-card () (div (fetch \"url\")))") e)
|
||||
(let ((anns {"fetch" ("io")})
|
||||
(diagnostics (check-component-effects "~eff-unannot-card" e anns)))
|
||||
(assert-equal 0 (len diagnostics))))))
|
||||
244
lib/tests/test-vm-closures.sx
Normal file
244
lib/tests/test-vm-closures.sx
Normal file
@@ -0,0 +1,244 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm-closures.sx — Tests for inner closure recursion patterns
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;;
|
||||
;; These tests exercise patterns where inner closures recurse deeply
|
||||
;; while sharing mutable state via upvalues. This is the sx-parse
|
||||
;; pattern: many inner functions close over a mutable cursor variable.
|
||||
;; Without proper VM closure support, each recursive call would
|
||||
;; allocate a fresh VM — blowing the stack or hanging.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Inner closure recursion with mutable upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "inner-closure-recursion"
|
||||
(deftest "self-recursive inner closure with set! on captured variable"
|
||||
;; Pattern: closure mutates captured var on each recursive call.
|
||||
;; This is the core pattern in skip-ws, read-str-loop, etc.
|
||||
(let ((counter 0))
|
||||
(define count-up
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! counter (+ counter 1))
|
||||
(count-up (- n 1)))))
|
||||
(count-up 100)
|
||||
(assert-equal 100 counter)))
|
||||
|
||||
(deftest "deep inner closure recursion (500 iterations)"
|
||||
;; Stress test: 500 recursive calls through an inner closure
|
||||
;; mutating a shared upvalue. Would stack-overflow without TCO.
|
||||
(let ((acc 0))
|
||||
(define sum-up
|
||||
(fn (n)
|
||||
(if (<= n 0)
|
||||
acc
|
||||
(do (set! acc (+ acc n))
|
||||
(sum-up (- n 1))))))
|
||||
(assert-equal 125250 (sum-up 500))))
|
||||
|
||||
(deftest "inner closure reading captured variable updated by another"
|
||||
;; Two closures: one writes, one reads, sharing the same binding.
|
||||
(let ((pos 0))
|
||||
(define advance! (fn () (set! pos (+ pos 1))))
|
||||
(define current (fn () pos))
|
||||
(advance!)
|
||||
(advance!)
|
||||
(advance!)
|
||||
(assert-equal 3 (current))))
|
||||
|
||||
(deftest "recursive closure with multiple mutable upvalues"
|
||||
;; Like sx-parse: multiple cursor variables mutated during recursion.
|
||||
(let ((pos 0)
|
||||
(count 0))
|
||||
(define scan
|
||||
(fn (source)
|
||||
(when (< pos (len source))
|
||||
(set! count (+ count 1))
|
||||
(set! pos (+ pos 1))
|
||||
(scan source))))
|
||||
(scan "hello world")
|
||||
(assert-equal 11 pos)
|
||||
(assert-equal 11 count))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mutual recursion between inner closures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "mutual-inner-closures"
|
||||
(deftest "two inner closures calling each other"
|
||||
;; Pattern: read-expr calls read-list, read-list calls read-expr.
|
||||
(let ((result (list)))
|
||||
(define process-a
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "a:" (first items)))
|
||||
(process-b (rest items)))))
|
||||
(define process-b
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "b:" (first items)))
|
||||
(process-a (rest items)))))
|
||||
(process-a (list 1 2 3 4))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a:1" (nth result 0))
|
||||
(assert-equal "b:2" (nth result 1))
|
||||
(assert-equal "a:3" (nth result 2))
|
||||
(assert-equal "b:4" (nth result 3))))
|
||||
|
||||
(deftest "mutual recursion with shared mutable state"
|
||||
;; Both closures read and write the same captured variable.
|
||||
(let ((pos 0)
|
||||
(source "aAbBcC"))
|
||||
(define skip-lower
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "a")
|
||||
(<= (nth source pos) "z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-upper))))
|
||||
(define skip-upper
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "A")
|
||||
(<= (nth source pos) "Z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-lower))))
|
||||
(skip-lower)
|
||||
(assert-equal 6 pos)))
|
||||
|
||||
(deftest "three-way mutual recursion"
|
||||
(let ((n 30)
|
||||
(result nil))
|
||||
(define step-a
|
||||
(fn (i)
|
||||
(if (>= i n)
|
||||
(set! result "done")
|
||||
(step-b (+ i 1)))))
|
||||
(define step-b
|
||||
(fn (i)
|
||||
(step-c (+ i 1))))
|
||||
(define step-c
|
||||
(fn (i)
|
||||
(step-a (+ i 1))))
|
||||
(step-a 0)
|
||||
(assert-equal "done" result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parser-like patterns (the sx-parse structure)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-pattern"
|
||||
(deftest "mini-parser: tokenize digits from string"
|
||||
;; Simplified sx-parse pattern: closure over pos + source,
|
||||
;; multiple inner functions sharing the mutable cursor.
|
||||
(let ((pos 0)
|
||||
(source "12 34 56")
|
||||
(len-src 8))
|
||||
|
||||
(define skip-ws
|
||||
(fn ()
|
||||
(when (and (< pos len-src) (= (nth source pos) " "))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-ws))))
|
||||
|
||||
(define read-digits
|
||||
(fn ()
|
||||
(let ((start pos))
|
||||
(define digit-loop
|
||||
(fn ()
|
||||
(when (and (< pos len-src)
|
||||
(>= (nth source pos) "0")
|
||||
(<= (nth source pos) "9"))
|
||||
(set! pos (+ pos 1))
|
||||
(digit-loop))))
|
||||
(digit-loop)
|
||||
(slice source start pos))))
|
||||
|
||||
(define read-all
|
||||
(fn ()
|
||||
(let ((tokens (list)))
|
||||
(define parse-loop
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(when (< pos len-src)
|
||||
(append! tokens (read-digits))
|
||||
(parse-loop))))
|
||||
(parse-loop)
|
||||
tokens)))
|
||||
|
||||
(let ((tokens (read-all)))
|
||||
(assert-equal 3 (len tokens))
|
||||
(assert-equal "12" (nth tokens 0))
|
||||
(assert-equal "34" (nth tokens 1))
|
||||
(assert-equal "56" (nth tokens 2)))))
|
||||
|
||||
(deftest "nested inner closures with upvalue chain"
|
||||
;; Inner function defines its own inner function,
|
||||
;; both closing over the outer mutable variable.
|
||||
(let ((total 0))
|
||||
(define outer-fn
|
||||
(fn (items)
|
||||
(for-each
|
||||
(fn (item)
|
||||
(let ((sub-total 0))
|
||||
(define inner-loop
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! sub-total (+ sub-total 1))
|
||||
(set! total (+ total 1))
|
||||
(inner-loop (- n 1)))))
|
||||
(inner-loop item)))
|
||||
items)))
|
||||
(outer-fn (list 3 2 1))
|
||||
(assert-equal 6 total)))
|
||||
|
||||
(deftest "closure returning accumulated list via append!"
|
||||
;; Pattern from read-list: loop appends to mutable list, returns it.
|
||||
(let ((items (list)))
|
||||
(define collect
|
||||
(fn (source pos)
|
||||
(if (>= pos (len source))
|
||||
items
|
||||
(do (append! items (nth source pos))
|
||||
(collect source (+ pos 1))))))
|
||||
(let ((result (collect (list "a" "b" "c" "d") 0)))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a" (first result))
|
||||
(assert-equal "d" (last result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures as callbacks to higher-order functions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "closure-ho-callbacks"
|
||||
(deftest "map with closure that mutates captured variable"
|
||||
(let ((running-total 0))
|
||||
(let ((results (map (fn (x)
|
||||
(set! running-total (+ running-total x))
|
||||
running-total)
|
||||
(list 1 2 3 4))))
|
||||
(assert-equal (list 1 3 6 10) results)
|
||||
(assert-equal 10 running-total))))
|
||||
|
||||
(deftest "reduce with closure over external state"
|
||||
(let ((call-count 0))
|
||||
(let ((sum (reduce (fn (acc x)
|
||||
(set! call-count (+ call-count 1))
|
||||
(+ acc x))
|
||||
0
|
||||
(list 10 20 30))))
|
||||
(assert-equal 60 sum)
|
||||
(assert-equal 3 call-count))))
|
||||
|
||||
(deftest "filter with closure reading shared state"
|
||||
(let ((threshold 3))
|
||||
(let ((result (filter (fn (x) (> x threshold))
|
||||
(list 1 2 3 4 5))))
|
||||
(assert-equal (list 4 5) result)))))
|
||||
495
lib/tests/test-vm.sx
Normal file
495
lib/tests/test-vm.sx
Normal file
@@ -0,0 +1,495 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx)
|
||||
;;
|
||||
;; Requires: test-framework.sx, compiler.sx, vm.sx loaded.
|
||||
;; Tests the compile → bytecode → VM execution pipeline.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Helper: compile an SX expression and execute it on the VM.
|
||||
;; Returns the result value.
|
||||
(define vm-eval
|
||||
(fn (expr)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module
|
||||
(code-from-value code)
|
||||
{}))))
|
||||
|
||||
;; Helper: compile and run with a pre-populated globals dict.
|
||||
(define vm-eval-with
|
||||
(fn (expr globals)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module (code-from-value code) globals))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constants and literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-constants"
|
||||
(deftest "number constant"
|
||||
(assert-equal 42 (vm-eval 42)))
|
||||
|
||||
(deftest "string constant"
|
||||
(assert-equal "hello" (vm-eval "hello")))
|
||||
|
||||
(deftest "boolean true"
|
||||
(assert-equal true (vm-eval true)))
|
||||
|
||||
(deftest "boolean false"
|
||||
(assert-equal false (vm-eval false)))
|
||||
|
||||
(deftest "nil constant"
|
||||
(assert-nil (vm-eval nil)))
|
||||
|
||||
(deftest "negative number"
|
||||
(assert-equal -7 (vm-eval -7)))
|
||||
|
||||
(deftest "float constant"
|
||||
(assert-equal 3.14 (vm-eval 3.14))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic via primitives
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-arithmetic"
|
||||
(deftest "addition"
|
||||
(assert-equal 5 (vm-eval '(+ 2 3))))
|
||||
|
||||
(deftest "subtraction"
|
||||
(assert-equal 7 (vm-eval '(- 10 3))))
|
||||
|
||||
(deftest "multiplication"
|
||||
(assert-equal 24 (vm-eval '(* 6 4))))
|
||||
|
||||
(deftest "division"
|
||||
(assert-equal 5 (vm-eval '(/ 10 2))))
|
||||
|
||||
(deftest "nested arithmetic"
|
||||
(assert-equal 14 (vm-eval '(+ (* 3 4) 2))))
|
||||
|
||||
(deftest "three-arg addition"
|
||||
(assert-equal 15 (vm-eval '(+ 5 4 6)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison and logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-comparison"
|
||||
(deftest "equal numbers"
|
||||
(assert-equal true (vm-eval '(= 1 1))))
|
||||
|
||||
(deftest "unequal numbers"
|
||||
(assert-equal false (vm-eval '(= 1 2))))
|
||||
|
||||
(deftest "less than"
|
||||
(assert-equal true (vm-eval '(< 1 2))))
|
||||
|
||||
(deftest "greater than"
|
||||
(assert-equal true (vm-eval '(> 5 3))))
|
||||
|
||||
(deftest "not"
|
||||
(assert-equal true (vm-eval '(not false))))
|
||||
|
||||
(deftest "not truthy"
|
||||
(assert-equal false (vm-eval '(not 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow — if, when, cond, and, or
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-control-flow"
|
||||
(deftest "if true branch"
|
||||
(assert-equal 1 (vm-eval '(if true 1 2))))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal 2 (vm-eval '(if false 1 2))))
|
||||
|
||||
(deftest "if without else returns nil"
|
||||
(assert-nil (vm-eval '(if false 1))))
|
||||
|
||||
(deftest "when true evaluates body"
|
||||
(assert-equal 42 (vm-eval '(when true 42))))
|
||||
|
||||
(deftest "when false returns nil"
|
||||
(assert-nil (vm-eval '(when false 42))))
|
||||
|
||||
(deftest "and short-circuits on false"
|
||||
(assert-equal false (vm-eval '(and true false 42))))
|
||||
|
||||
(deftest "and returns last truthy"
|
||||
(assert-equal 3 (vm-eval '(and 1 2 3))))
|
||||
|
||||
(deftest "or short-circuits on true"
|
||||
(assert-equal 1 (vm-eval '(or 1 false 2))))
|
||||
|
||||
(deftest "or returns false when all falsy"
|
||||
(assert-equal false (vm-eval '(or false false false))))
|
||||
|
||||
(deftest "cond first match"
|
||||
(assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two"))))
|
||||
|
||||
(deftest "cond else clause"
|
||||
(assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none"))))
|
||||
|
||||
(deftest "case match"
|
||||
(assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other"))))
|
||||
|
||||
(deftest "case else"
|
||||
(assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Let bindings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-let"
|
||||
(deftest "single binding"
|
||||
(assert-equal 10 (vm-eval '(let ((x 10)) x))))
|
||||
|
||||
(deftest "multiple bindings"
|
||||
(assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y)))))
|
||||
|
||||
(deftest "bindings are sequential"
|
||||
(assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y))))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y))))))
|
||||
|
||||
(deftest "inner let shadows outer"
|
||||
(assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x)))))
|
||||
|
||||
(deftest "let body returns last expression"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lambda and function calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-lambda"
|
||||
(deftest "lambda call"
|
||||
(assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5)))))
|
||||
|
||||
(deftest "lambda with multiple params"
|
||||
(assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6)))))
|
||||
|
||||
(deftest "higher-order: pass lambda to lambda"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((apply-fn (fn (f x) (f x)))
|
||||
(double (fn (n) (* n 2))))
|
||||
(apply-fn double 5)))))
|
||||
|
||||
(deftest "lambda returns lambda"
|
||||
(assert-equal 15
|
||||
(vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x)))))
|
||||
(let ((add10 (make-adder 10)))
|
||||
(add10 5))))))
|
||||
|
||||
(deftest "immediately invoked lambda"
|
||||
(assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures and upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-closures"
|
||||
(deftest "closure captures local"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((f (fn () x)))
|
||||
(f))))))
|
||||
|
||||
(deftest "closure captures through two levels"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((y 20))
|
||||
(let ((f (fn () (+ x y))))
|
||||
(f)))))))
|
||||
|
||||
(deftest "two closures share upvalue"
|
||||
(assert-equal 42
|
||||
(vm-eval '(let ((x 0))
|
||||
(let ((set-x (fn (v) (set! x v)))
|
||||
(get-x (fn () x)))
|
||||
(set-x 42)
|
||||
(get-x))))))
|
||||
|
||||
(deftest "closure mutation visible to sibling"
|
||||
(assert-equal 3
|
||||
(vm-eval '(let ((counter 0))
|
||||
(let ((inc! (fn () (set! counter (+ counter 1)))))
|
||||
(inc!)
|
||||
(inc!)
|
||||
(inc!)
|
||||
counter))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tail call optimization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-tco"
|
||||
(deftest "tail-recursive loop doesn't overflow"
|
||||
;; Count down from 10000 — would overflow without TCO
|
||||
(assert-equal 0
|
||||
(vm-eval '(let ((loop (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(loop (- n 1))))))
|
||||
(loop 10000)))))
|
||||
|
||||
(deftest "tail-recursive accumulator"
|
||||
(assert-equal 5050
|
||||
(vm-eval '(let ((sum (fn (n acc)
|
||||
(if (<= n 0) acc
|
||||
(sum (- n 1) (+ acc n))))))
|
||||
(sum 100 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collections
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-collections"
|
||||
(deftest "list construction"
|
||||
(assert-equal (list 1 2 3) (vm-eval '(list 1 2 3))))
|
||||
|
||||
(deftest "empty list"
|
||||
(assert-equal (list) (vm-eval '(list))))
|
||||
|
||||
(deftest "dict construction"
|
||||
(let ((d (vm-eval '{:a 1 :b 2})))
|
||||
(assert-equal 1 (get d "a"))
|
||||
(assert-equal 2 (get d "b"))))
|
||||
|
||||
(deftest "list operations"
|
||||
(assert-equal 1 (vm-eval '(first (list 1 2 3))))
|
||||
(assert-equal 3 (vm-eval '(len (list 1 2 3)))))
|
||||
|
||||
(deftest "nested list"
|
||||
(assert-equal (list 1 (list 2 3))
|
||||
(vm-eval '(list 1 (list 2 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-strings"
|
||||
(deftest "str concat"
|
||||
(assert-equal "hello world" (vm-eval '(str "hello" " " "world"))))
|
||||
|
||||
(deftest "string-length"
|
||||
(assert-equal 5 (vm-eval '(string-length "hello"))))
|
||||
|
||||
(deftest "str coerces numbers"
|
||||
(assert-equal "42" (vm-eval '(str 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Define — top-level and local
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-define"
|
||||
(deftest "top-level define"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do (define x 42) x))))
|
||||
|
||||
(deftest "define function then call"
|
||||
(assert-equal 10
|
||||
(vm-eval '(do
|
||||
(define double (fn (n) (* n 2)))
|
||||
(double 5)))))
|
||||
|
||||
(deftest "local define inside fn"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((f (fn (x)
|
||||
(define y (* x 2))
|
||||
(+ x y))))
|
||||
(f 10)))))
|
||||
|
||||
(deftest "define with forward reference"
|
||||
(assert-equal 120
|
||||
(vm-eval '(do
|
||||
(define fact (fn (n)
|
||||
(if (<= n 1) 1 (* n (fact (- n 1))))))
|
||||
(fact 5))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Letrec — mutual recursion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-letrec"
|
||||
(deftest "letrec self-recursion"
|
||||
(assert-equal 55
|
||||
(vm-eval '(letrec ((sum-to (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(+ n (sum-to (- n 1)))))))
|
||||
(sum-to 10)))))
|
||||
|
||||
(deftest "letrec mutual recursion"
|
||||
(assert-equal true
|
||||
(vm-eval '(letrec ((my-even? (fn (n)
|
||||
(if (= n 0) true (my-odd? (- n 1)))))
|
||||
(my-odd? (fn (n)
|
||||
(if (= n 0) false (my-even? (- n 1))))))
|
||||
(my-even? 10))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quasiquote
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-quasiquote"
|
||||
(deftest "simple quasiquote"
|
||||
(assert-equal (list 1 2 3)
|
||||
(vm-eval '(let ((x 2)) `(1 ,x 3)))))
|
||||
|
||||
(deftest "quasiquote with splice"
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Thread macro
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-threading"
|
||||
(deftest "thread-first"
|
||||
(assert-equal 7
|
||||
(vm-eval '(-> 5 (+ 2)))))
|
||||
|
||||
(deftest "thread-first chain"
|
||||
(assert-equal 12
|
||||
(vm-eval '(-> 10 (+ 5) (- 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Integration: compile then execute
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-integration"
|
||||
(deftest "fibonacci"
|
||||
(assert-equal 55
|
||||
(vm-eval '(do
|
||||
(define fib (fn (n)
|
||||
(if (<= n 1) n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
(fib 10)))))
|
||||
|
||||
(deftest "map via recursive define"
|
||||
(assert-equal (list 2 4 6)
|
||||
(vm-eval '(do
|
||||
(define my-map (fn (f lst)
|
||||
(if (empty? lst) (list)
|
||||
(cons (f (first lst)) (my-map f (rest lst))))))
|
||||
(my-map (fn (x) (* x 2)) (list 1 2 3))))))
|
||||
|
||||
(deftest "filter via recursive define"
|
||||
(assert-equal (list 2 4)
|
||||
(vm-eval '(do
|
||||
(define my-filter (fn (pred lst)
|
||||
(if (empty? lst) (list)
|
||||
(if (pred (first lst))
|
||||
(cons (first lst) (my-filter pred (rest lst)))
|
||||
(my-filter pred (rest lst))))))
|
||||
(my-filter (fn (x) (even? x)) (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "reduce via recursive define"
|
||||
(assert-equal 15
|
||||
(vm-eval '(do
|
||||
(define my-reduce (fn (f acc lst)
|
||||
(if (empty? lst) acc
|
||||
(my-reduce f (f acc (first lst)) (rest lst)))))
|
||||
(my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "nested function calls"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do
|
||||
(define compose (fn (f g) (fn (x) (f (g x)))))
|
||||
(define inc (fn (x) (+ x 1)))
|
||||
(define double (fn (x) (* x 2)))
|
||||
(let ((inc-then-double (compose double inc)))
|
||||
(inc-then-double 20)))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; VM recursive mutation — closure capture must preserve mutable references
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The stepper island's
|
||||
;; split-tag function produced 1 step instead of 16, breaking SSR.
|
||||
|
||||
(defsuite "vm-recursive-mutation"
|
||||
(deftest "recursive append! to shared list"
|
||||
(assert-equal 3
|
||||
(vm-eval '(do
|
||||
(define walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive tree walk with append!"
|
||||
(assert-equal 7
|
||||
(vm-eval '(do
|
||||
(define walk-children (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-children (rest items) result walk-fn))))
|
||||
(define walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(walk-children (rest expr) result walk)
|
||||
(append! result "close")))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive walk matching stepper split-tag pattern"
|
||||
(assert-equal 16
|
||||
(vm-eval '(do
|
||||
(define walk-each (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-each (rest items) result walk-fn))))
|
||||
(define collect-children (fn (items cch)
|
||||
(when (not (empty? items))
|
||||
(let ((a (first items)))
|
||||
(if (and (list? a) (not (empty? a))
|
||||
(= (type-of (first a)) "symbol")
|
||||
(starts-with? (symbol-name (first a)) "~"))
|
||||
nil ;; skip component spreads
|
||||
(append! cch a))
|
||||
(collect-children (rest items) cch)))))
|
||||
(define split-tag (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
(not (= (type-of (first expr)) "symbol"))
|
||||
(append! result "leaf")
|
||||
(is-html-tag? (symbol-name (first expr)))
|
||||
(let ((cch (list)))
|
||||
(collect-children (rest expr) cch)
|
||||
(append! result "open")
|
||||
(walk-each cch result split-tag)
|
||||
(append! result "close"))
|
||||
:else
|
||||
(append! result "expr"))))
|
||||
(let ((parsed (sx-parse "(div (~cssx/tw :tokens \"text-center\")\n (h1 (~cssx/tw :tokens \"text-3xl font-bold mb-2\")\n (span (~cssx/tw :tokens \"text-rose-500\") \"the \")\n (span (~cssx/tw :tokens \"text-amber-500\") \"joy \")\n (span (~cssx/tw :tokens \"text-emerald-500\") \"of \")\n (span (~cssx/tw :tokens \"text-violet-600 text-4xl\") \"sx\")))"))
|
||||
(result (list)))
|
||||
(split-tag (first parsed) result)
|
||||
(len result)))))))
|
||||
117
lib/tests/vm-inline.sx
Normal file
117
lib/tests/vm-inline.sx
Normal file
@@ -0,0 +1,117 @@
|
||||
;; vm-inline.sx — Tests for inline VM opcodes (OP_ADD, OP_EQ, etc.)
|
||||
;;
|
||||
;; These verify that the JIT-compiled inline opcodes produce
|
||||
;; identical results to the CALL_PRIM fallback.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline + integers" (= (+ 3 4) 7))
|
||||
(test "inline + floats" (= (+ 1.5 2.5) 4.0))
|
||||
(test "inline + string concat" (= (+ "hello" " world") "hello world"))
|
||||
(test "inline - integers" (= (- 10 3) 7))
|
||||
(test "inline - negative" (= (- 3 10) -7))
|
||||
(test "inline * integers" (= (* 6 7) 42))
|
||||
(test "inline * float" (= (* 2.5 4.0) 10.0))
|
||||
(test "inline / integers" (= (/ 10 2) 5))
|
||||
(test "inline / float" (= (/ 7.0 2.0) 3.5))
|
||||
(test "inline inc" (= (inc 5) 6))
|
||||
(test "inline dec" (= (dec 5) 4))
|
||||
(test "inline inc float" (= (inc 2.5) 3.5))
|
||||
(test "inline dec zero" (= (dec 0) -1))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline = numbers" (= 5 5))
|
||||
(test "inline = strings" (= "hello" "hello"))
|
||||
(test "inline = false" (not (= 5 6)))
|
||||
(test "inline = nil" (= nil nil))
|
||||
(test "inline = mixed false" (not (= 5 "5")))
|
||||
(test "inline < numbers" (< 3 5))
|
||||
(test "inline < false" (not (< 5 3)))
|
||||
(test "inline < equal" (not (< 5 5)))
|
||||
(test "inline < strings" (< "abc" "def"))
|
||||
(test "inline > numbers" (> 5 3))
|
||||
(test "inline > false" (not (> 3 5)))
|
||||
(test "inline > equal" (not (> 5 5)))
|
||||
(test "inline not true" (= (not true) false))
|
||||
(test "inline not false" (= (not false) true))
|
||||
(test "inline not nil" (= (not nil) true))
|
||||
(test "inline not number" (= (not 0) true))
|
||||
(test "inline not string" (= (not "") true))
|
||||
(test "inline not nonempty" (= (not "x") false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection ops
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline len list" (= (len (list 1 2 3)) 3))
|
||||
(test "inline len string" (= (len "hello") 5))
|
||||
(test "inline len empty" (= (len (list)) 0))
|
||||
(test "inline len nil" (= (len nil) 0))
|
||||
(test "inline first" (= (first (list 10 20 30)) 10))
|
||||
(test "inline first empty" (= (first (list)) nil))
|
||||
(test "inline rest" (= (rest (list 1 2 3)) (list 2 3)))
|
||||
(test "inline rest single" (= (rest (list 1)) (list)))
|
||||
(test "inline nth" (= (nth (list 10 20 30) 1) 20))
|
||||
(test "inline nth zero" (= (nth (list 10 20 30) 0) 10))
|
||||
(test "inline nth out of bounds" (= (nth (list 1 2) 5) nil))
|
||||
(test "inline cons" (= (cons 1 (list 2 3)) (list 1 2 3)))
|
||||
(test "inline cons to empty" (= (cons 1 (list)) (list 1)))
|
||||
(test "inline cons to nil" (= (cons 1 nil) (list 1)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Composition — inline ops in expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "nested arithmetic" (= (+ (* 3 4) (- 10 5)) 17))
|
||||
(test "comparison in if" (if (< 3 5) "yes" "no") (= "yes"))
|
||||
(test "len in condition" (if (> (len (list 1 2 3)) 2) true false))
|
||||
(test "inc in loop" (= (let ((x 0)) (for-each (fn (_) (set! x (inc x))) (list 1 2 3)) x) 3))
|
||||
(test "first + rest roundtrip" (= (cons (first (list 1 2 3)) (rest (list 1 2 3))) (list 1 2 3)))
|
||||
(test "nested comparison" (= (and (< 1 2) (> 3 0) (= 5 5)) true))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "+ with nil" (= (+ 5 nil) 5))
|
||||
(test "len of dict" (= (len {:a 1 :b 2}) 2))
|
||||
(test "= with booleans" (= (= true true) true))
|
||||
(test "= with keywords" (= (= :foo :foo) true))
|
||||
(test "not with list" (= (not (list 1)) false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Recursive mutation — VM closure capture must preserve mutable state
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The VM closure capture
|
||||
;; was copying the list value instead of sharing the mutable reference.
|
||||
|
||||
(test "recursive append! to shared list"
|
||||
(let ((walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result)))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(= (len result) 3))))
|
||||
|
||||
(test "recursive tree walk with append!"
|
||||
(let ((walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(for-each (fn (c) (walk c result)) (rest expr))
|
||||
(append! result "close"))))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(= (len result) 7))))
|
||||
Reference in New Issue
Block a user