ref: 1b00536fd5957d70dfde3a67fece862dbb879492
dir: /test/unittest.lsp/
; -*- scheme -*-
(define-macro (assert-fail expr . what)
`(assert (trycatch (begin ,expr #f)
(λ (e) ,(if (null? what) #t
`(eq? (car e) ',(car what)))))))
(define (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
(int64 n) (uint64 n) (bignum n)))
(define (every-sint n)
(list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n) (bignum n)))
(define (each f l)
(if (atom? l) ()
(begin (f (car l))
(each f (cdr l)))))
(define (each^2 f l m)
(each (λ (o) (each (λ (p) (f o p)) m)) l))
(define (test-lt a b)
(each^2 (λ (neg pos)
(begin
(eval `(assert (= -1 (compare ,neg ,pos))))
(eval `(assert (= 1 (compare ,pos ,neg))))))
a
b))
(define (test-eq a b)
(each^2 (λ (a b)
(begin
(eval `(assert (= 0 (compare ,a ,b))))))
a
b))
(test-lt (every-sint -1) (every-int 1))
(test-lt (every-int 0) (every-int 1))
(test-eq (every-int 88) (every-int 88))
(test-eq (every-sint -88) (every-sint -88))
(define (test-square a)
(each (λ (i) (eval `(assert (>= (* ,i ,i) 0))))
a))
(test-square (every-sint -67))
(test-square (every-int 3))
(test-square (every-int 0x80000000))
(test-square (every-sint 0x80000000))
(test-square (every-sint -0x80000000))
(assert (= (* 128 0x02000001) 0x100000080))
(assert (= (/ 1) 1))
(assert (= (/ -1) -1))
(assert (= (/ 2.0) 0.5))
(assert (= (- 4999950000 4999941999) 8001))
(assert (not (eqv? 10 #\newline)))
(assert (not (eqv? #\newline 10)))
; tricky cases involving INT32_MIN
(assert (< (- #uint32(0x80000000)) 0))
(assert (> (- #int32(0x80000000)) 0))
(assert (< (- #uint64(0x8000000000000000)) 0))
(assert (> (- #int64(0x8000000000000000)) 0))
; fixnum versions
(assert (= (- -536870912) 536870912))
(assert (= (- -2305843009213693952) 2305843009213693952))
(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
#uint64(0x8000000000000000)))
(assert (equal? (* 2 #int64(0x4000000000000000))
#uint64(0x8000000000000000)))
(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
(assert (equal? (string 'sym #byte(65) #rune(945) "blah") "symA\u03B1blah"))
(assert (= (length (string #\x0)) 1))
(assert (> 9223372036854775808 9223372036854775807))
(assert (fixnum? (- (aref "0" 0) #\0)))
(assert (= (ash #bignum(1) -9999) 0))
; number boundaries
(load "number-boundaries.lsp")
; bignum
(assert (> 0x10000000000000000 0x8fffffffffffffff))
(assert (< 0x8fffffffffffffff 0x10000000000000000))
(assert (not (bignum? (ash 2 60))))
(assert (not (bignum? (- (ash 2 60) 1))))
(assert (bignum? 1606938044258990275541962092341162602522202993782792835301376))
(assert (bignum? 0xfffffffffffffffff))
(assert (not (bignum? 0xfffffffffffffff)))
(assert (= 4764984380238568507752444984131552966909
(* 66405897020462343733 71755440315342536873)))
(assert (= 71755440315342536873
(div 4764984380238568507752444984131552966909 66405897020462343733)))
(assert (= 3203431780337 (div 576460752303423487 179951)))
(assert (= 3487 (mod 576460752303423487 18000)))
(assert (= 7 (mod 576460752303423487 10)))
(assert (= 0xfffffffffffffffff (logior 0xaaaaaaaaaaaaaaaaa 0x55555555555555555)))
(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
(assert (= 0xaaaaaaaaa (logand 0xaaaaaaaaaaaaaaaaa 0x55555555fffffffff)))
(assert (= 0 (logand 0 0x55555555555555555)))
(assert (= 602394779747 (ash 11112222333344445555666677778888 -64)))
(assert (= 204984321473364576635441321909950327706185271083008
(ash 11112222333344445555666677778888 64)))
; NaNs
(assert (equal? +nan.0 +nan.0))
(assert (equal? -nan.0 -nan.0))
(assert (not (= +nan.0 +nan.0)))
(assert (not (= +nan.0 -nan.0)))
(assert (not (= -nan.0 -nan.0)))
(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
(assert (not (>= +nan.0 +nan.0)))
(assert (not (<= -nan.0 -nan.0)))
; comparing strings
(assert (< "a" "b"))
(assert (> "b" "a"))
(assert (not (< "a" "a")))
(assert (<= "a" "a"))
(assert (>= "a" "a"))
(assert (>= "ab" "aa"))
; comparing numbers and runes
(assert (< 9 #\newline))
(assert (not (< 10 #\newline)))
(assert (= 10 #\newline))
(assert (> 11 #\newline))
; -0.0 etc.
(assert (not (equal? 0.0 0)))
(assert (equal? 0.0 0.0))
(assert (not (equal? -0.0 0.0)))
(assert (not (equal? -0.0 0)))
(assert (not (eqv? 0.0 0)))
(assert (not (eqv? -0.0 0)))
(assert (not (eqv? -0.0 0.0)))
(assert (= 0.0 -0.0))
; this crashed once
(for 1 10 (λ (i) 0))
; failing applications
(assert-fail ((λ (x) x) 1 2))
(assert-fail ((λ (x) x)))
(assert-fail ((λ (x y . z) z) 1))
(assert-fail (car 'x) type-error)
(assert-fail gjegherqpfdf___trejif unbound-error)
; long argument lists
(assert (= (apply + (iota 100000)) 4999950000))
(define ones (map (λ (x) 1) (iota 80000)))
(assert (= (eval `(if (< 2 1)
(+ ,@ones)
(+ ,@(cdr ones))))
79999))
(define MAX_ARGS 255)
(define as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 1))))
(define f (compile `(λ ,as ,(lastcdr as))))
(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
(define as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 100))))
(define ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
,(car (last-pair as)))))
(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
(define ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
(λ () ,(car (last-pair as))))))
(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
(define as (map-int (λ (x) (gensym)) 1000))
(define f (compile `(λ ,as ,(car (last-pair as)))))
(assert (equal? (apply f (iota 1000)) 999))
(define as (apply list* (map-int (λ (x) (gensym)) 995)))
(define f (compile `(λ ,as ,(lastcdr as))))
(assert (equal? (apply f (iota 994)) '()))
(assert (equal? (apply f (iota 995)) '(994)))
(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
; optional arguments
(assert (equal? ((λ ((b 0)) b)) 0))
(assert (equal? ((λ (a (b 2)) (list a b)) 1) '(1 2)))
(assert (equal? ((λ (a (b 2)) (list a b)) 1 3) '(1 3)))
(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
(assert (equal? ((λ ((x 0) . r) (list x r))) '(0 ())))
(assert (equal? ((λ ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
; keyword arguments
(assert (keyword? kw:))
(assert (not (keyword? 'kw)))
(assert (not (keyword? ':)))
(assert (equal? ((λ (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
'(1 0 0 (8 4 5))))
(assert (equal? ((λ (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
'(0 2 3 (1))))
(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
(assert (equal? (keys4 a: 10) '(10 3 7 6)))
(assert (equal? (keys4 b: 10) '(8 10 7 6)))
(assert (equal? (keys4 c: 10) '(8 3 10 6)))
(assert (equal? (keys4 d: 10) '(8 3 7 10)))
(assert-fail (keys4 e: 10)) ; unsupported keyword
(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
; cvalues and arrays
(assert (equal? (typeof "") '(array byte)))
(assert-fail (aref #(1) 3) bounds-error)
(define iarr (array 'int64 32 16 8 7 1))
(assert (equal? (aref iarr 0) 32))
(assert (equal? (aref iarr #int8(3)) 7))
; gensyms
(assert (gensym? (gensym)))
(assert (not (gensym? 'a)))
(assert (not (eq? (gensym) (gensym))))
(assert (not (equal? (string (gensym)) (string (gensym)))))
(let ((gs (gensym))) (assert (eq? gs gs)))
; eof object
(assert (eof-object? (eof-object)))
(assert (not (eof-object? 1)))
(assert (not (eof-object? 'a)))
(assert (not (eof-object? '())))
(assert (not (eof-object? #f)))
(assert (not (null? (eof-object))))
(assert (not (builtin? (eof-object))))
(assert (not (function? (eof-object))))
; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))
(load "color.lsp")
(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
(3 . d) (2 . c) (0 . b) (1 . a))))
; hashing strange things
(assert (equal?
(hash '#0=(1 1 #0# . #0#))
(hash '#1=(1 1 #1# 1 1 #1# . #1#))))
(assert (not (equal?
(hash '#0=(1 1 #0# . #0#))
(hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
(assert (equal?
(hash '#0=((1 . #0#) . #0#))
(hash '#1=((1 . #1#) (1 . #1#) . #1#))))
(assert (not (equal?
(hash '#0=((1 . #0#) . #0#))
(hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
(assert (not (equal?
(hash '#0=((1 . #0#) . #0#))
(hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
(assert (equal?
(hash '(#0=(#0#) 0))
(hash '(#1=(((((#1#))))) 0))))
(assert (not (equal?
(hash '(#0=(#0#) 0))
(hash '(#1=(((((#1#))))) 1)))))
(assert (equal?
(hash #0=#(1 #(2 #(#0#)) 3))
(hash #1=#(1 #(2 #(#(1 #(2 #(#1#)) 3))) 3))))
(assert (not (equal?
(hash #0=#(1 #(2 #(#0#)) 3))
(hash #1=#(1 #(2 #(#(5 #(2 #(#1#)) 3))) 3)))))
(assert (equal?
(hash #0=#(1 #0# #(2 #(#0#)) 3))
(hash #1=#(1 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3))))
(assert (not (equal?
(hash #0=#(1 #0# #(2 #(#0#)) 3))
(hash #1=#(6 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3)))))
(assert (equal?
(hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))
(hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))))
(assert (not (equal?
(hash #(6 1 #(2 #(#(3 1 #(2 #(1)) 3))) 3))
(hash #(6 1 #(2 #(#(1 1 #(2 #(1)) 3))) 3)))))
(assert (equal? (hash '#0=(1 . #0#))
(hash '#1=(1 1 . #1#))))
(assert (not (equal? (hash '#0=(1 1 . #0#))
(hash '#1=(1 #0# . #1#)))))
(assert (not (equal? (hash (iota 10))
(hash (iota 20)))))
(assert (not (equal? (hash (iota 41))
(hash (iota 42)))))
(if (top-level-bound? 'string->time)
(assert (let ((ts (time->string (time-now))))
(eqv? ts (time->string (string->time ts))))))
(assert (equal? 0.0 (+ 0.0 0))) ; tests that + no longer does inexact->exact
(assert (equal? 1.0 (* 1.0 1))) ; tests that * no longer does inexact->exact
(define (with-output-to-string nada thunk)
(let ((b (buffer)))
(with-output-to b (thunk))
(iostream->string b)))
(let ((c #\a))
(assert (equal? (with-output-to-string #f (λ () (print (list c c))))
"(#\\a #\\a)")))
(assert-fail (eval '(set! (car (cons 1 2)) 3)))
(assert (equal? `(a `(b c)) '(a (quasiquote (b c)))))
(assert (equal? ````x '```x))
(assert-fail (eval '(append 1)))
(assert-fail (eval '(append '() 1)))
(assert (equal? (append) '()))
(assert (equal? (append '()) '()))
(assert (equal? (append '() '()) '()))
(assert (equal? (append '(1 2)) '(1 2)))
(assert (equal? (append '(1 2) '(3 4)) '(1 2 3 4)))
(define a '(1))
(set-cdr! a a)
(assert (equal? (length a) +inf.0))
;; make many initialized tables large enough not to be stored in-line
(for 1 100 (λ (i)
(table eq? 2 eqv? 2
equal? 2 atom? 1
not 1 null? 1
boolean? 1 symbol? 1
number? 1 bound? 1
pair? 1 builtin? 1
vector? 1 fixnum? 1
cons 2 car 1
cdr 1 set-car! 2
set-cdr! 2 = 2
< 2 compare 2
aref 2 aset! 3
div0 2)))
;; now allocate enough to trigger GC
(for 1 8000000 (λ (i) (cons 1 2)))
(princ "all tests pass\n")
#t