Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 06:39:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

switching tests suites to use (chibi test)

Browse source
This commit is contained in:
Alex Shinn 2010-07-31 23:30:30 +09:00
parent 9684192ffe
commit 1923f54df0
9 changed files with 187 additions and 362 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -182,6 +182,9 @@ test-loop: chibi-scheme$(EXE)
test-sort: chibi-scheme$(EXE) test-sort: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm
test-libs: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm
test: chibi-scheme$(EXE) test: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm

21
tests/flonum-tests.scm Normal file
View file

@ -0,0 +1,21 @@
;;;; these will fail when compiled either without flonums or trig funcs
(import (chibi test))
(test-begin "floating point")
(test-assert (= -5 (floor -4.3)))
(test-assert (= -4 (ceiling -4.3)))
(test-assert (= -4 (truncate -4.3)))
(test-assert (= -4 (round -4.3)))
(test-assert (= 3 (floor 3.5)))
(test-assert (= 4 (ceiling 3.5)))
(test-assert (= 3 (truncate 3.5)))
(test-assert (= 4 (round 3.5)))
(test 1124378190243790143.0 (exact->inexact 1124378190243790143))
;; (test "1124378190243790143.0"
;; (number->string (exact->inexact 1124378190243790143)))
(test-end)

43
tests/hash-tests.scm
View file

@ -1,44 +1,7 @@
(import (srfi 69)) (import (srfi 69) (chibi test))
(define *tests-run* 0) (test-begin "hash")
(define *tests-passed* 0)
(define-syntax test
(syntax-rules ()
((test expect expr)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string
(lambda (out)
(write *tests-run* out)
(display ". " out)
(display 'expr out))))
(res expr))
(display str)
(write-char #\space)
(display (make-string (max 0 (- 72 (string-length str))) #\.))
(flush-output)
(cond
((equal? res expect)
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run tests
(test (test
'white 'white
@ -70,5 +33,5 @@
(hash-table-set! ht i (* i i))) (hash-table-set! ht i (* i i)))
(hash-table-ref/default ht 25 #f))) (hash-table-ref/default ht 25 #f)))
(test-report) (test-end)

13
tests/lib-tests.scm Normal file
View file

@ -0,0 +1,13 @@
(import (chibi test))
(test-begin "libraries")
(load "tests/flonum-tests.scm")
(load "tests/numeric-tests.scm")
(load "tests/hash-tests.scm")
(load "tests/sort-tests.scm")
(load "tests/loop-tests.scm")
(load "tests/match-tests.scm")
(test-end)

40
tests/loop-tests.scm
View file

@ -1,40 +1,7 @@
(import (chibi loop)) (import (chibi loop) (chibi test))
(define *tests-run* 0) (test-begin "loops")
(define *tests-passed* 0)
(define-syntax test
(syntax-rules ()
((test name expr expect)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string (lambda (out) (display name out))))
(res expr))
(display str)
(write-char #\space)
(display (make-string (max 0 (- 72 (string-length str))) #\.))
(flush-output)
(cond
((equal? res expect)
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run tests
(test (test
"stepping" "stepping"
@ -198,5 +165,4 @@
(for res (listing i))) (for res (listing i)))
=> res)) => res))
(test-report) (test-end)

267
tests/match-tests.scm
View file

@ -1,196 +1,135 @@
(import (chibi match)) (import (chibi match) (chibi test))
(define *tests-run* 0) (test-begin "match")
(define *tests-passed* 0)
(define-syntax test (test "any" 'ok (match 'any (_ 'ok)))
(syntax-rules () (test "symbol" 'ok (match 'ok (x x)))
((test name expr expect) (test "number" 'ok (match 28 (28 'ok)))
(begin (test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
(set! *tests-run* (+ *tests-run* 1)) (test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
(let ((str (call-with-output-string (lambda (out) (display name out)))) (test "null" 'ok (match '() (() 'ok)))
(res expr)) (test "pair" 'ok (match '(ok) ((x) x)))
(display str) (test "vector" 'ok (match '#(ok) (#(x) x)))
(write-char #\space) (test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
(display (make-string (max 0 (- 72 (string-length str))) #\.)) (test "and empty" 'ok (match '(o k) ((and) 'ok)))
(flush-output) (test "and single" 'ok (match 'ok ((and x) x)))
(cond (test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
((equal? res expect) (test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
(set! *tests-passed* (+ *tests-passed* 1)) (test "or single" 'ok (match 'ok ((or x) 'ok)))
(display " [PASS]\n")) (test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
(else (test "not" 'ok (match 28 ((not (a . b)) 'ok)))
(display " [FAIL]\n") (test "pred" 'ok (match 28 ((? number?) 'ok)))
(display " expected ") (write expect) (test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
(display " but got ") (write res) (newline))))))))
(define (test-report) (test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
(write *tests-passed*) (test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
(display " out of ") (test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test "ellipses" '((a b c) (1 2 3))
;; run tests (match '((a . 1) (b . 2) (c . 3))
(((x . y) ___) (list x y))))
(test "any" (match 'any (_ 'ok)) 'ok) (test "real ellipses" '((a b c) (1 2 3))
(test "symbol" (match 'ok (x x)) 'ok) (match '((a . 1) (b . 2) (c . 3))
(test "number" (match 28 (28 'ok)) 'ok) (((x . y) ...) (list x y))))
(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok)
(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok)
(test "null" (match '() (() 'ok)) 'ok)
(test "pair" (match '(ok) ((x) x)) 'ok)
(test "vector" (match '#(ok) (#(x) x)) 'ok)
(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok)
(test "and empty" (match '(o k) ((and) 'ok)) 'ok)
(test "and single" (match 'ok ((and x) x)) 'ok)
(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok)
(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok)
(test "or single" (match 'ok ((or x) 'ok)) 'ok)
(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok)
(test "not" (match 28 ((not (a . b)) 'ok)) 'ok)
(test "pred" (match 28 ((? number?) 'ok)) 'ok)
(test "named pred" (match 28 ((? number? x) (+ x 1))) 29)
(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) (test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) (#(a b c (hd . tl) ...) (list a b c hd tl))))
(test "ellipses" (test "pred ellipses" '(1 2 3)
(match '((a . 1) (b . 2) (c . 3)) (match '(1 2 3)
(((x . y) ___) (list x y))) (((? odd? n) ___) n)
'((a b c) (1 2 3))) (((? number? n) ___) n)))
(test "real ellipses" (test "failure continuation" 'ok
(match '((a . 1) (b . 2) (c . 3)) (match '(1 2)
(((x . y) ...) (list x y))) ((a . b) (=> next) (if (even? a) 'fail (next)))
'((a b c) (1 2 3))) ((a . b) 'ok)))
(test "vector ellipses" (test "let" '(o k)
(match '#(1 2 3 (a . 1) (b . 2) (c . 3)) (match-let ((x 'ok) (y '(o k))) y))
(#(a b c (hd . tl) ...) (list a b c hd tl)))
'(1 2 3 (a b c) (1 2 3)))
(test "pred ellipses" (test "let*" '(f o o f)
(match '(1 2 3) (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
(((? odd? n) ___) n)
(((? number? n) ___) n))
'(1 2 3))
(test "failure continuation" (test "getter car" '(1 2)
(match '(1 2) (match '(1 . 2) (((get! a) . b) (list (a) b))))
((a . b) (=> next) (if (even? a) 'fail (next)))
((a . b) 'ok))
'ok)
(test "let" (test "getter cdr" '(1 2)
(match-let ((x 'ok) (y '(o k))) (match '(1 . 2) ((a . (get! b)) (list a (b)))))
y)
'(o k))
(test "let*" (test "getter vector" '(1 2 3)
(match-let* ((x 'f) (y 'o) ((z w) (list y x))) (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
(list x y z w))
'(f o o f))
(test "getter car" (test "setter car" '(3 . 2)
(match '(1 . 2) (((get! a) . b) (list (a) b))) (let ((x (cons 1 2)))
'(1 2)) (match x (((set! a) . b) (a 3)))
x))
(test "getter cdr" (test "setter cdr" '(1 . 3)
(match '(1 . 2) ((a . (get! b)) (list a (b)))) (let ((x (cons 1 2)))
'(1 2)) (match x ((a . (set! b)) (b 3)))
x))
(test "getter vector" (test "setter vector" '#(1 0 3)
(match '#(1 2 3) (#((get! a) b c) (list (a) b c))) (let ((x (vector 1 2 3)))
'(1 2 3)) (match x (#(a (set! b) c) (b 0)))
x))
(test "setter car" (test "single tail" '((a b) (1 2) (c . 3))
(let ((x (cons 1 2))) (match '((a . 1) (b . 2) (c . 3))
(match x (((set! a) . b) (a 3))) (((x . y) ... last) (list x y last))))
x)
'(3 . 2))
(test "setter cdr" (test "single tail 2" '((a b) (1 2) 3)
(let ((x (cons 1 2))) (match '((a . 1) (b . 2) 3)
(match x ((a . (set! b)) (b 3))) (((x . y) ... last) (list x y last))))
x)
'(1 . 3))
(test "setter vector" (test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
(let ((x (vector 1 2 3))) (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
(match x (#(a (set! b) c) (b 0))) (((x . y) ... u v w) (list x y u v w))))
x)
'#(1 0 3))
(test "single tail" (test "Riastradh quasiquote" '(2 3)
(match '((a . 1) (b . 2) (c . 3)) (match '(1 2 3) (`(1 ,b ,c) (list b c))))
(((x . y) ... last) (list x y last)))
'((a b) (1 2) (c . 3)))
(test "single tail 2" (test "trivial tree search" '(1 2 3)
(match '((a . 1) (b . 2) 3) (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
(((x . y) ... last) (list x y last)))
'((a b) (1 2) 3))
(test "multiple tail" (test "simple tree search" '(1 2 3)
(match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
(((x . y) ... u v w) (list x y u v w)))
'((a b) (1 2) (c . 3) (d . 4) (e . 5)))
(test "Riastradh quasiquote" (test "deep tree search" '(1 2 3)
(match '(1 2 3) (`(1 ,b ,c) (list b c))) (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
'(2 3))
(test "trivial tree search" (test "non-tail tree search" '(1 2 3)
(match '(1 2 3) ((_ *** (a b c)) (list a b c))) (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
'(1 2 3))
(test "simple tree search" (test "restricted tree search" '(1 2 3)
(match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
'(1 2 3))
(test "deep tree search" (test "fail restricted tree search" #f
(match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) (match '(x (y (x a b c (1 2 3) d e f)))
'(1 2 3)) (('x *** (a b c)) (list a b c))
(else #f)))
(test "non-tail tree search" (test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
(match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
'(1 2 3)) (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(else #f)))
(test "restricted tree search" (test "failed sxml tree search" #f
(match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
'(1 2 3)) (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(test "fail restricted tree search" (else #f)))
(match '(x (y (x a b c (1 2 3) d e f)))
(('x *** (a b c)) (list a b c))
(else #f))
#f)
(test "sxml tree search"
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(else #f))
'(((href . "http://synthcode.com/")) ("synthcode")))
(test "failed sxml tree search"
(match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(else #f))
#f)
(test "collect tree search" (test "collect tree search"
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
(((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(list tag attrs text)) (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
(else #f)) (list tag attrs text))
'((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) (else #f)))
(test-report)
(test-end)

36
tests/numeric-tests.scm
View file

@ -2,39 +2,9 @@
;; these tests are only valid if chibi-scheme is compiled with full ;; these tests are only valid if chibi-scheme is compiled with full
;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) ;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH)
(define *tests-run* 0) (import (chibi test))
(define *tests-passed* 0)
(define-syntax test (test-begin "numbers")
(syntax-rules ()
((test expect expr)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
(res expr))
(display str)
(write-char #\space)
(display (make-string (max 0 (- 72 (string-length str))) #\.))
(flush-output)
(cond
((equal? res expect)
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (integer-neighborhoods x) (define (integer-neighborhoods x)
(list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x)))
@ -147,4 +117,4 @@
(-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1))
(sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) (sign-combinations (+ 1 (expt 2 64)) (expt 2 32)))
(test-report) (test-end)

87
tests/sort-tests.scm
View file

@ -1,57 +1,40 @@
(import (srfi 95)) (import (srfi 95) (chibi test))
(define *tests-run* 0) (test-begin "sorting")
(define *tests-passed* 0)
(define-syntax test (test "sort null" '() (sort '()))
(syntax-rules () (test "sort null <" '() (sort '() <))
((test name expr expect) (test "sort null < car" '() (sort '() < car))
(begin (test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
(set! *tests-run* (+ *tests-run* 1)) (test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
(let ((str (call-with-output-string (lambda (out) (display name out)))) (test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
(res expr)) (test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
(display str) (test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
(write-char #\space) (test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)
(display (make-string (max 0 (- 72 (string-length str))) #\.)) (sort '(7 5 2 8 1 6 4 9 3) <))
(flush-output) (test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9))
(cond (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car))
((equal? res expect)
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run tests
(test "sort null" (sort '()) '())
(test "sort null <" (sort '() <) '())
(test "sort null < car" (sort '() < car) '())
(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9))
(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9))
(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)
'((1) (2) (3) (4) (5) (6) (7) (8) (9)))
(test "sort list (lambda (a b) (< (car a) (car b)))" (test "sort list (lambda (a b) (< (car a) (car b)))"
(sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) '((1) (2) (3) (4) (5) (6) (7) (8) (9))
(lambda (a b) (< (car a) (car b)))) (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3))
'((1) (2) (3) (4) (5) (6) (7) (8) (9))) (lambda (a b) (< (car a) (car b)))))
(test "sort 1-char symbols" (sort '(h b k d a c j i e g f)) (test "sort 1-char symbols" '(a b c d e f g h i j k)
'(a b c d e f g h i j k)) (sort '(h b k d a c j i e g f)))
(test "sort short symbols" (sort '(h b aa k d a ee c j i e g f)) (test "sort short symbols" '(a aa b c d e ee f g h i j k)
'(a aa b c d e ee f g h i j k)) (sort '(h b aa k d a ee c j i e g f)))
(test "sort long symbols" (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)) (test "sort long symbol"
'(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)) '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)
(sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)))
(test "sort long symbols"
'(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k)
(sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)))
(test "sort strings"
'("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk")
(sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear")))
(test "sort strings string-ci<?"
'("ape" "Bear" "CaT" "DOG" "elephant" "Fox" "GoAt" "HAWK")
(sort '("elephant" "CaT" "DOG" "ape" "GoAt" "Fox" "HAWK" "Bear")
string-ci<?))
(test-report) (test-end)

39
tests/thread-tests.scm
View file

@ -1,40 +1,7 @@
(import (srfi 18)) (import (srfi 18) (chibi test))
(define *tests-run* 0) (test-begin)
(define *tests-passed* 0)
(define-syntax test
(syntax-rules ()
((test name expr expect)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string (lambda (out) (display name out))))
(res expr))
(display str)
(write-char #\space)
(display (make-string (max 0 (- 72 (string-length str))) #\.))
(flush-output)
(cond
((equal? res expect)
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run tests
(test "no threads" (begin 'ok) 'ok) (test "no threads" (begin 'ok) 'ok)
(test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok) (test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok)
@ -54,5 +21,5 @@
;(test "mailbox") ;(test "mailbox")
(test-report) (test-end)