Add comprehensive spec tests: closures, macros, TCO, defcomp, parser
New test files expose fundamental evaluator issues: - define doesn't create self-referencing closures (13 failures) - let doesn't isolate scope from parent env (2 failures) - set! doesn't walk scope chain for closed-over vars (3 failures) - Component calls return kwargs object instead of evaluating body (10 failures) 485/516 passing (94%). Parser tests: 100% pass. Macro tests: 96% pass. These failures map the exact work needed for tree-walk removal. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -14,7 +14,8 @@ global.window = global;
|
||||
global.addEventListener = () => {};
|
||||
global.self = global;
|
||||
global.document = {
|
||||
createElement: () => ({ style: {}, setAttribute: () => {}, appendChild: () => {} }),
|
||||
createElement: () => ({ style: {}, setAttribute: () => {}, appendChild: () => {}, children: [] }),
|
||||
createDocumentFragment: () => ({ appendChild: () => {}, children: [], childNodes: [] }),
|
||||
head: { appendChild: () => {} },
|
||||
body: { appendChild: () => {} },
|
||||
querySelector: () => null,
|
||||
|
||||
212
spec/tests/test-closures.sx
Normal file
212
spec/tests/test-closures.sx
Normal file
@@ -0,0 +1,212 @@
|
||||
;; ==========================================================================
|
||||
;; test-closures.sx — Comprehensive tests for closures and lexical scoping
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: eval.sx (lambda, let, define, set!)
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closure basics
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "closure-basics"
|
||||
(deftest "lambda captures variable from enclosing scope"
|
||||
(let ((x 10))
|
||||
(let ((f (fn () x)))
|
||||
(assert-equal 10 (f)))))
|
||||
|
||||
(deftest "lambda captures multiple variables"
|
||||
(let ((a 3) (b 4))
|
||||
(let ((hyp (fn () (+ (* a a) (* b b)))))
|
||||
(assert-equal 25 (hyp)))))
|
||||
|
||||
(deftest "returned lambda retains captured values"
|
||||
(define make-greeter
|
||||
(fn (greeting)
|
||||
(fn (name) (str greeting ", " name "!"))))
|
||||
(let ((hello (make-greeter "Hello")))
|
||||
(assert-equal "Hello, Alice!" (hello "Alice"))
|
||||
(assert-equal "Hello, Bob!" (hello "Bob"))))
|
||||
|
||||
(deftest "factory function returns independent closures"
|
||||
(define make-adder
|
||||
(fn (n) (fn (x) (+ n x))))
|
||||
(let ((add5 (make-adder 5))
|
||||
(add10 (make-adder 10)))
|
||||
(assert-equal 8 (add5 3))
|
||||
(assert-equal 13 (add10 3))
|
||||
(assert-equal 15 (add5 10))))
|
||||
|
||||
(deftest "counter via closure"
|
||||
(define make-counter
|
||||
(fn ()
|
||||
(let ((count 0))
|
||||
(fn ()
|
||||
(set! count (+ count 1))
|
||||
count))))
|
||||
(let ((counter (make-counter)))
|
||||
(assert-equal 1 (counter))
|
||||
(assert-equal 2 (counter))
|
||||
(assert-equal 3 (counter))))
|
||||
|
||||
(deftest "closure captures value at time of creation"
|
||||
;; Create closure when x=1, then rebind x to 99.
|
||||
;; The closure should still see 1, not 99.
|
||||
(let ((x 1))
|
||||
(let ((f (fn () x)))
|
||||
(let ((x 99))
|
||||
(assert-equal 1 (f)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lexical scope
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "lexical-scope"
|
||||
(deftest "inner binding shadows outer"
|
||||
(let ((x 1))
|
||||
(let ((x 2))
|
||||
(assert-equal 2 x))))
|
||||
|
||||
(deftest "shadow does not affect outer scope"
|
||||
(let ((x 1))
|
||||
(let ((x 2))
|
||||
(assert-equal 2 x))
|
||||
(assert-equal 1 x)))
|
||||
|
||||
(deftest "nested let scoping"
|
||||
(let ((x 1) (y 10))
|
||||
(let ((x 2) (z 100))
|
||||
(assert-equal 2 x)
|
||||
(assert-equal 10 y)
|
||||
(assert-equal 100 z))
|
||||
(assert-equal 1 x)))
|
||||
|
||||
(deftest "lambda body sees its own let bindings"
|
||||
(let ((f (fn (x)
|
||||
(let ((y (* x 2)))
|
||||
(+ x y)))))
|
||||
(assert-equal 9 (f 3))
|
||||
(assert-equal 15 (f 5))))
|
||||
|
||||
(deftest "deeply nested scope chain"
|
||||
(let ((a 1))
|
||||
(let ((b 2))
|
||||
(let ((c 3))
|
||||
(let ((d 4))
|
||||
(assert-equal 10 (+ a b c d)))))))
|
||||
|
||||
(deftest "lambda param shadows enclosing binding"
|
||||
(let ((x 99))
|
||||
(let ((f (fn (x) (* x 2))))
|
||||
(assert-equal 10 (f 5))
|
||||
;; outer x still visible after call
|
||||
(assert-equal 99 x))))
|
||||
|
||||
(deftest "sibling let bindings are independent"
|
||||
;; Bindings in the same let do not see each other.
|
||||
(let ((a 1) (b 2))
|
||||
(assert-equal 1 a)
|
||||
(assert-equal 2 b))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closure mutation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "closure-mutation"
|
||||
(deftest "set! inside closure affects closed-over variable"
|
||||
(let ((x 0))
|
||||
(let ((inc-x (fn () (set! x (+ x 1)))))
|
||||
(inc-x)
|
||||
(inc-x)
|
||||
(assert-equal 2 x))))
|
||||
|
||||
(deftest "multiple closures sharing same mutable variable"
|
||||
(let ((count 0))
|
||||
(let ((inc! (fn () (set! count (+ count 1))))
|
||||
(dec! (fn () (set! count (- count 1))))
|
||||
(get (fn () count)))
|
||||
(inc!)
|
||||
(inc!)
|
||||
(inc!)
|
||||
(dec!)
|
||||
(assert-equal 2 (get)))))
|
||||
|
||||
(deftest "set! in let binding visible to later expressions"
|
||||
(let ((x 1))
|
||||
(set! x 42)
|
||||
(assert-equal 42 x)))
|
||||
|
||||
(deftest "set! visible across multiple later expressions"
|
||||
(let ((result 0))
|
||||
(set! result 5)
|
||||
(set! result (* result 2))
|
||||
(assert-equal 10 result)))
|
||||
|
||||
(deftest "map creates closures each seeing its own iteration value"
|
||||
;; Each fn passed to map closes over x for that invocation.
|
||||
;; The resulting list of thunks should each return the value they
|
||||
;; were called with at map time.
|
||||
(let ((thunks (map (fn (x) (fn () x)) (list 1 2 3 4 5))))
|
||||
(assert-equal 1 ((nth thunks 0)))
|
||||
(assert-equal 2 ((nth thunks 1)))
|
||||
(assert-equal 3 ((nth thunks 2)))
|
||||
(assert-equal 4 ((nth thunks 3)))
|
||||
(assert-equal 5 ((nth thunks 4))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Higher-order closures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "higher-order-closures"
|
||||
(deftest "compose two functions"
|
||||
(define compose
|
||||
(fn (f g) (fn (x) (f (g x)))))
|
||||
(let ((double (fn (x) (* x 2)))
|
||||
(inc (fn (x) (+ x 1))))
|
||||
(let ((double-then-inc (compose inc double))
|
||||
(inc-then-double (compose double inc)))
|
||||
(assert-equal 7 (double-then-inc 3))
|
||||
(assert-equal 8 (inc-then-double 3)))))
|
||||
|
||||
(deftest "partial application via closure"
|
||||
(define partial
|
||||
(fn (f &rest bound)
|
||||
(fn (&rest rest)
|
||||
(apply f (append bound rest)))))
|
||||
(let ((add (fn (a b) (+ a b)))
|
||||
(mul (fn (a b) (* a b))))
|
||||
(let ((add10 (partial add 10))
|
||||
(triple (partial mul 3)))
|
||||
(assert-equal 15 (add10 5))
|
||||
(assert-equal 21 (triple 7)))))
|
||||
|
||||
(deftest "map with closure that captures outer variable"
|
||||
(let ((offset 100))
|
||||
(let ((result (map (fn (x) (+ x offset)) (list 1 2 3))))
|
||||
(assert-equal (list 101 102 103) result))))
|
||||
|
||||
(deftest "reduce with closure"
|
||||
(let ((multiplier 3))
|
||||
(let ((result (reduce (fn (acc x) (+ acc (* x multiplier))) 0 (list 1 2 3 4))))
|
||||
;; (1*3 + 2*3 + 3*3 + 4*3) = 30
|
||||
(assert-equal 30 result))))
|
||||
|
||||
(deftest "filter with closure over threshold"
|
||||
(let ((threshold 5))
|
||||
(let ((big (filter (fn (x) (> x threshold)) (list 3 5 7 9 1 6))))
|
||||
(assert-equal (list 7 9 6) big))))
|
||||
|
||||
(deftest "closure returned from higher-order function composes correctly"
|
||||
(define make-multiplier
|
||||
(fn (factor) (fn (x) (* x factor))))
|
||||
(define pipeline
|
||||
(fn (fns x)
|
||||
(reduce (fn (acc f) (f acc)) x fns)))
|
||||
(let ((double (make-multiplier 2))
|
||||
(triple (make-multiplier 3)))
|
||||
;; 5 -> *2 -> 10 -> *3 -> 30
|
||||
(assert-equal 30 (pipeline (list double triple) 5)))))
|
||||
197
spec/tests/test-defcomp.sx
Normal file
197
spec/tests/test-defcomp.sx
Normal file
@@ -0,0 +1,197 @@
|
||||
;; ==========================================================================
|
||||
;; test-defcomp.sx — Tests for component (defcomp) calling conventions
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: eval.sx (defcomp, component call), render.sx
|
||||
;;
|
||||
;; Component calling convention:
|
||||
;; (defcomp ~name (&key k1 k2 &rest children) body...)
|
||||
;; Keyword args: (~name :k1 v1 :k2 v2)
|
||||
;; Children: (~name :k1 v1 child1 child2) — positional after keywords
|
||||
;; Defaults: (or k1 "fallback")
|
||||
;;
|
||||
;; render-html takes an SX source string, evaluates + renders to HTML string.
|
||||
;; For multi-form programs use (do ...) or define forms before the call.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Basic defcomp behaviour
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defcomp-basics"
|
||||
(deftest "defcomp binds the component name"
|
||||
(defcomp ~no-params ()
|
||||
(span "hello"))
|
||||
(assert-true (not (nil? ~no-params))))
|
||||
|
||||
(deftest "defcomp with positional params"
|
||||
;; Components can accept plain positional params (not &key).
|
||||
(defcomp ~greet (name)
|
||||
(span name))
|
||||
(assert-true (not (nil? ~greet))))
|
||||
|
||||
(deftest "defcomp body can reference defined names"
|
||||
;; Body is evaluated in the defining env — outer defines are visible.
|
||||
(define greeting "hi")
|
||||
(defcomp ~uses-outer ()
|
||||
(span greeting))
|
||||
(assert-true (not (nil? ~uses-outer))))
|
||||
|
||||
(deftest "defcomp is a component type"
|
||||
(defcomp ~typed-comp (&key x)
|
||||
(div x))
|
||||
;; component-affinity is available on all component values
|
||||
(assert-equal "auto" (component-affinity ~typed-comp))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Keyword argument (&key) convention
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defcomp-keyword-args"
|
||||
(deftest "single &key param receives keyword argument"
|
||||
;; Evaluation: component body is called with title bound to "World".
|
||||
(defcomp ~k-single (&key title)
|
||||
title)
|
||||
;; We call it and check the returned value (not HTML).
|
||||
(assert-equal "World" (~k-single :title "World")))
|
||||
|
||||
(deftest "multiple &key params"
|
||||
(defcomp ~k-multi (&key first last)
|
||||
(str first " " last))
|
||||
(assert-equal "Ada Lovelace" (~k-multi :first "Ada" :last "Lovelace")))
|
||||
|
||||
(deftest "missing &key param is nil"
|
||||
(defcomp ~k-missing (&key title subtitle)
|
||||
subtitle)
|
||||
(assert-nil (~k-missing :title "Only title")))
|
||||
|
||||
(deftest "&key param default via or"
|
||||
(defcomp ~k-default (&key label)
|
||||
(or label "default-label"))
|
||||
(assert-equal "custom" (~k-default :label "custom"))
|
||||
(assert-equal "default-label" (~k-default)))
|
||||
|
||||
(deftest "&key params can be numbers"
|
||||
(defcomp ~k-num (&key value)
|
||||
(* value 2))
|
||||
(assert-equal 84 (~k-num :value 42)))
|
||||
|
||||
(deftest "&key params can be lists"
|
||||
(defcomp ~k-list (&key items)
|
||||
(len items))
|
||||
(assert-equal 3 (~k-list :items (list "a" "b" "c")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Rest / children convention
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defcomp-rest-children"
|
||||
(deftest "&rest captures all positional args"
|
||||
(defcomp ~r-basic (&rest children)
|
||||
(len children))
|
||||
(assert-equal 3 (~r-basic "a" "b" "c")))
|
||||
|
||||
(deftest "&rest with &key separates keywords from positional"
|
||||
(defcomp ~r-mixed (&key title &rest children)
|
||||
(list title (len children)))
|
||||
(let ((result (~r-mixed :title "T" "c1" "c2")))
|
||||
(assert-equal "T" (first result))
|
||||
(assert-equal 2 (nth result 1))))
|
||||
|
||||
(deftest "empty children when no positional args provided"
|
||||
(defcomp ~r-empty (&rest children)
|
||||
children)
|
||||
(assert-true (empty? (~r-empty))))
|
||||
|
||||
(deftest "multiple children are captured in order"
|
||||
(defcomp ~r-order (&rest children)
|
||||
children)
|
||||
(let ((kids (~r-order "x" "y" "z")))
|
||||
(assert-equal "x" (nth kids 0))
|
||||
(assert-equal "y" (nth kids 1))
|
||||
(assert-equal "z" (nth kids 2)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component rendering to HTML
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defcomp-rendering"
|
||||
(deftest "simplest component renders to HTML"
|
||||
(assert-equal "<p>hello</p>"
|
||||
(render-html "(do (defcomp ~r-simple () (p \"hello\")) (~r-simple))")))
|
||||
|
||||
(deftest "component with &key renders keyword arg value"
|
||||
(assert-equal "<h1>Greetings</h1>"
|
||||
(render-html "(do (defcomp ~r-title (&key text) (h1 text))
|
||||
(~r-title :text \"Greetings\"))")))
|
||||
|
||||
(deftest "component with multiple &key args"
|
||||
(let ((html (render-html
|
||||
"(do (defcomp ~r-card (&key title subtitle)
|
||||
(div :class \"card\" (h2 title) (p subtitle)))
|
||||
(~r-card :title \"Hi\" :subtitle \"Sub\"))")))
|
||||
(assert-true (string-contains? html "class=\"card\""))
|
||||
(assert-true (string-contains? html "<h2>Hi</h2>"))
|
||||
(assert-true (string-contains? html "<p>Sub</p>"))))
|
||||
|
||||
(deftest "nested component calls"
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~r-inner (&key label) (span label))
|
||||
(defcomp ~r-outer (&key text) (div (~r-inner :label text)))
|
||||
(~r-outer :text \"nested\"))")))
|
||||
(assert-true (string-contains? html "<div>"))
|
||||
(assert-true (string-contains? html "<span>nested</span>"))))
|
||||
|
||||
(deftest "component with children rendered inside wrapper"
|
||||
(let ((html (render-html
|
||||
"(do (defcomp ~r-box (&key &rest children)
|
||||
(div :class \"box\" children))
|
||||
(~r-box (p \"inside\")))")))
|
||||
(assert-true (string-contains? html "class=\"box\""))
|
||||
(assert-true (string-contains? html "<p>inside</p>"))))
|
||||
|
||||
(deftest "component with conditional rendering via when"
|
||||
(let ((html-with (render-html
|
||||
"(do (defcomp ~r-cond (&key show)
|
||||
(div (when show (span \"visible\"))))
|
||||
(~r-cond :show true))"))
|
||||
(html-without (render-html
|
||||
"(do (defcomp ~r-cond (&key show)
|
||||
(div (when show (span \"visible\"))))
|
||||
(~r-cond :show false))")))
|
||||
(assert-true (string-contains? html-with "<span>visible</span>"))
|
||||
(assert-false (string-contains? html-without "<span>"))))
|
||||
|
||||
(deftest "component with conditional rendering via if"
|
||||
(assert-equal "<p>yes</p>"
|
||||
(render-html "(do (defcomp ~r-if (&key flag)
|
||||
(if flag (p \"yes\") (p \"no\")))
|
||||
(~r-if :flag true))"))
|
||||
(assert-equal "<p>no</p>"
|
||||
(render-html "(do (defcomp ~r-if (&key flag)
|
||||
(if flag (p \"yes\") (p \"no\")))
|
||||
(~r-if :flag false))")))
|
||||
|
||||
(deftest "component default via or renders correctly"
|
||||
(assert-equal "<span>fallback</span>"
|
||||
(render-html "(do (defcomp ~r-default (&key label)
|
||||
(span (or label \"fallback\")))
|
||||
(~r-default))"))
|
||||
(assert-equal "<span>given</span>"
|
||||
(render-html "(do (defcomp ~r-default (&key label)
|
||||
(span (or label \"fallback\")))
|
||||
(~r-default :label \"given\"))")))
|
||||
|
||||
(deftest "component with multiple children rendered in order"
|
||||
(let ((html (render-html
|
||||
"(do (defcomp ~r-multi (&rest children)
|
||||
(ul children))
|
||||
(~r-multi (li \"a\") (li \"b\") (li \"c\")))")))
|
||||
(assert-true (string-contains? html "<li>a</li>"))
|
||||
(assert-true (string-contains? html "<li>b</li>"))
|
||||
(assert-true (string-contains? html "<li>c</li>")))))
|
||||
268
spec/tests/test-macros.sx
Normal file
268
spec/tests/test-macros.sx
Normal file
@@ -0,0 +1,268 @@
|
||||
;; ==========================================================================
|
||||
;; test-macros.sx — Tests for macros and quasiquote
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: eval.sx (defmacro, quasiquote, unquote, splice-unquote)
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; sx-parse-one (source) -> first AST expression from source string
|
||||
;; equal? (a b) -> deep equality comparison
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quasiquote basics
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "quasiquote-basics"
|
||||
(deftest "quasiquote with no unquotes is like quote"
|
||||
;; `(a b c) returns a list of three symbols — same as '(a b c)
|
||||
(assert-true (equal? '(a b c) `(a b c)))
|
||||
(assert-length 3 `(a b c)))
|
||||
|
||||
(deftest "quasiquote preserves numbers and strings as-is"
|
||||
(assert-equal (list 1 "hello" true) `(1 "hello" true)))
|
||||
|
||||
(deftest "quasiquote returns literal list"
|
||||
;; Without unquotes, the result is a plain list — not evaluated
|
||||
(let ((result `(+ 1 2)))
|
||||
(assert-type "list" result)
|
||||
(assert-length 3 result)))
|
||||
|
||||
(deftest "unquote substitutes value"
|
||||
;; `(a ,x b) with x=42 should yield the list (a 42 b)
|
||||
;; Compare against the parsed AST of "(a 42 b)"
|
||||
(let ((x 42))
|
||||
(assert-true (equal? (sx-parse-one "(a 42 b)") `(a ,x b)))))
|
||||
|
||||
(deftest "unquote evaluates its expression"
|
||||
;; ,expr evaluates expr — not just symbol substitution
|
||||
(let ((x 3))
|
||||
(assert-equal (list 1 2 6 4) `(1 2 ,(* x 2) 4))))
|
||||
|
||||
(deftest "unquote-splicing flattens list into quasiquote"
|
||||
;; ,@xs splices the elements of xs in-place
|
||||
(let ((xs (list 1 2 3)))
|
||||
(assert-equal (list 0 1 2 3 4) `(0 ,@xs 4))))
|
||||
|
||||
(deftest "unquote-splicing with multiple elements"
|
||||
;; Verify splice replaces the ,@xs slot with each element individually
|
||||
(let ((xs (list 2 3 4)))
|
||||
(assert-true (equal? (sx-parse-one "(a 2 3 4 b)") `(a ,@xs b)))))
|
||||
|
||||
(deftest "unquote-splicing empty list leaves no elements"
|
||||
(let ((empty (list)))
|
||||
(assert-equal (list 1 2) `(1 ,@empty 2))))
|
||||
|
||||
(deftest "multiple unquotes in one template"
|
||||
(let ((a 10) (b 20))
|
||||
(assert-equal (list 10 20 30) `(,a ,b ,(+ a b)))))
|
||||
|
||||
(deftest "quasiquote with only unquote-splicing"
|
||||
(let ((items (list 7 8 9)))
|
||||
(assert-equal (list 7 8 9) `(,@items)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defmacro basics
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "defmacro-basics"
|
||||
(deftest "simple macro transforms code"
|
||||
;; A macro that wraps its argument in (do ...)
|
||||
(defmacro wrap-do (expr)
|
||||
`(do ,expr))
|
||||
(assert-equal 42 (wrap-do 42))
|
||||
(assert-equal "hello" (wrap-do "hello")))
|
||||
|
||||
(deftest "macro with multiple args"
|
||||
;; my-if is structurally the same as if
|
||||
(defmacro my-if (condition then else)
|
||||
`(if ,condition ,then ,else))
|
||||
(assert-equal "yes" (my-if true "yes" "no"))
|
||||
(assert-equal "no" (my-if false "yes" "no"))
|
||||
(assert-equal "yes" (my-if (> 5 3) "yes" "no")))
|
||||
|
||||
(deftest "macro using quasiquote and unquote"
|
||||
;; inc1 expands to (+ x 1)
|
||||
(defmacro inc1 (x)
|
||||
`(+ ,x 1))
|
||||
(assert-equal 6 (inc1 5))
|
||||
(assert-equal 1 (inc1 0))
|
||||
(let ((n 10))
|
||||
(assert-equal 11 (inc1 n))))
|
||||
|
||||
(deftest "macro using unquote-splicing for rest body"
|
||||
;; progn evaluates a sequence, returning the last value
|
||||
(defmacro progn (&rest body)
|
||||
`(do ,@body))
|
||||
(assert-equal 3 (progn 1 2 3))
|
||||
(assert-equal "last" (progn "first" "middle" "last")))
|
||||
|
||||
(deftest "macro with rest body side effects"
|
||||
;; All body forms execute, not just the first
|
||||
(define counter 0)
|
||||
(defmacro progn2 (&rest body)
|
||||
`(do ,@body))
|
||||
(progn2
|
||||
(set! counter (+ counter 1))
|
||||
(set! counter (+ counter 1))
|
||||
(set! counter (+ counter 1)))
|
||||
(assert-equal 3 counter))
|
||||
|
||||
(deftest "macro expansion happens before evaluation"
|
||||
;; The macro sees raw AST — its body arg is the symbol x, not a value
|
||||
;; This verifies that macro args are not evaluated before expansion
|
||||
(defmacro quote-arg (x)
|
||||
`(quote ,x))
|
||||
;; (quote-arg foo) should expand to (quote foo), returning the symbol foo
|
||||
(let ((result (quote-arg foo)))
|
||||
(assert-true (equal? (sx-parse-one "foo") result))))
|
||||
|
||||
(deftest "macro can build new list structure"
|
||||
;; Macro that builds a let binding from two args
|
||||
(defmacro bind-to (name val body)
|
||||
`(let ((,name ,val)) ,body))
|
||||
(assert-equal 10 (bind-to x 10 x))
|
||||
(assert-equal 20 (bind-to y 10 (* y 2)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Common macro patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "macro-patterns"
|
||||
(deftest "unless macro — opposite of when"
|
||||
(defmacro unless (condition &rest body)
|
||||
`(when (not ,condition) ,@body))
|
||||
;; Runs body when condition is false
|
||||
(assert-equal "ran" (unless false "ran"))
|
||||
(assert-nil (unless true "should-not-run"))
|
||||
;; Works with compound conditions
|
||||
(assert-equal "done" (unless (> 1 2) "done"))
|
||||
(assert-nil (unless (= 1 1) "nope")))
|
||||
|
||||
(deftest "swap-vals! macro — exchange two bindings"
|
||||
;; Swaps values of two variables using a temp binding
|
||||
(defmacro swap-vals! (a b)
|
||||
`(let ((tmp ,a))
|
||||
(set! ,a ,b)
|
||||
(set! ,b tmp)))
|
||||
(define p 1)
|
||||
(define q 2)
|
||||
(swap-vals! p q)
|
||||
(assert-equal 2 p)
|
||||
(assert-equal 1 q))
|
||||
|
||||
(deftest "with-default macro — provide fallback for nil"
|
||||
;; (with-default expr default) returns expr unless it is nil
|
||||
(defmacro with-default (expr fallback)
|
||||
`(or ,expr ,fallback))
|
||||
(assert-equal "hello" (with-default "hello" "fallback"))
|
||||
(assert-equal "fallback" (with-default nil "fallback"))
|
||||
(assert-equal "fallback" (with-default false "fallback")))
|
||||
|
||||
(deftest "when2 macro — two-arg version with implicit body"
|
||||
;; Like when, but condition and body are explicit
|
||||
(defmacro when2 (cond-expr body-expr)
|
||||
`(if ,cond-expr ,body-expr nil))
|
||||
(assert-equal 42 (when2 true 42))
|
||||
(assert-nil (when2 false 42)))
|
||||
|
||||
(deftest "dotimes macro — simple counted loop"
|
||||
;; Executes body n times, binding loop var to 0..n-1
|
||||
(defmacro dotimes (binding &rest body)
|
||||
(let ((var (first binding))
|
||||
(n (first (rest binding))))
|
||||
`(let loop ((,var 0))
|
||||
(when (< ,var ,n)
|
||||
,@body
|
||||
(loop (+ ,var 1))))))
|
||||
(define total 0)
|
||||
(dotimes (i 5)
|
||||
(set! total (+ total i)))
|
||||
;; 0+1+2+3+4 = 10
|
||||
(assert-equal 10 total))
|
||||
|
||||
(deftest "and2 macro — two-arg short-circuit and"
|
||||
(defmacro and2 (a b)
|
||||
`(if ,a ,b false))
|
||||
(assert-equal "b" (and2 "a" "b"))
|
||||
(assert-false (and2 false "b"))
|
||||
(assert-false (and2 "a" false)))
|
||||
|
||||
(deftest "macro calling another macro"
|
||||
;; nand is defined in terms of and2 (which is itself a macro)
|
||||
(defmacro and2b (a b)
|
||||
`(if ,a ,b false))
|
||||
(defmacro nand (a b)
|
||||
`(not (and2b ,a ,b)))
|
||||
(assert-true (nand false false))
|
||||
(assert-true (nand false true))
|
||||
(assert-true (nand true false))
|
||||
(assert-false (nand true true))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Macro hygiene
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "macro-hygiene"
|
||||
(deftest "macro-introduced bindings do not leak to caller scope"
|
||||
;; The macro uses a local let binding named `tmp`.
|
||||
;; That binding must not appear in the caller's environment after expansion.
|
||||
(defmacro double-add (x)
|
||||
`(let ((tmp (* ,x 2)))
|
||||
(+ tmp 1)))
|
||||
(assert-equal 11 (double-add 5))
|
||||
(assert-equal 21 (double-add 10))
|
||||
;; Verify the let scope is isolated: evaluate two calls and confirm
|
||||
;; results are independent (no shared `tmp` leaking between calls)
|
||||
(assert-equal (list 11 21) (list (double-add 5) (double-add 10))))
|
||||
|
||||
(deftest "caller bindings are visible inside macro expansion"
|
||||
;; The macro emits code that references `scale` — a name that must be
|
||||
;; looked up in the caller's environment at expansion evaluation time.
|
||||
(defmacro scale-add (x)
|
||||
`(+ ,x scale))
|
||||
(let ((scale 100))
|
||||
(assert-equal 105 (scale-add 5))))
|
||||
|
||||
(deftest "nested macro expansion"
|
||||
;; Outer macro expands to a call of an inner macro.
|
||||
;; The inner macro's expansion must also be fully evaluated.
|
||||
(defmacro inner-mac (x)
|
||||
`(* ,x 2))
|
||||
(defmacro outer-mac (x)
|
||||
`(inner-mac (+ ,x 1)))
|
||||
;; outer-mac 4 → (inner-mac (+ 4 1)) → (inner-mac 5) → (* 5 2) → 10
|
||||
(assert-equal 10 (outer-mac 4)))
|
||||
|
||||
(deftest "macro does not evaluate args — sees raw AST"
|
||||
;; Passing an expression that would error if evaluated; macro must not
|
||||
;; force evaluation of args it doesn't use.
|
||||
(defmacro first-arg (a b)
|
||||
`(quote ,a))
|
||||
;; b = (/ 1 0) would be a runtime error if evaluated, but macro ignores b
|
||||
(assert-true (equal? (sx-parse-one "hello") (first-arg hello (/ 1 0)))))
|
||||
|
||||
(deftest "macro expansion in let body"
|
||||
;; Macros must expand correctly when used inside a let body,
|
||||
;; not just at top level.
|
||||
(defmacro triple (x)
|
||||
`(* ,x 3))
|
||||
(let ((n 4))
|
||||
(assert-equal 12 (triple n))))
|
||||
|
||||
(deftest "macro in higher-order position — map over macro results"
|
||||
;; Macros can't be passed as first-class values, but their expansions
|
||||
;; can produce lambdas that are passed. Verify that using a macro to
|
||||
;; build a lambda works correctly.
|
||||
(defmacro make-adder (n)
|
||||
`(fn (x) (+ x ,n)))
|
||||
(let ((add5 (make-adder 5))
|
||||
(add10 (make-adder 10)))
|
||||
(assert-equal 8 (add5 3))
|
||||
(assert-equal 13 (add10 3))
|
||||
(assert-equal (list 6 7 8)
|
||||
(map (make-adder 5) (list 1 2 3))))))
|
||||
@@ -256,4 +256,273 @@
|
||||
(deftest "quote shorthand list"
|
||||
(let ((result (first (sx-parse "#'(1 2 3)"))))
|
||||
(assert-equal "quote" (symbol-name (first result)))
|
||||
(assert-equal (list 1 2 3) (nth result 1)))))
|
||||
(assert-equal (list 1 2 3) (nth result 1))))
|
||||
|
||||
(deftest "apostrophe quote expands to (quote ...)"
|
||||
(let ((result (sx-parse "'x")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "quote" (symbol-name (first expr)))
|
||||
(assert-equal "x" (symbol-name (nth expr 1))))))
|
||||
|
||||
(deftest "apostrophe quote on list"
|
||||
(let ((result (sx-parse "'(1 2 3)")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "quote" (symbol-name (first expr)))
|
||||
(assert-equal (list 1 2 3) (nth expr 1)))))
|
||||
|
||||
(deftest "quasiquote with unquote inside"
|
||||
(let ((result (sx-parse "`(a ,b)")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "quasiquote" (symbol-name (first expr)))
|
||||
(let ((inner (nth expr 1)))
|
||||
(assert-type "list" inner)
|
||||
(assert-equal "a" (symbol-name (first inner)))
|
||||
(let ((unquoted (nth inner 1)))
|
||||
(assert-type "list" unquoted)
|
||||
(assert-equal "unquote" (symbol-name (first unquoted)))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Number formats
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-numbers"
|
||||
(deftest "integer zero"
|
||||
(assert-equal (list 0) (sx-parse "0")))
|
||||
|
||||
(deftest "large integer"
|
||||
(assert-equal (list 1000000) (sx-parse "1000000")))
|
||||
|
||||
(deftest "negative float"
|
||||
(assert-equal (list -2.718) (sx-parse "-2.718")))
|
||||
|
||||
(deftest "exponent notation"
|
||||
(let ((result (sx-parse "1e10")))
|
||||
(assert-length 1 result)
|
||||
(assert-type "number" (first result))
|
||||
(assert-equal 10000000000 (first result))))
|
||||
|
||||
(deftest "negative exponent"
|
||||
(let ((result (sx-parse "2.5e-1")))
|
||||
(assert-length 1 result)
|
||||
(assert-type "number" (first result))
|
||||
(assert-equal 0.25 (first result))))
|
||||
|
||||
(deftest "uppercase exponent E"
|
||||
(let ((result (sx-parse "1E3")))
|
||||
(assert-length 1 result)
|
||||
(assert-type "number" (first result))
|
||||
(assert-equal 1000 (first result)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Symbol naming conventions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-symbols"
|
||||
(deftest "symbol with hyphens"
|
||||
(let ((result (sx-parse "my-var")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "my-var" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with question mark"
|
||||
(let ((result (sx-parse "nil?")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "nil?" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with exclamation"
|
||||
(let ((result (sx-parse "set!")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "set!" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with tilde (component)"
|
||||
(let ((result (sx-parse "~my-comp")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "~my-comp" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with arrow"
|
||||
(let ((result (sx-parse "->")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "->" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with &"
|
||||
(let ((result (sx-parse "&key")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "&key" (symbol-name (first result)))))
|
||||
|
||||
(deftest "symbol with every? style"
|
||||
(let ((result (sx-parse "every?")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "every?" (symbol-name (first result)))))
|
||||
|
||||
(deftest "ellipsis is a symbol"
|
||||
(let ((result (sx-parse "...")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "..." (symbol-name (first result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Serializer — extended
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "serializer-extended"
|
||||
(deftest "serialize negative number"
|
||||
(assert-equal "-5" (sx-serialize -5)))
|
||||
|
||||
(deftest "serialize float"
|
||||
(assert-equal "3.14" (sx-serialize 3.14)))
|
||||
|
||||
(deftest "serialize string with escaped quote"
|
||||
(let ((s (sx-serialize "say \"hi\"")))
|
||||
(assert-true (string-contains? s "\\\""))))
|
||||
|
||||
(deftest "serialize dict round-trips"
|
||||
;; Parse a dict literal, serialize it, parse again — values survive.
|
||||
(let ((d (first (sx-parse "{:x 1 :y 2}"))))
|
||||
(let ((s (sx-serialize d)))
|
||||
(assert-true (string-contains? s ":x"))
|
||||
(assert-true (string-contains? s ":y"))
|
||||
(let ((d2 (first (sx-parse s))))
|
||||
(assert-equal 1 (get d2 "x"))
|
||||
(assert-equal 2 (get d2 "y"))))))
|
||||
|
||||
(deftest "serialize symbol with hyphens"
|
||||
(assert-equal "my-fn" (sx-serialize (make-symbol "my-fn"))))
|
||||
|
||||
(deftest "serialize keyword with hyphens"
|
||||
(assert-equal ":my-key" (sx-serialize (make-keyword "my-key"))))
|
||||
|
||||
(deftest "serialize deeply nested list"
|
||||
(assert-equal "(1 (2 (3)))"
|
||||
(sx-serialize (list 1 (list 2 (list 3)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Round-trip — extended
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-roundtrip-extended"
|
||||
(deftest "roundtrip keyword"
|
||||
(let ((parsed (first (sx-parse ":hello"))))
|
||||
(assert-equal ":hello" (sx-serialize parsed))))
|
||||
|
||||
(deftest "roundtrip negative number"
|
||||
(assert-equal "-7" (sx-serialize (first (sx-parse "-7")))))
|
||||
|
||||
(deftest "roundtrip float"
|
||||
(assert-equal "3.14" (sx-serialize (first (sx-parse "3.14")))))
|
||||
|
||||
(deftest "roundtrip string with newline escape"
|
||||
(let ((parsed (first (sx-parse "\"a\\nb\""))))
|
||||
;; Parsed value contains a real newline character.
|
||||
(assert-equal "a\nb" parsed)
|
||||
;; Serialized form must escape it back.
|
||||
(let ((serialized (sx-serialize parsed)))
|
||||
(assert-true (string-contains? serialized "\\n")))))
|
||||
|
||||
(deftest "roundtrip symbol with question mark"
|
||||
(let ((parsed (first (sx-parse "empty?"))))
|
||||
(assert-equal "empty?" (sx-serialize parsed))))
|
||||
|
||||
(deftest "roundtrip component symbol"
|
||||
(let ((parsed (first (sx-parse "~card"))))
|
||||
(assert-equal "~card" (sx-serialize parsed))))
|
||||
|
||||
(deftest "roundtrip keyword arguments in list"
|
||||
(let ((src "(~comp :title \"Hi\" :count 3)"))
|
||||
(assert-equal src
|
||||
(sx-serialize (first (sx-parse src))))))
|
||||
|
||||
(deftest "roundtrip empty list"
|
||||
(assert-equal "()" (sx-serialize (first (sx-parse "()")))))
|
||||
|
||||
(deftest "roundtrip mixed-type list"
|
||||
(let ((src "(1 \"hello\" true nil)"))
|
||||
(assert-equal src
|
||||
(sx-serialize (first (sx-parse src)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-edge-cases"
|
||||
(deftest "empty string parses to empty list"
|
||||
(assert-equal (list) (sx-parse "")))
|
||||
|
||||
(deftest "whitespace-only parses to empty list"
|
||||
(assert-equal (list) (sx-parse " \n\t ")))
|
||||
|
||||
(deftest "multiple top-level expressions"
|
||||
(let ((result (sx-parse "1 2 3")))
|
||||
(assert-length 3 result)
|
||||
(assert-equal 1 (nth result 0))
|
||||
(assert-equal 2 (nth result 1))
|
||||
(assert-equal 3 (nth result 2))))
|
||||
|
||||
(deftest "multiple top-level mixed types"
|
||||
(let ((result (sx-parse "42 \"hello\" true nil")))
|
||||
(assert-length 4 result)
|
||||
(assert-equal 42 (nth result 0))
|
||||
(assert-equal "hello" (nth result 1))
|
||||
(assert-equal true (nth result 2))
|
||||
(assert-nil (nth result 3))))
|
||||
|
||||
(deftest "deeply nested list"
|
||||
(let ((result (sx-parse "(((((1)))))")))
|
||||
(assert-length 1 result)
|
||||
(let ((l1 (first result)))
|
||||
(let ((l2 (first l1)))
|
||||
(let ((l3 (first l2)))
|
||||
(let ((l4 (first l3)))
|
||||
(assert-equal (list 1) l4)))))))
|
||||
|
||||
(deftest "long string value"
|
||||
(let ((long-str (join "" (map (fn (x) "abcdefghij") (range 0 10)))))
|
||||
(let ((src (str "\"" long-str "\"")))
|
||||
(assert-equal (list long-str) (sx-parse src)))))
|
||||
|
||||
(deftest "inline comment inside list"
|
||||
(let ((result (sx-parse "(+ 1 ;; comment\n 2)")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list (make-symbol "+") 1 2) (first result))))
|
||||
|
||||
(deftest "comment at end of file with no trailing newline"
|
||||
(assert-equal (list 1) (sx-parse "1 ;; trailing comment")))
|
||||
|
||||
(deftest "keyword with numeric suffix"
|
||||
(let ((result (sx-parse ":item-1")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "item-1" (keyword-name (first result)))))
|
||||
|
||||
(deftest "consecutive keywords parsed as separate atoms"
|
||||
(let ((result (sx-parse ":a :b :c")))
|
||||
(assert-length 3 result)
|
||||
(assert-equal "a" (keyword-name (nth result 0)))
|
||||
(assert-equal "b" (keyword-name (nth result 1)))
|
||||
(assert-equal "c" (keyword-name (nth result 2)))))
|
||||
|
||||
(deftest "symbol immediately after opening paren"
|
||||
(let ((result (first (sx-parse "(foo)"))))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "foo" (symbol-name (first result)))))
|
||||
|
||||
(deftest "parse boolean true is not a symbol"
|
||||
(let ((result (first (sx-parse "true"))))
|
||||
(assert-type "boolean" result)
|
||||
(assert-equal true result)))
|
||||
|
||||
(deftest "parse boolean false is not a symbol"
|
||||
(let ((result (first (sx-parse "false"))))
|
||||
(assert-type "boolean" result)
|
||||
(assert-equal false result)))
|
||||
|
||||
(deftest "parse nil is not a symbol"
|
||||
(let ((result (first (sx-parse "nil"))))
|
||||
(assert-nil result))))
|
||||
|
||||
190
spec/tests/test-tco.sx
Normal file
190
spec/tests/test-tco.sx
Normal file
@@ -0,0 +1,190 @@
|
||||
;; ==========================================================================
|
||||
;; test-tco.sx — Tests for tail-call optimization and set! mutation
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: eval.sx (trampoline, thunk, set!)
|
||||
;;
|
||||
;; TCO note: tail-recursive calls in SX produce thunks that are resolved
|
||||
;; by the trampoline. Deep recursion that would overflow a native call
|
||||
;; stack must complete in O(1) stack space via this mechanism.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tail-call optimization — basic deep recursion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "tco-basic"
|
||||
(deftest "tail-recursive sum completes without stack overflow"
|
||||
;; sum-iter is tail-recursive: the recursive call is the final value.
|
||||
;; n=10000 would blow the call stack without TCO.
|
||||
(define sum-iter
|
||||
(fn (n acc)
|
||||
(if (<= n 0)
|
||||
acc
|
||||
(sum-iter (- n 1) (+ acc n)))))
|
||||
(assert-equal 50005000 (sum-iter 10000 0)))
|
||||
|
||||
(deftest "tail-recursive factorial"
|
||||
(define fact-iter
|
||||
(fn (n acc)
|
||||
(if (<= n 1)
|
||||
acc
|
||||
(fact-iter (- n 1) (* acc n)))))
|
||||
(assert-equal 120 (fact-iter 5 1))
|
||||
(assert-equal 3628800 (fact-iter 10 1)))
|
||||
|
||||
(deftest "mutual tail recursion via define"
|
||||
;; even? and odd? call each other in tail position.
|
||||
;; With TCO both directions must trampoline correctly.
|
||||
(define my-even?
|
||||
(fn (n)
|
||||
(if (= n 0)
|
||||
true
|
||||
(my-odd? (- n 1)))))
|
||||
(define my-odd?
|
||||
(fn (n)
|
||||
(if (= n 0)
|
||||
false
|
||||
(my-even? (- n 1)))))
|
||||
(assert-true (my-even? 100))
|
||||
(assert-false (my-odd? 100))
|
||||
(assert-false (my-even? 99))
|
||||
(assert-true (my-odd? 99)))
|
||||
|
||||
(deftest "non-tail recursion at moderate depth"
|
||||
;; Classic non-tail factorial: O(n) stack frames.
|
||||
;; n=100 is deep enough to exercise recursion without relying on TCO.
|
||||
(define factorial
|
||||
(fn (n)
|
||||
(if (<= n 1)
|
||||
1
|
||||
(* n (factorial (- n 1))))))
|
||||
(assert-equal 1 (factorial 1))
|
||||
(assert-equal 24 (factorial 4))
|
||||
;; Use a boolean check so we don't need big-integer support
|
||||
(assert-true (> (factorial 20) 1000000))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; set! mutation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "set-mutation"
|
||||
(deftest "set! changes binding value"
|
||||
(define x 1)
|
||||
(set! x 2)
|
||||
(assert-equal 2 x))
|
||||
|
||||
(deftest "set! in let body"
|
||||
(let ((y 10))
|
||||
(set! y 20)
|
||||
(assert-equal 20 y)))
|
||||
|
||||
(deftest "set! visible to subsequent expressions in do block"
|
||||
(let ((counter 0))
|
||||
(do
|
||||
(set! counter (+ counter 1))
|
||||
(set! counter (+ counter 1))
|
||||
(set! counter (+ counter 1)))
|
||||
(assert-equal 3 counter)))
|
||||
|
||||
(deftest "set! counter pattern"
|
||||
;; Simulate an imperative loop via set! + tail recursion.
|
||||
(let ((total 0))
|
||||
(define loop
|
||||
(fn (i)
|
||||
(when (< i 5)
|
||||
(set! total (+ total i))
|
||||
(loop (+ i 1)))))
|
||||
(loop 0)
|
||||
;; 0+1+2+3+4 = 10
|
||||
(assert-equal 10 total)))
|
||||
|
||||
(deftest "multiple set! to same variable"
|
||||
(define v 0)
|
||||
(set! v 1)
|
||||
(set! v 2)
|
||||
(set! v 3)
|
||||
(assert-equal 3 v)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; TCO in various tail positions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "tco-patterns"
|
||||
(deftest "accumulator pattern"
|
||||
;; Classic FP accumulator — build result in extra param so the
|
||||
;; recursive call stays in tail position.
|
||||
(define reverse-iter
|
||||
(fn (lst acc)
|
||||
(if (empty? lst)
|
||||
acc
|
||||
(reverse-iter (rest lst) (cons (first lst) acc)))))
|
||||
(assert-equal (list 3 2 1) (reverse-iter (list 1 2 3) (list)))
|
||||
(assert-equal (list) (reverse-iter (list) (list))))
|
||||
|
||||
(deftest "loop via tail recursion until condition"
|
||||
;; count-down reaches zero via tail calls only.
|
||||
(define count-down
|
||||
(fn (n)
|
||||
(if (= n 0)
|
||||
"done"
|
||||
(count-down (- n 1)))))
|
||||
(assert-equal "done" (count-down 5000)))
|
||||
|
||||
(deftest "tail position in if then-branch"
|
||||
(define f
|
||||
(fn (n)
|
||||
(if (> n 0)
|
||||
(f (- n 1)) ;; tail call in then-branch
|
||||
"zero")))
|
||||
(assert-equal "zero" (f 1000)))
|
||||
|
||||
(deftest "tail position in if else-branch"
|
||||
(define g
|
||||
(fn (n)
|
||||
(if (= n 0)
|
||||
"done"
|
||||
(g (- n 1))))) ;; tail call in else-branch
|
||||
(assert-equal "done" (g 1000)))
|
||||
|
||||
(deftest "tail position in cond"
|
||||
(define classify
|
||||
(fn (n)
|
||||
(cond (< n 0) "negative"
|
||||
(= n 0) "zero"
|
||||
:else "positive")))
|
||||
(assert-equal "negative" (classify -5))
|
||||
(assert-equal "zero" (classify 0))
|
||||
(assert-equal "positive" (classify 7)))
|
||||
|
||||
(deftest "tail position in cond recursive clause"
|
||||
(define count-up
|
||||
(fn (n limit)
|
||||
(cond (= n limit) n
|
||||
:else (count-up (+ n 1) limit))))
|
||||
(assert-equal 500 (count-up 0 500)))
|
||||
|
||||
(deftest "tail position in let body"
|
||||
;; The body expression of a let is in tail position.
|
||||
(define h
|
||||
(fn (n)
|
||||
(let ((m (- n 1)))
|
||||
(if (<= m 0)
|
||||
m
|
||||
(h m)))))
|
||||
(assert-equal 0 (h 1000)))
|
||||
|
||||
(deftest "tail position in when body"
|
||||
;; The last expression of a when body is in tail position.
|
||||
(define scan
|
||||
(fn (lst acc)
|
||||
(when (not (empty? lst))
|
||||
(scan (rest lst) (+ acc (first lst))))))
|
||||
;; scan returns nil on empty — seed with pre-evaluated sum
|
||||
(define sum-list
|
||||
(fn (lst)
|
||||
(reduce (fn (a x) (+ a x)) 0 lst)))
|
||||
(assert-equal 15 (sum-list (list 1 2 3 4 5)))))
|
||||
Reference in New Issue
Block a user