giles
8f146cc810
Strict mode (spec/eval.sx):
- *strict* flag, set-strict!, set-prim-param-types!
- value-matches-type? checks values against declared types
- strict-check-args validates primitive call args at runtime
- Injected into eval-call before apply — zero cost when off
- Supports positional params, rest-type, nullable ("string?")
New test files:
- test-strict.sx (25): value-matches-type?, toggle, 12 type error cases
- test-errors.sx (74): undefined symbols, arity, permissive coercion,
strict type mismatches, nil/empty edge cases, number edge cases,
string edge cases, recursion patterns
- test-advanced.sx (39): nested special forms, higher-order patterns,
define patterns, quasiquote advanced, thread-first, letrec, case/cond
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
372 lines
12 KiB
Plaintext
372 lines
12 KiB
Plaintext
;; ==========================================================================
|
|
;; test-advanced.sx — Tests for advanced evaluation patterns
|
|
;;
|
|
;; Requires: test-framework.sx loaded first.
|
|
;; Modules tested: eval.sx (nested forms, higher-order patterns, define,
|
|
;; quasiquote, thread-first, letrec, case/cond)
|
|
;; ==========================================================================
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Nested special forms
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "nested-special-forms"
|
|
(deftest "let inside let"
|
|
(let ((x 1))
|
|
(let ((y (let ((z 10)) (+ x z))))
|
|
(assert-equal 11 y))))
|
|
|
|
(deftest "if inside let"
|
|
(let ((flag true)
|
|
(result (if true "yes" "no")))
|
|
(assert-equal "yes" result))
|
|
(let ((result (if false "yes" "no")))
|
|
(assert-equal "no" result)))
|
|
|
|
(deftest "let inside if"
|
|
(assert-equal 15
|
|
(if true
|
|
(let ((a 5) (b 10)) (+ a b))
|
|
0))
|
|
(assert-equal 0
|
|
(if false
|
|
99
|
|
(let ((x 0)) x))))
|
|
|
|
(deftest "cond inside let"
|
|
(let ((n 2)
|
|
(label (cond (= 2 1) "one"
|
|
(= 2 2) "two"
|
|
:else "other")))
|
|
(assert-equal "two" label)))
|
|
|
|
(deftest "when inside when (nested conditional)"
|
|
;; Inner when only runs when outer when runs
|
|
(let ((result "none"))
|
|
(when true
|
|
(when true
|
|
(set! result "both")))
|
|
(assert-equal "both" result))
|
|
(let ((result "none"))
|
|
(when true
|
|
(when false
|
|
(set! result "inner")))
|
|
(assert-equal "none" result))
|
|
(let ((result "none"))
|
|
(when false
|
|
(when true
|
|
(set! result "inner")))
|
|
(assert-equal "none" result)))
|
|
|
|
(deftest "do inside let body"
|
|
(let ((x 0))
|
|
(do
|
|
(set! x (+ x 1))
|
|
(set! x (+ x 1))
|
|
(set! x (+ x 1)))
|
|
(assert-equal 3 x)))
|
|
|
|
(deftest "let inside map callback"
|
|
;; Each map iteration creates its own let scope
|
|
(let ((result (map (fn (x)
|
|
(let ((doubled (* x 2))
|
|
(label (str "item-" x)))
|
|
(str label "=" doubled)))
|
|
(list 1 2 3))))
|
|
(assert-equal "item-1=2" (nth result 0))
|
|
(assert-equal "item-2=4" (nth result 1))
|
|
(assert-equal "item-3=6" (nth result 2)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Higher-order patterns
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "higher-order-patterns"
|
|
(deftest "map then filter (pipeline)"
|
|
;; Double each number, then keep only those > 4
|
|
(let ((result (filter (fn (x) (> x 4))
|
|
(map (fn (x) (* x 2)) (list 1 2 3 4 5)))))
|
|
(assert-equal (list 6 8 10) result)))
|
|
|
|
(deftest "filter then map"
|
|
;; Keep odd numbers, then square them
|
|
(let ((result (map (fn (x) (* x x))
|
|
(filter (fn (x) (= (mod x 2) 1)) (list 1 2 3 4 5)))))
|
|
(assert-equal (list 1 9 25) result)))
|
|
|
|
(deftest "reduce to build a dict"
|
|
;; Build a word-length dict from a list of strings
|
|
(let ((result (reduce
|
|
(fn (acc s) (assoc acc s (string-length s)))
|
|
{}
|
|
(list "a" "bb" "ccc"))))
|
|
(assert-equal 1 (get result "a"))
|
|
(assert-equal 2 (get result "bb"))
|
|
(assert-equal 3 (get result "ccc"))))
|
|
|
|
(deftest "map returning lambdas, then calling them"
|
|
;; Produce a list of adder functions; call each with 10
|
|
(let ((adders (map (fn (n) (fn (x) (+ n x))) (list 1 2 3)))
|
|
(results (list)))
|
|
(for-each
|
|
(fn (f) (append! results (f 10)))
|
|
adders)
|
|
(assert-equal (list 11 12 13) results)))
|
|
|
|
(deftest "nested map (map of map)"
|
|
(let ((matrix (list (list 1 2) (list 3 4) (list 5 6)))
|
|
(result (map (fn (row) (map (fn (x) (* x 10)) row)) matrix)))
|
|
(assert-equal (list 10 20) (nth result 0))
|
|
(assert-equal (list 30 40) (nth result 1))
|
|
(assert-equal (list 50 60) (nth result 2))))
|
|
|
|
(deftest "for-each with side effect (set! counter)"
|
|
(define fe-counter 0)
|
|
(for-each
|
|
(fn (x) (set! fe-counter (+ fe-counter x)))
|
|
(list 1 2 3 4 5))
|
|
;; 1+2+3+4+5 = 15
|
|
(assert-equal 15 fe-counter)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Define patterns
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "define-patterns"
|
|
(deftest "define inside let body"
|
|
;; define inside a let body is visible in subsequent let body expressions
|
|
(let ((x 5))
|
|
(define y (* x 2))
|
|
(assert-equal 10 y)))
|
|
|
|
(deftest "define inside do block"
|
|
(do
|
|
(define do-val 42)
|
|
(assert-equal 42 do-val)))
|
|
|
|
(deftest "define function then call it"
|
|
(define square (fn (n) (* n n)))
|
|
(assert-equal 9 (square 3))
|
|
(assert-equal 25 (square 5))
|
|
(assert-equal 0 (square 0)))
|
|
|
|
(deftest "redefine a name (second define overwrites first)"
|
|
(define redef-x 1)
|
|
(assert-equal 1 redef-x)
|
|
(define redef-x 99)
|
|
(assert-equal 99 redef-x))
|
|
|
|
(deftest "define with computed value"
|
|
(define base 7)
|
|
(define derived (* base 6))
|
|
(assert-equal 42 derived)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Quasiquote advanced
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "quasiquote-advanced"
|
|
(deftest "quasiquote with multiple unquotes"
|
|
(let ((a 1) (b 2) (c 3))
|
|
(assert-equal (list 1 2 3) `(,a ,b ,c))
|
|
(assert-equal (list 10 2 30) `(,(* a 10) ,b ,(* c 10)))))
|
|
|
|
(deftest "unquote-splicing at start of list"
|
|
(let ((prefix (list 1 2 3)))
|
|
(assert-equal (list 1 2 3 4 5) `(,@prefix 4 5))))
|
|
|
|
(deftest "unquote-splicing at end of list"
|
|
(let ((suffix (list 3 4 5)))
|
|
(assert-equal (list 1 2 3 4 5) `(1 2 ,@suffix))))
|
|
|
|
(deftest "unquote inside nested list"
|
|
(let ((x 42))
|
|
;; The inner list contains an unquote — it should still be spliced
|
|
(let ((result `(a (b ,x) c)))
|
|
(assert-length 3 result)
|
|
(assert-equal 42 (nth (nth result 1) 1)))))
|
|
|
|
(deftest "quasiquote preserving structure"
|
|
;; A quasiquoted form with no unquotes is identical to the quoted form
|
|
(let ((q `(fn (a b) (+ a b))))
|
|
(assert-type "list" q)
|
|
(assert-length 3 q)
|
|
;; First element is the symbol fn
|
|
(assert-true (equal? (sx-parse-one "fn") (first q)))
|
|
;; Body is (+ a b) — a 3-element list
|
|
(assert-length 3 (nth q 2)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Thread-first
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "thread-first"
|
|
(deftest "simple thread through arithmetic"
|
|
;; (-> 5 (+ 1) (* 2)) = (5+1)*2 = 12
|
|
(assert-equal 12 (-> 5 (+ 1) (* 2))))
|
|
|
|
(deftest "thread with string ops"
|
|
(assert-equal "HELLO" (-> "hello" upcase))
|
|
(assert-equal "hello" (-> "HELLO" downcase)))
|
|
|
|
(deftest "thread with multiple steps"
|
|
;; (-> 1 (+ 1) (+ 1) (+ 1) (+ 1)) = 5
|
|
(assert-equal 5 (-> 1 (+ 1) (+ 1) (+ 1) (+ 1)))
|
|
;; (-> 100 (- 10) (/ 2) (+ 5)) = (100-10)/2+5 = 50
|
|
(assert-equal 50 (-> 100 (- 10) (/ 2) (+ 5))))
|
|
|
|
(deftest "thread through list ops"
|
|
;; Build list, reverse, take first
|
|
(assert-equal 3 (-> (list 1 2 3) reverse first))
|
|
;; Append then get length
|
|
(assert-equal 5 (-> (list 1 2 3) (append (list 4 5)) len))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; letrec
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "letrec"
|
|
(deftest "simple letrec with self-reference"
|
|
;; A single binding that calls itself recursively
|
|
(letrec ((count-down (fn (n)
|
|
(if (<= n 0)
|
|
"done"
|
|
(count-down (- n 1))))))
|
|
(assert-equal "done" (count-down 5))))
|
|
|
|
(deftest "mutual recursion in letrec"
|
|
(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))))))
|
|
(assert-true (my-even? 4))
|
|
(assert-false (my-even? 3))
|
|
(assert-true (my-odd? 3))
|
|
(assert-false (my-odd? 4))))
|
|
|
|
(deftest "letrec fibonacci"
|
|
(letrec ((fib (fn (n)
|
|
(if (< n 2)
|
|
n
|
|
(+ (fib (- n 1)) (fib (- n 2)))))))
|
|
(assert-equal 0 (fib 0))
|
|
(assert-equal 1 (fib 1))
|
|
(assert-equal 1 (fib 2))
|
|
(assert-equal 8 (fib 6))
|
|
(assert-equal 55 (fib 10))))
|
|
|
|
(deftest "letrec with non-recursive values too"
|
|
;; letrec can hold plain values alongside recursive fns
|
|
(letrec ((base 10)
|
|
(triple (fn (n) (* n 3)))
|
|
(result (fn () (triple base))))
|
|
(assert-equal 10 base)
|
|
(assert-equal 6 (triple 2))
|
|
(assert-equal 30 (result)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; case and cond
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(defsuite "case-cond"
|
|
(deftest "case with string matching"
|
|
(define color-label
|
|
(fn (c)
|
|
(case c
|
|
"red" "warm"
|
|
"blue" "cool"
|
|
"green" "natural"
|
|
:else "unknown")))
|
|
(assert-equal "warm" (color-label "red"))
|
|
(assert-equal "cool" (color-label "blue"))
|
|
(assert-equal "natural" (color-label "green"))
|
|
(assert-equal "unknown" (color-label "purple")))
|
|
|
|
(deftest "case with number matching"
|
|
(define grade
|
|
(fn (n)
|
|
(case n
|
|
1 "one"
|
|
2 "two"
|
|
3 "three"
|
|
:else "many")))
|
|
(assert-equal "one" (grade 1))
|
|
(assert-equal "two" (grade 2))
|
|
(assert-equal "three" (grade 3))
|
|
(assert-equal "many" (grade 99)))
|
|
|
|
(deftest "case :else fallthrough"
|
|
(assert-equal "fallback"
|
|
(case "unrecognised"
|
|
"a" "alpha"
|
|
"b" "beta"
|
|
:else "fallback")))
|
|
|
|
(deftest "case no match returns nil"
|
|
(assert-nil
|
|
(case "x"
|
|
"a" "alpha"
|
|
"b" "beta")))
|
|
|
|
(deftest "cond with multiple predicates"
|
|
(define classify
|
|
(fn (n)
|
|
(cond (< n 0) "negative"
|
|
(= n 0) "zero"
|
|
(< n 10) "small"
|
|
:else "large")))
|
|
(assert-equal "negative" (classify -5))
|
|
(assert-equal "zero" (classify 0))
|
|
(assert-equal "small" (classify 7))
|
|
(assert-equal "large" (classify 100)))
|
|
|
|
(deftest "cond with (= x val) predicate style"
|
|
(let ((x "b"))
|
|
(assert-equal "beta"
|
|
(cond (= x "a") "alpha"
|
|
(= x "b") "beta"
|
|
(= x "c") "gamma"
|
|
:else "other"))))
|
|
|
|
(deftest "cond :else"
|
|
(assert-equal "default"
|
|
(cond false "nope"
|
|
false "also-nope"
|
|
:else "default")))
|
|
|
|
(deftest "cond all false returns nil"
|
|
(assert-nil
|
|
(cond false "a"
|
|
false "b"
|
|
false "c")))
|
|
|
|
(deftest "nested cond/case"
|
|
;; cond selects a branch, that branch uses case
|
|
(define describe
|
|
(fn (kind val)
|
|
(cond (= kind "color")
|
|
(case val
|
|
"r" "red"
|
|
"g" "green"
|
|
"b" "blue"
|
|
:else "unknown-color")
|
|
(= kind "size")
|
|
(case val
|
|
"s" "small"
|
|
"l" "large"
|
|
:else "unknown-size")
|
|
:else "unknown-kind")))
|
|
(assert-equal "red" (describe "color" "r"))
|
|
(assert-equal "green" (describe "color" "g"))
|
|
(assert-equal "unknown-color" (describe "color" "x"))
|
|
(assert-equal "small" (describe "size" "s"))
|
|
(assert-equal "large" (describe "size" "l"))
|
|
(assert-equal "unknown-kind" (describe "other" "?"))))
|