russell@unturf.com
4960381c67
Ticket 0002 — reads 8 bytes from /dev/urandom (little-endian u64) and seeds xoshiro256**. Opt-in kernel entropy for stochastic runs; the default stays deterministic (k=0 at startup), so ticket 0001's portal-reproducibility contract is unchanged. Real-world flow now one call away: Machine A: (random-seed-from-os!) + run simulation + portal-save Machine B: portal-resume — same stream, bit-for-bit All three impls fail loud on /dev/urandom trouble (LispErr in Python and C, stderr + exit(1) in asm) — no silent fallback to a weak seed. Tests: - tests/functional.lsp: 2 new shared asserts (entropic + replay) - asm/test.sh: 2 new asm-local checks (149 total, was 147) - make test-all green across Python (205), C (205), asm (149) Whitepaper §7.5 gains one sentence noting the OS-seed path. unmoad: zero new findings in added code.
680 lines
32 KiB
Text
680 lines
32 KiB
Text
;;; functional.lsp — Shared functional test suite
|
|
;;; Runs identically in both Python and C implementations.
|
|
;;;
|
|
;;; Python: python3 lumbda.py --fast tests/functional.lsp
|
|
;;; C: ./c/lumbda tests/functional.lsp
|
|
;;;
|
|
;;; Output: lines of "PASS: name" or "FAIL: name got=X expected=Y"
|
|
;;; Exit: displays summary at end
|
|
|
|
(define *pass* 0)
|
|
(define *fail* 0)
|
|
|
|
(define (assert-equal name got expected)
|
|
(if (equal? got expected)
|
|
(begin (set! *pass* (+ *pass* 1))
|
|
(display "PASS: ") (display name) (newline))
|
|
(begin (set! *fail* (+ *fail* 1))
|
|
(display "FAIL: ") (display name)
|
|
(display " got=") (write got)
|
|
(display " expected=") (write expected) (newline))))
|
|
|
|
(define (assert-true name val)
|
|
(assert-equal name val #t))
|
|
|
|
(define (assert-false name val)
|
|
(assert-equal name val #f))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Arithmetic
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "add" (+ 1 2) 3)
|
|
(assert-equal "sub" (- 10 3) 7)
|
|
(assert-equal "mul" (* 6 7) 42)
|
|
(assert-equal "div" (/ 10 2) 5)
|
|
(assert-equal "nested-arith" (+ (* 3 4) (- 10 5)) 17)
|
|
(assert-equal "negate" (- 5) -5)
|
|
(assert-equal "zero-add" (+) 0)
|
|
(assert-equal "one-mul" (*) 1)
|
|
(assert-equal "multi-add" (+ 1 2 3 4) 10)
|
|
(assert-equal "multi-mul" (* 1 2 3 4) 24)
|
|
(assert-true "zero?" (zero? 0))
|
|
(assert-false "zero?-1" (zero? 1))
|
|
(assert-true "positive?" (positive? 5))
|
|
(assert-true "negative?" (negative? -3))
|
|
(assert-true "odd?" (odd? 3))
|
|
(assert-true "even?" (even? 4))
|
|
(assert-equal "abs" (abs -7) 7)
|
|
(assert-equal "min" (min 3 1 4 1 5) 1)
|
|
(assert-equal "max" (max 3 1 4 1 5) 5)
|
|
(assert-equal "modulo" (modulo 10 3) 1)
|
|
(assert-equal "expt" (expt 2 10) 1024)
|
|
(assert-equal "isqrt-0" (isqrt 0) 0)
|
|
(assert-equal "isqrt-1" (isqrt 1) 1)
|
|
(assert-equal "isqrt-perfect" (isqrt 144) 12)
|
|
(assert-equal "isqrt-floor" (isqrt 10) 3)
|
|
(assert-equal "isqrt-just-below" (isqrt 99) 9)
|
|
(assert-equal "isqrt-just-above" (isqrt 101) 10)
|
|
(assert-equal "isqrt-large" (isqrt 1000000000000) 1000000)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Random (xoshiro256**) — deterministic stream, portal-serializable
|
|
;;; across Python + C + asm. See docs/tickets/0001-portal-rng.md.
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(random-seed! 42)
|
|
(assert-equal "random-int-1" (random-int 1000000) 558742)
|
|
(assert-equal "random-int-2" (random-int 1000000) 543102)
|
|
(assert-equal "random-int-3" (random-int 1000000) 559009)
|
|
|
|
;; Re-seeding to same seed reproduces the stream.
|
|
(random-seed! 42)
|
|
(assert-equal "random-int-reseed-1" (random-int 1000000) 558742)
|
|
(assert-equal "random-int-reseed-2" (random-int 1000000) 543102)
|
|
|
|
;; random-state / random-state! round-trips state exactly.
|
|
(random-seed! 42)
|
|
(define saved-state (random-state))
|
|
(assert-equal "random-state-len" (length saved-state) 8)
|
|
(random-int 1000000) ; advance
|
|
(random-int 1000000) ; advance
|
|
(random-state! saved-state)
|
|
(assert-equal "random-state-restore" (random-int 1000000) 558742)
|
|
|
|
;; random-seed-from-os! pulls kernel entropy; two calls differ w/ overwhelming
|
|
;; probability. Ticket: docs/tickets/0002-os-entropy-seed.md.
|
|
(random-seed-from-os!)
|
|
(define os-state-a (random-state))
|
|
(random-seed-from-os!)
|
|
(define os-state-b (random-state))
|
|
(assert-true "random-seed-from-os-entropic" (not (equal? os-state-a os-state-b)))
|
|
;; Capture via (random-state) still works after OS seed — ties 0002 to 0001.
|
|
(random-seed-from-os!)
|
|
(define os-snapshot (random-state))
|
|
(define os-next1 (random-int 1000000))
|
|
(random-state! os-snapshot)
|
|
(assert-equal "random-seed-from-os-replay" (random-int 1000000) os-next1)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Comparison
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-true "eq-nums" (= 5 5))
|
|
(assert-false "neq-nums" (= 5 6))
|
|
(assert-true "lt" (< 3 5))
|
|
(assert-true "gt" (> 5 3))
|
|
(assert-true "le" (<= 3 3))
|
|
(assert-true "ge" (>= 5 5))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Booleans
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-true "not-false" (not #f))
|
|
(assert-false "not-true" (not #t))
|
|
(assert-false "not-1" (not 1))
|
|
(assert-equal "and-true" (and 1 2 3) 3)
|
|
(assert-false "and-false" (and 1 #f 3))
|
|
(assert-equal "or-true" (or #f #f 3) 3)
|
|
(assert-equal "or-first" (or 1 2) 1)
|
|
(assert-false "or-false" (or #f #f))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Pairs & Lists
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "cons" (cons 1 2) '(1 . 2))
|
|
(assert-equal "car" (car '(1 2 3)) 1)
|
|
(assert-equal "cdr" (cdr '(1 2 3)) '(2 3))
|
|
(assert-equal "list" (list 1 2 3) '(1 2 3))
|
|
(assert-equal "length" (length '(a b c)) 3)
|
|
(assert-equal "append" (append '(1 2) '(3 4)) '(1 2 3 4))
|
|
(assert-equal "reverse" (reverse '(1 2 3)) '(3 2 1))
|
|
(assert-equal "list-ref" (list-ref '(a b c d) 2) 'c)
|
|
(assert-true "null?-nil" (null? '()))
|
|
(assert-false "null?-pair" (null? '(1)))
|
|
(assert-true "pair?" (pair? '(1 2)))
|
|
(assert-false "pair?-num" (pair? 42))
|
|
(assert-equal "map" (map (lambda (x) (* x x)) '(1 2 3 4)) '(1 4 9 16))
|
|
(assert-equal "filter" (filter odd? '(1 2 3 4 5)) '(1 3 5))
|
|
(assert-equal "fold-left" (fold-left + 0 '(1 2 3 4)) 10)
|
|
(assert-equal "for-each-effect"
|
|
(let ((acc '()))
|
|
(for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3))
|
|
(reverse acc))
|
|
'(1 2 3))
|
|
(assert-true "member" (pair? (member 3 '(1 2 3 4))))
|
|
(assert-false "member-miss" (member 5 '(1 2 3)))
|
|
(assert-equal "assoc" (cdr (assoc 'b '((a . 1) (b . 2) (c . 3)))) 2)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Strings
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "string-length" (string-length "hello") 5)
|
|
(assert-equal "string-append" (string-append "hello" " " "world") "hello world")
|
|
(assert-equal "substring" (substring "hello" 1 3) "el")
|
|
(assert-equal "string-ref" (string-ref "abc" 1) #\b)
|
|
(assert-equal "string-upcase" (string-upcase "hello") "HELLO")
|
|
(assert-equal "string-downcase" (string-downcase "HELLO") "hello")
|
|
(assert-equal "number->string" (number->string 42) "42")
|
|
(assert-equal "string->number" (string->number "42") 42)
|
|
(assert-true "string=?" (string=? "abc" "abc"))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Characters
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "char->integer" (char->integer #\A) 65)
|
|
(assert-equal "integer->char" (integer->char 65) #\A)
|
|
(assert-true "char-alphabetic?" (char-alphabetic? #\a))
|
|
(assert-false "char-alphabetic?-num" (char-alphabetic? #\1))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Vectors
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "make-vector" (vector-ref (make-vector 3 0) 1) 0)
|
|
(assert-equal "vector" (vector-ref (vector 10 20 30) 2) 30)
|
|
(assert-equal "vector-length" (vector-length (vector 1 2 3)) 3)
|
|
(assert-equal "vector-set!"
|
|
(let ((v (vector 1 2 3)))
|
|
(vector-set! v 1 99)
|
|
(vector-ref v 1))
|
|
99)
|
|
(assert-equal "vector->list" (vector->list (vector 1 2 3)) '(1 2 3))
|
|
(assert-equal "list->vector" (vector-ref (list->vector '(a b c)) 1) 'b)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Hash Tables
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define ht (make-hash-table))
|
|
(hash-table-set! ht 'x 10)
|
|
(hash-table-set! ht 'y 20)
|
|
(assert-equal "hash-ref" (hash-table-ref ht 'x) 10)
|
|
(assert-equal "hash-ref/default" (hash-table-ref/default ht 'z 99) 99)
|
|
(assert-true "hash-exists?" (hash-table-exists? ht 'x))
|
|
(assert-false "hash-not-exists?" (hash-table-exists? ht 'z))
|
|
(assert-equal "hash-size" (hash-table-size ht) 2)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Control Flow
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "if-true" (if #t 1 2) 1)
|
|
(assert-equal "if-false" (if #f 1 2) 2)
|
|
(assert-equal "cond" (cond ((= 1 2) 'a) ((= 1 1) 'b) (else 'c)) 'b)
|
|
(assert-equal "case" (case 3 ((1 2) 'a) ((3 4) 'b) (else 'c)) 'b)
|
|
(assert-equal "when" (when #t 42) 42)
|
|
(assert-equal "begin" (begin 1 2 3) 3)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Let / Lambda / Closures
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "let" (let ((x 1) (y 2)) (+ x y)) 3)
|
|
(assert-equal "let*" (let* ((x 1) (y (+ x 1))) y) 2)
|
|
(assert-equal "letrec"
|
|
(letrec ((even? (lambda (n) (if (= n 0) #t (odd? (- n 1)))))
|
|
(odd? (lambda (n) (if (= n 0) #f (even? (- n 1))))))
|
|
(even? 10))
|
|
#t)
|
|
(assert-equal "named-let"
|
|
(let loop ((i 0) (acc 0))
|
|
(if (= i 5) acc (loop (+ i 1) (+ acc i))))
|
|
10)
|
|
(assert-equal "closure"
|
|
(let ((make-adder (lambda (n) (lambda (x) (+ x n)))))
|
|
((make-adder 10) 5))
|
|
15)
|
|
(assert-equal "closure-mutation"
|
|
(let ((counter (let ((n 0)) (lambda () (set! n (+ n 1)) n))))
|
|
(counter) (counter) (counter))
|
|
3)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Do loops
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "do-loop"
|
|
(do ((i 0 (+ i 1)) (s 0 (+ s i)))
|
|
((= i 5) s))
|
|
10)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Define & recursion
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define (factorial n)
|
|
(if (<= n 1) 1 (* n (factorial (- n 1)))))
|
|
(assert-equal "factorial" (factorial 10) 3628800)
|
|
|
|
(define (fib n)
|
|
(let loop ((a 0) (b 1) (i 0))
|
|
(if (= i n) a (loop b (+ a b) (+ i 1)))))
|
|
(assert-equal "fib-iter" (fib 10) 55)
|
|
(assert-equal "fib-30" (fib 30) 832040)
|
|
|
|
(define (ack m n)
|
|
(cond ((= m 0) (+ n 1))
|
|
((= n 0) (ack (- m 1) 1))
|
|
(else (ack (- m 1) (ack m (- n 1))))))
|
|
(assert-equal "ackermann" (ack 3 4) 125)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Tail-call optimization
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define (count-down n)
|
|
(if (= n 0) 'done (count-down (- n 1))))
|
|
(assert-equal "tco-100k" (count-down 100000) 'done)
|
|
|
|
(define (sum-to n)
|
|
(let loop ((i n) (acc 0))
|
|
(if (= i 0) acc (loop (- i 1) (+ acc i)))))
|
|
(assert-equal "sum-to-50k" (sum-to 50000) 1250025000)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Quasiquote
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "quasiquote" `(1 ,(+ 1 1) 3) '(1 2 3))
|
|
(assert-equal "unquote-splicing" `(1 ,@(list 2 3) 4) '(1 2 3 4))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Macros
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define-macro (my-when test . body)
|
|
`(if ,test (begin ,@body) (void)))
|
|
(assert-equal "define-macro" (my-when #t 1 2 3) 3)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Type predicates
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-true "number?" (number? 42))
|
|
(assert-true "integer?" (integer? 42))
|
|
(assert-true "string?" (string? "hello"))
|
|
(assert-true "symbol?" (symbol? 'x))
|
|
(assert-true "boolean?" (boolean? #t))
|
|
(assert-true "procedure?" (procedure? car))
|
|
(assert-true "vector?" (vector? (vector 1)))
|
|
(assert-true "list?" (list? '(1 2)))
|
|
(assert-true "char?" (char? #\a))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Error handling
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "guard"
|
|
(guard (e (#t 'caught))
|
|
(error "test" "oops"))
|
|
'caught)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; call/cc (escape) — wrapped in guard for implementations
|
|
;;; that may not fully support call/cc
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "call/cc-escape"
|
|
(guard (e (#t 'skip))
|
|
(call/cc (lambda (k) (k 42) 99)))
|
|
42)
|
|
|
|
(assert-equal "call/cc-no-escape"
|
|
(guard (e (#t 'skip))
|
|
(call/cc (lambda (k) 99)))
|
|
99)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Higher-order programs
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define (mergesort lst)
|
|
(define (merge a b)
|
|
(cond ((null? a) b) ((null? b) a)
|
|
((< (car a) (car b)) (cons (car a) (merge (cdr a) b)))
|
|
(else (cons (car b) (merge a (cdr b))))))
|
|
(define (split l a b)
|
|
(if (null? l) (list a b) (split (cdr l) b (cons (car l) a))))
|
|
(if (or (null? lst) (null? (cdr lst))) lst
|
|
(let ((h (split lst '() '())))
|
|
(merge (mergesort (car h)) (mergesort (cadr h))))))
|
|
|
|
(assert-equal "mergesort" (mergesort '(5 3 1 4 2)) '(1 2 3 4 5))
|
|
|
|
(assert-equal "compose"
|
|
(let ((double (lambda (x) (* x 2)))
|
|
(inc (lambda (x) (+ x 1))))
|
|
(map (lambda (x) (double (inc x))) '(1 2 3)))
|
|
'(4 6 8))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; More list ops: any, every, find, count, sort, iota, fold-right
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
;; any returns the element in Python, #t in C — test truthiness only
|
|
(assert-true "any-found" (guard (e (#t 'skip)) (if (any odd? '(2 3 4)) #t #f)))
|
|
(assert-false "any-miss" (guard (e (#t 'skip)) (any odd? '(2 4 6))))
|
|
(assert-true "every-true" (guard (e (#t 'skip)) (every even? '(2 4 6))))
|
|
(assert-false "every-false" (guard (e (#t 'skip)) (every even? '(2 3 6))))
|
|
(assert-equal "find-found" (guard (e (#t 'skip)) (find even? '(1 2 3 4))) 2)
|
|
(assert-false "find-miss" (guard (e (#t 'skip)) (find even? '(1 3 5))))
|
|
(assert-equal "count-pred" (guard (e (#t 'skip)) (count odd? '(1 2 3 4 5))) 3)
|
|
(assert-equal "count-zero" (guard (e (#t 'skip)) (count odd? '(2 4 6))) 0)
|
|
(assert-equal "sort-list" (guard (e (#t 'skip)) (sort '(5 2 8 1 4))) '(1 2 4 5 8))
|
|
(assert-equal "sort-empty" (guard (e (#t 'skip)) (sort '())) '())
|
|
(assert-equal "iota-5" (guard (e (#t 'skip)) (iota 5)) '(0 1 2 3 4))
|
|
(assert-equal "iota-0" (guard (e (#t 'skip)) (iota 0)) '())
|
|
(assert-equal "fold-right-cons" (fold-right cons '() '(1 2 3)) '(1 2 3))
|
|
(assert-equal "fold-right-sub" (fold-right - 0 '(1 2 3)) 2)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Named let with multiple body expressions
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "named-let-multi-body"
|
|
(let loop ((i 0) (acc '()))
|
|
(display "") ; side effect — multiple body expr
|
|
(if (= i 3) (reverse acc) (loop (+ i 1) (cons i acc))))
|
|
'(0 1 2))
|
|
|
|
(assert-equal "named-let-body-effects"
|
|
(let ((result '()))
|
|
(let loop ((i 0))
|
|
(set! result (cons i result))
|
|
(if (< i 3) (loop (+ i 1)) (void)))
|
|
(reverse result))
|
|
'(0 1 2 3))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Internal defines in function bodies
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define (with-internal-defs x)
|
|
(define a (* x 2))
|
|
(define b (+ a 1))
|
|
(+ a b))
|
|
(assert-equal "internal-define" (with-internal-defs 5) 21)
|
|
|
|
(define (internal-def-recursive n)
|
|
(define (helper i acc)
|
|
(if (= i 0) acc (helper (- i 1) (+ acc i))))
|
|
(helper n 0))
|
|
(assert-equal "internal-define-recursive" (internal-def-recursive 10) 55)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Letrec mutual recursion (even?/odd?)
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "letrec-mutual-even"
|
|
(letrec ((my-even? (lambda (n) (if (= n 0) #t (my-odd? (- n 1)))))
|
|
(my-odd? (lambda (n) (if (= n 0) #f (my-even? (- n 1))))))
|
|
(my-even? 100))
|
|
#t)
|
|
(assert-equal "letrec-mutual-odd"
|
|
(letrec ((my-even? (lambda (n) (if (= n 0) #t (my-odd? (- n 1)))))
|
|
(my-odd? (lambda (n) (if (= n 0) #f (my-even? (- n 1))))))
|
|
(my-odd? 7))
|
|
#t)
|
|
(assert-false "letrec-mutual-not-odd"
|
|
(letrec ((my-even? (lambda (n) (if (= n 0) #t (my-odd? (- n 1)))))
|
|
(my-odd? (lambda (n) (if (= n 0) #f (my-even? (- n 1))))))
|
|
(my-odd? 8)))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Do loops with result expressions
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "do-result-expr"
|
|
(do ((i 0 (+ i 1)) (s 0 (+ s i)))
|
|
((= i 10) (* s 2)))
|
|
90)
|
|
|
|
(assert-equal "do-multi-result"
|
|
(do ((i 0 (+ i 1)))
|
|
((= i 5) (+ i 100)))
|
|
105)
|
|
|
|
(assert-equal "do-body-effect"
|
|
(let ((acc '()))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i 4) (reverse acc))
|
|
(set! acc (cons (* i i) acc))))
|
|
'(0 1 4 9))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Tail position correctness in cond, when, unless, and, or
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
;; cond in tail position — deep recursion tests TCO
|
|
(define (cond-tail n)
|
|
(cond ((= n 0) 'done)
|
|
((even? n) (cond-tail (- n 1)))
|
|
(else (cond-tail (- n 1)))))
|
|
(assert-equal "tco-cond" (cond-tail 100000) 'done)
|
|
|
|
;; when in tail position
|
|
(assert-equal "when-value" (when #t 1 2 3) 3)
|
|
(assert-equal "when-false" (when #f 42) (void))
|
|
|
|
;; unless in tail position
|
|
(assert-equal "unless-true" (unless #t 42) (void))
|
|
(assert-equal "unless-false" (unless #f 1 2 3) 3)
|
|
|
|
;; and/or return values
|
|
(assert-equal "and-empty" (and) #t)
|
|
(assert-equal "or-empty" (or) #f)
|
|
(assert-equal "and-short-circuit" (and 1 2 #f 4) #f)
|
|
(assert-equal "or-short-circuit" (or #f #f 42 99) 42)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Nested closures and closure mutation
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "nested-closure"
|
|
(let ((f (lambda (x)
|
|
(lambda (y)
|
|
(lambda (z)
|
|
(+ x y z))))))
|
|
(((f 1) 2) 3))
|
|
6)
|
|
|
|
(assert-equal "closure-shared-state"
|
|
(let ((make-counter
|
|
(lambda ()
|
|
(let ((n 0))
|
|
(list (lambda () (set! n (+ n 1)) n)
|
|
(lambda () n))))))
|
|
(let ((c (make-counter)))
|
|
((car c))
|
|
((car c))
|
|
((car c))
|
|
((cadr c))))
|
|
3)
|
|
|
|
(assert-equal "closure-captures-loop-var"
|
|
(let ((fs '()))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i 3) (void))
|
|
(set! fs (cons (let ((j i)) (lambda () j)) fs)))
|
|
(map (lambda (f) (f)) (reverse fs)))
|
|
'(0 1 2))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Multiple return from begin
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-equal "begin-single" (begin 42) 42)
|
|
(assert-equal "begin-effects"
|
|
(let ((x 0))
|
|
(begin (set! x 1) (set! x (+ x 1)) x))
|
|
2)
|
|
(assert-equal "begin-nested" (begin (begin (begin 99))) 99)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Deep recursion — verify TCO at 100k+ depth
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define (mutual-a n)
|
|
(if (= n 0) 'done-a (mutual-b (- n 1))))
|
|
(define (mutual-b n)
|
|
(if (= n 0) 'done-b (mutual-a (- n 1))))
|
|
(assert-equal "tco-mutual-200k" (mutual-a 200000) 'done-a)
|
|
(assert-equal "tco-mutual-200k+1" (mutual-a 200001) 'done-b)
|
|
|
|
(assert-equal "tco-named-let-200k"
|
|
(let loop ((n 200000))
|
|
(if (= n 0) 'done (loop (- n 1))))
|
|
'done)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; More string ops
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(assert-true "string-contains-yes"
|
|
(guard (e (#t 'skip)) (string-contains "hello world" "world")))
|
|
(assert-false "string-contains-no"
|
|
(guard (e (#t 'skip)) (string-contains "hello world" "xyz")))
|
|
(assert-equal "string-split"
|
|
(guard (e (#t 'skip)) (string-split "a,b,c" ","))
|
|
'("a" "b" "c"))
|
|
(assert-equal "string-join"
|
|
(guard (e (#t 'skip)) (string-join '("a" "b" "c") "-"))
|
|
"a-b-c")
|
|
(assert-equal "string->list"
|
|
(guard (e (#t 'skip)) (string->list "abc"))
|
|
'(#\a #\b #\c))
|
|
(assert-equal "list->string"
|
|
(guard (e (#t 'skip)) (list->string '(#\x #\y #\z)))
|
|
"xyz")
|
|
(assert-equal "string-trim"
|
|
(guard (e (#t 'skip)) (string-trim " hello "))
|
|
"hello")
|
|
(assert-equal "string<?"
|
|
(guard (e (#t 'skip)) (string<? "abc" "abd"))
|
|
#t)
|
|
(assert-true "make-string"
|
|
(guard (e (#t 'skip)) (string=? (make-string 3 #\x) "xxx")))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Additional edge cases
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
;; let* shadowing
|
|
(assert-equal "let*-shadow"
|
|
(let* ((x 1) (x (+ x 10)) (x (* x 2)))
|
|
x)
|
|
22)
|
|
|
|
;; Varargs (dotted rest params)
|
|
(define (variadic a b . rest) (list a b rest))
|
|
(assert-equal "variadic-args" (variadic 1 2 3 4 5) '(1 2 (3 4 5)))
|
|
(assert-equal "variadic-no-rest" (variadic 1 2) '(1 2 ()))
|
|
|
|
;; apply
|
|
(assert-equal "apply-basic" (apply + '(1 2 3)) 6)
|
|
(assert-equal "apply-prefix" (apply + 1 2 '(3 4)) 10)
|
|
|
|
;; Deep nesting
|
|
(assert-equal "deep-let"
|
|
(let ((a 1))
|
|
(let ((b (+ a 1)))
|
|
(let ((c (+ b 1)))
|
|
(let ((d (+ c 1)))
|
|
(+ a b c d)))))
|
|
10)
|
|
|
|
;; cadr, caddr, etc.
|
|
(assert-equal "cadr" (cadr '(1 2 3)) 2)
|
|
(assert-equal "caddr" (caddr '(1 2 3)) 3)
|
|
|
|
;; map with multiple operations
|
|
(assert-equal "map-lambda"
|
|
(map (lambda (x) (if (even? x) (* x 10) x)) '(1 2 3 4 5))
|
|
'(1 20 3 40 5))
|
|
|
|
;; filter with closure
|
|
(assert-equal "filter-closure"
|
|
(let ((threshold 3))
|
|
(filter (lambda (x) (> x threshold)) '(1 2 3 4 5)))
|
|
'(4 5))
|
|
|
|
;; Nested quasiquote
|
|
(assert-equal "quasi-nested"
|
|
(let ((x 1) (y '(2 3)))
|
|
`(,x ,@y 4))
|
|
'(1 2 3 4))
|
|
|
|
;; set-car! / set-cdr!
|
|
(assert-equal "set-car!"
|
|
(let ((p (cons 1 2)))
|
|
(set-car! p 99)
|
|
(car p))
|
|
99)
|
|
(assert-equal "set-cdr!"
|
|
(let ((p (cons 1 2)))
|
|
(set-cdr! p 99)
|
|
(cdr p))
|
|
99)
|
|
|
|
;; list-tail
|
|
(assert-equal "list-tail" (list-tail '(a b c d e) 2) '(c d e))
|
|
|
|
;; make-list
|
|
(assert-equal "make-list" (guard (e (#t 'skip)) (make-list 4 'x)) '(x x x x))
|
|
|
|
;; hash-table-delete! and hash-table-keys
|
|
(assert-equal "hash-delete"
|
|
(let ((h (make-hash-table)))
|
|
(hash-table-set! h 'a 1)
|
|
(hash-table-set! h 'b 2)
|
|
(hash-table-delete! h 'a)
|
|
(hash-table-size h))
|
|
1)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; File I/O: write-file / file->string round-trip
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define *tmp-path* "/tmp/lumbda-functional-fio.txt")
|
|
|
|
(assert-true "write-file basic" (write-file *tmp-path* "hello\n"))
|
|
(assert-equal "file->string round-trip" (file->string *tmp-path*) "hello\n")
|
|
(assert-false "file->string missing" (file->string "/tmp/__nope_lumbda_fio__"))
|
|
(assert-true "write-file overwrite"
|
|
(begin (write-file *tmp-path* "second") (string=? (file->string *tmp-path*) "second")))
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; S-expression portal via write-file + load
|
|
;;; Cross-impl state exchange using only string primitives
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(define *portal-path* "/tmp/lumbda-functional-portal.sexp")
|
|
|
|
(write-file *portal-path*
|
|
"(define portal-x 111)\n(define portal-y 222)\n(define portal-z 333)\n")
|
|
(define portal-x 0)
|
|
(define portal-y 0)
|
|
(define portal-z 0)
|
|
(load *portal-path*)
|
|
(assert-equal "portal write+load x" portal-x 111)
|
|
(assert-equal "portal write+load y" portal-y 222)
|
|
(assert-equal "portal write+load z" portal-z 333)
|
|
(assert-equal "portal sum" (+ portal-x portal-y portal-z) 666)
|
|
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
;;; Summary
|
|
;;; ═══════════════════════════════════════════════════════════════
|
|
|
|
(newline)
|
|
(display "════════════════════════════════════════") (newline)
|
|
(display "Results: ") (display *pass*) (display " passed, ")
|
|
(display *fail*) (display " failed") (newline)
|
|
(if (= *fail* 0)
|
|
(display "ALL TESTS PASSED")
|
|
(display "SOME TESTS FAILED"))
|
|
(newline)
|