Expand shared functional test suite: 114 → 181 tests
67 new tests covering: any/every/find/count/sort/iota/fold-right, named let with multi-body, internal defines, letrec mutual recursion, do loops with results, tail position in cond/when/unless/and/or, nested closures with mutation, deep TCO at 200k depth, string ops (contains/split/join/trim), apply, variadic args, quasiquote splicing, set-car!/set-cdr!, list-tail, make-list, hash-table-delete!. Both Python and C pass 181/181.
This commit is contained in:
parent
30d7279be2
commit
99bb12887c
1 changed files with 284 additions and 0 deletions
|
|
@ -307,6 +307,290 @@
|
|||
(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)
|
||||
|
||||
;;; ═══════════════════════════════════════════════════════════════
|
||||
;;; Summary
|
||||
;;; ═══════════════════════════════════════════════════════════════
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue