Converting tests to modules instead of separate programs.

By convention, a library meant for testing exports "run-tests".
Also by convention, assume the test for (foo bar) is (foo bar-test),
keeping the test in the same directory and avoiding confusion since
(chibi test) is not a test for (chibi).
- Avoids the hack of "load"ing test, with resulting namespace complications.
- Allows keeping tests together with the libraries.
- Allows setting up test hooks before running.
- Allows implicit inference of test locations when using above conventions.

Makefile

@@ -200,50 +200,17 @@ test-build:
 test-ffi: chibi-scheme$(EXE)
 	$(CHIBI) tests/ffi/ffi-tests.scm
 
-test-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
-	$(CHIBI) -xchibi tests/thread-tests.scm
-
 test-numbers: chibi-scheme$(EXE)
 	$(CHIBI) -xchibi tests/numeric-tests.scm
 
 test-flonums: chibi-scheme$(EXE)
 	$(CHIBI) -xchibi tests/flonum-tests.scm
 
-test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
-	$(CHIBI) -xchibi tests/hash-tests.scm
-
-test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
-	$(CHIBI) -xchibi tests/io-tests.scm
-
-test-match: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/match-tests.scm
-
-test-loop: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/loop-tests.scm
-
-test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
-	$(CHIBI) -xchibi tests/sort-tests.scm
-
-test-srfi-1: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/srfi-1-tests.scm
-
-test-records: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/record-tests.scm
-
-test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
-	$(CHIBI) -xchibi tests/weak-tests.scm
-
 test-unicode: chibi-scheme$(EXE)
 	$(CHIBI) -xchibi tests/unicode-tests.scm
 
-test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
-	$(CHIBI) -xchibi tests/process-tests.scm
-
-test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
-	$(CHIBI) -xchibi tests/system-tests.scm
-
 test-libs: chibi-scheme$(EXE)
-	$(CHIBI) -xchibi tests/lib-tests.scm
+	$(CHIBI) tests/lib-tests.scm
 
 test-r5rs: chibi-scheme$(EXE)
 	$(CHIBI) -xchibi tests/r5rs-tests.scm

lib/chibi/base64-test.sld

@@ -0,0 +1,42 @@
+(define-library (chibi base64-test)
+  (export run-tests)
+  (import (chibi) (chibi base64) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "base64")
+
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+          (base64-encode-string "any carnal pleasure."))
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
+          (base64-encode-string "any carnal pleasure"))
+      (test "YW55IGNhcm5hbCBwbGVhc3Vy"
+          (base64-encode-string "any carnal pleasur"))
+      (test "YW55IGNhcm5hbCBwbGVhc3U="
+          (base64-encode-string "any carnal pleasu"))
+      (test "YW55IGNhcm5hbCBwbGVhcw=="
+          (base64-encode-string "any carnal pleas"))
+
+      (test "any carnal pleas"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
+      (test "any carnal pleasu"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
+      (test "any carnal pleasur"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
+      (test "any carnal pleas"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
+      (test "any carnal pleasu"
+          (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
+
+      (test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+          (call-with-output-string
+            (lambda (out)
+              (call-with-input-string "any carnal pleasure."
+                (lambda (in) (base64-encode in out))))))
+
+      (test "any carnal pleasure."
+          (call-with-output-string
+            (lambda (out)
+              (call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+                (lambda (in) (base64-decode in out))))))
+
+      (test-end))))

lib/chibi/crypto/md5-test.sld

@@ -0,0 +1,13 @@
+(define-library (chibi crypto md5-test)
+  (export run-tests)
+  (import (chibi) (chibi crypto md5) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "md5")
+      (test "d41d8cd98f00b204e9800998ecf8427e"
+          (md5 ""))
+      (test "900150983cd24fb0d6963f7d28e17f72"
+          (md5 "abc"))
+      (test "9e107d9d372bb6826bd81d3542a419d6"
+          (md5 "The quick brown fox jumps over the lazy dog"))
+      (test-end))))

lib/chibi/crypto/rsa-test.sld

@@ -0,0 +1,83 @@
+(define-library (chibi crypto rsa-test)
+  (export run-tests)
+  (import (scheme base)
+          (chibi crypto rsa)
+          (chibi crypto sha2)
+          (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "rsa")
+
+      ;; Verify an explicit key.
+
+      ;; p = 61, q = 53
+      (define priv-key (rsa-key-gen-from-primes 8 61 53))
+      (define pub-key (rsa-pub-key priv-key))
+
+      (test 439 (rsa-sign priv-key 42))
+      (test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
+
+      (let ((msg 42))
+        (test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
+
+      (define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
+      (define pub-key2 (rsa-pub-key priv-key2))
+
+      (let ((msg 42))
+        (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
+
+      (let ((msg #u8(42)))
+        (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
+
+      (let ((msg "*"))
+        (test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
+
+      (let ((msg "*"))
+        (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
+
+      (let ((msg #u8(42)))
+        (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
+
+      ;; Key generation.
+
+      (define (test-key key)
+        (test #t (rsa-key? key))
+        (test #t (positive? (rsa-key-n key)))
+        (test #t (positive? (rsa-key-e key)))
+        (test #t (positive? (rsa-key-d key)))
+        (test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
+
+      (test-key (rsa-key-gen 8))
+      (test-key (rsa-key-gen 16))
+      (test-key (rsa-key-gen 32))
+      (test-key (rsa-key-gen-from-primes 32 2936546443 3213384203))
+
+      ;; These are expensive to test.  Times with -h1G:
+      ;; (test-key (rsa-key-gen 128))   ; 0.04s
+      ;; (test-key (rsa-key-gen 256))   ; 0.4s
+      ;; (test-key (rsa-key-gen 512))   ; 4s
+      ;; (test-key (rsa-key-gen 1024))  ; 92s
+
+      ;; padding
+
+      (test #u8(8 8 8 8 8 8 8 8) (pkcs1-pad #u8()))
+      (test #u8(1 7 7 7 7 7 7 7) (pkcs1-pad #u8(1)))
+      (test #u8(1 2 6 6 6 6 6 6) (pkcs1-pad #u8(1 2)))
+      (test #u8(1 2 3 5 5 5 5 5) (pkcs1-pad #u8(1 2 3)))
+      (test #u8(1 2 3 4 4 4 4 4) (pkcs1-pad #u8(1 2 3 4)))
+      (test #u8(1 2 3 4 5 3 3 3) (pkcs1-pad #u8(1 2 3 4 5)))
+      (test #u8(1 2 3 4 5 6 2 2) (pkcs1-pad #u8(1 2 3 4 5 6)))
+      (test #u8(1 2 3 4 5 6 7 1) (pkcs1-pad #u8(1 2 3 4 5 6 7)))
+      (test #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8) (pkcs1-pad #u8(1 2 3 4 5 6 7 8)))
+
+      (test #u8() (pkcs1-unpad #u8(8 8 8 8 8 8 8 8)))
+      (test #u8(1) (pkcs1-unpad #u8(1 7 7 7 7 7 7 7)))
+      (test #u8(1 2) (pkcs1-unpad #u8(1 2 6 6 6 6 6 6)))
+      (test #u8(1 2 3) (pkcs1-unpad #u8(1 2 3 5 5 5 5 5)))
+      (test #u8(1 2 3 4) (pkcs1-unpad #u8(1 2 3 4 4 4 4 4)))
+      (test #u8(1 2 3 4 5) (pkcs1-unpad #u8(1 2 3 4 5 3 3 3)))
+      (test #u8(1 2 3 4 5 6) (pkcs1-unpad #u8(1 2 3 4 5 6 2 2)))
+      (test #u8(1 2 3 4 5 6 7) (pkcs1-unpad #u8(1 2 3 4 5 6 7 1)))
+      (test #u8(1 2 3 4 5 6 7 8) (pkcs1-unpad #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8)))
+
+      (test-end))))

lib/chibi/crypto/sha2-test.sld

@@ -0,0 +1,23 @@
+(define-library (chibi crypto sha2-test)
+  (export run-tests)
+  (import (chibi) (chibi crypto sha2) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "sha2")
+      (test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
+          (sha-224 ""))
+      (test "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7"
+          (sha-224 "abc"))
+      (test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
+          (sha-224 "The quick brown fox jumps over the lazy dog"))
+      (test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+          (sha-256 ""))
+      (test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
+          (sha-256 "abc"))
+      (test "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592"
+          (sha-256 "The quick brown fox jumps over the lazy dog"))
+      (test "61f8fe4c4cdc8b3e10673933fcd0c5b1f6b46d3392550e42b265daefc7bc0d31"
+          (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
+      (test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
+          (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
+      (test-end))))

lib/chibi/filesystem-test.sld

@@ -0,0 +1,76 @@
+(define-library (chibi filesystem-test)
+  (export run-tests)
+  (import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
+  (begin
+    (define (run-tests)
+      (test-begin "filesystem")
+
+      (define tmp-file "/tmp/chibi-fs-test-0123456789")
+      (define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
+      (define tmp-link "/tmp/chibi-fs-test-0123456789-link")
+      (define tmp-dir "/tmp/chibi-fs-test-0123456789-dir")
+
+      (call-with-output-file tmp-file
+        (lambda (out) (display "0123456789" out)))
+
+      (test-assert (file-exists? tmp-file))
+      (test "0123456789" (call-with-input-file tmp-file port->string))
+
+      ;; call-with-output-file truncates
+      (call-with-output-file tmp-file
+        (lambda (out) (display "xxxxx" out)))
+      (test "xxxxx" (call-with-input-file tmp-file port->string))
+
+      (call-with-output-file tmp-file
+        (lambda (out) (display "0123456789" out)))
+      (test "0123456789" (call-with-input-file tmp-file port->string))
+
+      ;; open without open/truncate writes in place
+      (let* ((fd (open tmp-file open/write))
+             (out (open-output-file-descriptor fd)))
+        (display "xxxxx" out)
+        (close-output-port out))
+      (test "xxxxx56789" (call-with-input-file tmp-file port->string))
+
+      ;; file-truncate can explicitly truncate
+      (let* ((fd (open tmp-file open/write))
+             (out (open-output-file-descriptor fd)))
+        (display "01234" out)
+        (file-truncate out 7)
+        (close-output-port out))
+      (test "0123456" (call-with-input-file tmp-file port->string))
+
+      ;; symbolic links
+      (test-assert (symbolic-link-file tmp-file tmp-link))
+      (test-assert (file-exists? tmp-link))
+      (test-assert (file-link? tmp-link))
+      (test tmp-file (read-link tmp-link))
+
+      ;; rename
+      (test-assert (rename-file tmp-file tmp-file2))
+      (test-not (file-exists? tmp-file))
+      (test-not (file-exists? tmp-link))
+      (test-assert (file-link? tmp-link))
+      (test-assert (delete-file tmp-link))
+      (test-not (file-exists? tmp-link))
+
+      ;; cleanup
+      (test-assert (delete-file tmp-file2))
+      (test-not (file-exists? tmp-file2))
+
+      ;; directories
+      (test-assert (file-directory? "."))
+      (test-assert (file-directory? ".."))
+      (test-assert (file-directory? "/"))
+      (test-not (file-regular? "."))
+      (test-assert (create-directory tmp-dir))
+      (test-assert (file-directory? tmp-dir))
+      (test-not (file-regular? tmp-dir))
+      (test-assert
+          (let ((files (directory-files tmp-dir)))
+            (or (equal? files '("." ".."))
+                (equal? files '(".." ".")))))
+      (test-assert (delete-directory tmp-dir))
+      (test-not (file-directory? tmp-dir))
+
+      (test-end))))

lib/chibi/generic-test.sld

@@ -0,0 +1,37 @@
+(define-library (chibi filesystem-test)
+  (export run-tests)
+  (import (chibi) (chibi generic) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "generics")
+
+      (let ()
+        (define-generic add)
+        (define-method (add (x number?) (y number?))
+          (+ x y))
+        (define-method (add (x string?) (y string?))
+          (string-append x y))
+        (define-method (add x (y list?))
+          (append x y))
+        (test 4 (add 2 2))
+        (test "22" (add "2" "2"))
+        (test '(2 2) (add '() '(2 2)))
+        (test '(2 2) (add '(2) '(2)))
+        (test '(2 2) (add '(2 2) '()))
+        (test '(2) (add #f '(2)))
+        (test-error (add #(2) #(2))))
+
+      (let ()
+        (define-generic mul)
+        (define-method (mul (x number?) (y number?))
+          (* x y))
+        (define-method (mul (x inexact?) (y inexact?))
+          (+ (* x y) 0.1))
+        (define-method (mul (x exact?) (y exact?))
+          (inexact->exact (call-next-method)))
+        (test 21 (mul 3 7))
+        (test 21.0 (mul 3.0 7))
+        (test 21.0 (mul 3 7.0))
+        (test 21.1 (mul 3.0 7.0)))
+
+      (test-end))))

lib/chibi/io-test.sld

@@ -0,0 +1,167 @@
+(define-library (chibi io-test)
+  (export run-tests)
+  (import (chibi)
+          (chibi io)
+          (only (scheme base) read-bytevector write-bytevector)
+          (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "io")
+
+      (define long-string (make-string 2000 #\a))
+
+      (test "input-string-port" 1025
+        (call-with-input-string (substring long-string 0 1025)
+          (lambda (in)
+            (let loop ((c (read-char in)) (i 0))
+              (cond ((eof-object? c) i)
+                    ((> i 1025) (error "read past eof"))
+                    (else (loop (read-char in) (+ i 1))))))))
+
+      (test "read-line" '("abc" "def")
+        (call-with-input-string "abc\ndef\n"
+          (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
+
+      (test "read-line" '("abc" "def" "ghi")
+        (call-with-input-string "abcdef\nghi\n"
+          (lambda (in)
+            (let* ((line1 (read-line in 3))
+                   (line2 (read-line in 3)))
+              (list line1 line2 (read-line in 3))))))
+
+      (test "read-line-to-eof" '("abc" "def")
+        (call-with-input-string "abc\ndef"
+          (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
+
+      (test "read-string" '("abc" "def")
+        (call-with-input-string "abcdef"
+          (lambda (in)
+            (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+      (test "read-string-to-eof" '("abc" "de")
+        (call-with-input-string "abcde"
+          (lambda (in)
+            (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+      (test "read-string" '("ab日" "本語f")
+        (call-with-input-string "ab日本語f"
+          (lambda (in)
+            (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+      (test "read-string!" '("abc" "def")
+        (call-with-input-string "abcdef"
+          (lambda (in)
+            (let* ((str1 (make-string 3))
+                   (str2 (make-string 3)))
+              (read-string! str1 3 in)
+              (read-string! str2 3 in)
+              (list str1 str2)))))
+
+      (test "read-string!-to-eof" '("abc" "de ")
+        (call-with-input-string "abcde"
+          (lambda (in)
+            (let* ((str1 (make-string 3))
+                   (str2 (make-string 3 #\space)))
+              (read-string! str1 3 in)
+              (read-string! str2 3 in)
+              (list str1 str2)))))
+
+      (test "null-output-port" #t
+        (let ((out (make-null-output-port)))
+          (write 1 out)
+          (close-output-port out)
+          #t))
+
+      (test "null-input-port" #t
+        (let ((in (make-null-input-port)))
+          (let ((res (eof-object? (read-char in))))
+            (close-input-port in)
+            res)))
+
+      (define (string-upcase str)
+        (list->string (map char-upcase (string->list str))))
+
+      (test "upcase-input-port" "ABC"
+        (call-with-input-string "abc"
+          (lambda (in)
+            (let ((in (make-filtered-input-port string-upcase in)))
+              (let ((res (read-line in)))
+                (close-input-port in)
+                res)))))
+
+      (test "upcase-output-port" "ABC"
+        (call-with-output-string
+          (lambda (out)
+            (let ((out (make-filtered-output-port string-upcase out)))
+              (display "abc" out)
+              (close-output-port out)))))
+
+      (define (strings->input-port str-ls)
+        (make-generated-input-port
+         (lambda ()
+           (and (pair? str-ls)
+                (let ((res (car str-ls)))
+                  (set! str-ls (cdr str-ls))
+                  res)))))
+
+      (test "abcdef" (read-line (strings->input-port '("abcdef"))))
+      (test "abcdef" (read-line (strings->input-port '("abc" "def"))))
+      (test "abcdef"
+          (read-line (strings->input-port '("a" "b" "c" "d" "e" "f"))))
+      (test "日本語" (read-line (strings->input-port '("日本語"))))
+      (test "日本語" (read-line (strings->input-port '("日" "本" "語"))))
+      (test "abc"
+          (let ((in (strings->input-port
+                     (list "日本語" (make-string 4087 #\-) "abc"))))
+            (read-string 4090 in)
+            (read-line in)))
+      (test "abc"
+          (let ((in (strings->input-port
+                     (list "日本語" (make-string 4087 #\本) "abc"))))
+            (read-string 4090 in)
+            (read-line in)))
+      (test "abc"
+          (let ((in (strings->input-port
+                     (list "日本語" (make-string 4093 #\-) "abc"))))
+            (read-string 4096 in)
+            (read-line in)))
+
+      (let ((in (make-custom-binary-input-port
+                 (let ((i 0))
+                   (lambda (bv start end)
+                     (do ((j start (+ j 1)))
+                         ((= j end))
+                       (bytevector-u8-set! bv j (modulo (+ j i) 256)))
+                     (if (> end 0)
+                         (set! i (bytevector-u8-ref bv (- end 1))))
+                     (- end start))))))
+        (test #u8(0 1 2 3) (read-bytevector 4 in))
+        (test #u8(4 5 6 7) (read-bytevector 4 in))
+        (test 7 (bytevector-u8-ref (read-bytevector 256 in) 255))
+        (test 6 (bytevector-u8-ref (read-bytevector 1024 in) 1022)))
+
+      (let* ((sum 0)
+             (out (make-custom-binary-output-port
+                   (lambda (bv start end)
+                     (do ((i start (+ i 1))
+                          (x 0 (+ x (bytevector-u8-ref bv i))))
+                         ((= i end) (set! sum x)))))))
+        (write-bytevector #u8(0 1 2 3) out)
+        (flush-output out)
+        (test 6 sum)
+        (write-bytevector #u8(100) out)
+        (flush-output out)
+        (test 106 sum))
+
+      (test "file-position"
+          '(0 1 2)
+        (let* ((p (open-input-file "/etc/passwd"))
+               (t0 (file-position p)))
+          (read-char p)
+          (let ((t1 (file-position p)))
+            (read-char p)
+            (let ((t2 (file-position p)))
+              (close-input-port p)
+              (list t0 t1 t2)))))
+
+      (test-end))))

lib/chibi/iset-test.sld

@@ -0,0 +1,198 @@
+(define-library (chibi iset-test)
+  (export run-tests)
+  (import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test))
+  (begin
+    (define (run-tests)
+      (define (test-name iset op)
+        (call-with-output-string
+          (lambda (out)
+            (let* ((ls (iset->list iset))
+                   (ls (if (> (length ls) 10)
+                           `(,@(take ls 5) ... ,@(take-right ls 5))
+                           ls)))
+              (write `(,(car op) (iset ,@ls) ,@(cdr op)) out)))))
+
+      (test-begin "iset")
+
+      ;; Tests to perform repeated operations on an iset.  The first element
+      ;; in each list is a list of integers to initialize the set `is', which
+      ;; we generate and verify the size and round-trip list conversion.
+      ;; Subsequent elements are abbreviated operations on is:
+      ;;
+      ;;   (+ a ...)     (iset-adjoin! a) ...
+      ;;   (- a ...)     (iset-delete! a) ...
+      ;;   (= a ...)     (test (list a ...) (iset->list is))
+      ;;   (<= a ...)    (test-assert (iset<= is (iset a ...)))
+      ;;   (? a ...)     (test-assert (iset-contains? is a)) ...
+      ;;   (!? a ...)    (test-not (iset-contains? is a)) ...
+      ;;   (u a ...)     (iset-union is (iset a ...))
+      ;;   (u: a b)      (iset-union is (make-iset a b))
+      ;;   (i a ...)     (iset-intersection is (iset a ...))
+      ;;   (d a ...)     (iset-difference is (iset a ...))
+      ;;   (m f)         (iset-map f is)
+      ;;   (s size)      (test size (iset-size iset))
+      ;;   (z [empty?])  (test empty? (iset-empty? iset))
+      (let ((tests
+             `(;; construction
+               ((1 128 127))
+               ((129 2 127))
+               ((1 -128 -126))
+               ((1 2 3 1000 1005))
+               ((97308 97827 97845 97827))
+               ((1 2 3 4 5 6 7 8))
+               ((2 3 4 5 6 7 8))
+               ((1 3 4 5 6 7 8))
+               ((1 2 4 5 6 7 8))
+               ((1 2 3 5 6 7 8))
+               ((1 2 3 4 6 7 8))
+               ((1 2 3 4 5 7 8))
+               ((1 2 3 4 5 6 8))
+               ((1 2 3 4 5 6 7))
+               ;; ordering
+               ((97) (<= 97 117))
+               ((117) (<= 97 117))
+               ;; individual elements
+               (() (+ 99) (u 3 50) (? 99))
+               (() (+ 1) (+ 1000) (+ -1000) (+ 3) (+ -1))
+               ((0) (z #f) (- 0) (z))
+               ((0 1 2) (- 1) (- 2) (? 0))
+               ;; union
+               ((17 29) (u 7 29))
+               ((2 3 4) (u 1 2 3 4 5))
+               ((1 2 3 4 5) (u 2 3 4))
+               ((1 2 3 1000 2000) (u 1 4))
+               ((1 3) (u 1 4) (= 1 3 4))
+               ((1 3) (u 3 4) (= 1 3 4))
+               ((1) (u 1 3) (= 1 3))
+               ((3) (u 1 3) (= 1 3))
+               ((1 4) (u 3 4 5) (= 1 3 4 5))
+               ((1 2 3 4) (u 5 6 7 8) (= 1 2 3 4 5 6 7 8))
+               ((1 3 4) (u 5 6 7 8) (= 1 3 4 5 6 7 8))
+               ((1 2 4) (u 5 6 7 8) (= 1 2 4 5 6 7 8))
+               ((1 2 3) (u 5 6 7 8) (= 1 2 3 5 6 7 8))
+               ((1 2 3 4) (u 6 7 8) (= 1 2 3 4 6 7 8))
+               ((1 2 3 4) (u 5 7 8) (= 1 2 3 4 5 7 8))
+               ((1 2 3 4) (u 5 6 8) (= 1 2 3 4 5 6 8))
+               ((1 2 3) (u 6 7 8) (= 1 2 3 6 7 8))
+               ((1 3) (u 6 8) (= 1 3 6 8))
+               ((1 2 3 4 1001 1002)
+                (u 1003 1004 2001 2002 2003 2004)
+                (= 1 2 3 4 1001 1002 1003 1004 2001 2002 2003 2004))
+               ((1 2 4 1001 1002)
+                (u 1003 1004 2001 2002 2003 2004)
+                (= 1 2 4 1001 1002 1003 1004 2001 2002 2003 2004))
+               ((1 2 3 4 1001 1002)
+                (u 1004 2001 2002 2003 2004)
+                (= 1 2 3 4 1001 1002 1004 2001 2002 2003 2004))
+               ((1 2 3 4 1001 1002)
+                (u 1003 1004 2001 2003 2004)
+                (= 1 2 3 4 1001 1002 1003 1004 2001 2003 2004))
+               (() (u: 349 680) (u: 682 685))
+               (() (u: 64434 64449) (u: 65020 65021) (u #xFE62))
+               (() (u: 716 747) (u: 750 1084))
+               (() (u: 48 57) (u: 65 90) (u: 97 122) (u 45 46 95 126) (? 119))
+               ;; intersection
+               ((1 2 3 4 5) (i 1) (= 1))
+               ((1 2 3 4 5) (i 1 2) (= 1 2))
+               ((1 2 3 4 5) (i 1 2 3) (= 1 2 3))
+               ((1 2 3 4 5) (i 2 3) (= 2 3))
+               ((1 2 3 4 5) (i 2 3 4) (= 2 3 4))
+               ((1 2 3 4 5) (i 5) (= 5))
+               ((1 2 3 4 5) (i 4 5) (= 4 5))
+               ((1 2 3 4 5) (i 1 2 3 4 5) (= 1 2 3 4 5))
+               ((1 2 3 4 5) (i 0 1 5 6) (= 1 5))
+               ;; difference
+               ((1 2 3 4 5) (d 1) (!? 0) (? 2 3 4 5) (!? 6))
+               ((1 2 3 4 5) (d 1 2) (!? 0) (? 3 4 5) (!? 6))
+               ((1 2 3 4 5) (d 1 2 3) (!? 0) (? 4 4) (!? 6))
+               ((1 2 3 4 5) (d 2 3) (!? 0) (? 1 4 5) (!? 6))
+               ((1 2 3 4 5) (d 2 3 4) (!? 0) (? 1 5) (!? 6))
+               ((1 2 3 4 5) (d 5) (!? 0) (? 1 2 3 4) (!? 6))
+               ((1 2 3 4 5) (d 4 5) (!? 0) (? 1 2 3) (!? 6))
+               ((1 2 3 4 5) (d 1 2 3 4 5) (z))
+               ((1 2 3 4 5) (d 0 1 5 6) (? 2 3 4))
+               ;; map
+               ((1 2 3) (m ,(lambda (x) (+ x 1))) (= 2 3 4))
+               )))
+        (for-each
+         (lambda (tst)
+           (let* ((ls (car tst))
+                  (is (list->iset ls))
+                  (ls2 (delete-duplicates ls =)))
+             ;; initial creation and sanity checks
+             (test-assert (lset= equal? ls2 (iset->list is)))
+             (test (length ls2) (iset-size is))
+             (test-assert (call-with-output-string
+                            (lambda (out)
+                              (display "init: " out)
+                              (write ls out)))
+               (every
+                (lambda (x) (iset-contains? is x))
+                ls))
+             (test (iset-contains? is 42) (member 42 ls))
+             ;; additional operations
+             (for-each
+              (lambda (op)
+                (let ((name (test-name is op)))
+                  (case (car op)
+                    ((+)
+                     (for-each
+                      (lambda (x) (iset-adjoin! is x))
+                      (cdr op))
+                     (test-assert name (iset-contains? is (cadr op))))
+                    ((-)
+                     (for-each
+                      (lambda (x) (iset-delete! is x))
+                      (cdr op))
+                     (test-assert name (not (iset-contains? is (cadr op)))))
+                    ((=)
+                     (test name (cdr op) (iset->list is))
+                     (test-assert name (iset= (list->iset (cdr op)) is)))
+                    ((<=)
+                     (test-assert name (iset<= is (list->iset (cdr op)))))
+                    ((?)
+                     (test-assert name
+                       (every (lambda (x) (iset-contains? is x)) (cdr op))))
+                    ((!?)
+                     (test-assert name
+                       (every (lambda (x) (not (iset-contains? is x))) (cdr op))))
+                    ((d)
+                     (set! is (iset-difference is (list->iset (cdr op))))
+                     (test-assert name
+                       (every
+                        (lambda (x) (not (iset-contains? is x)))
+                        (cdr op))))
+                    ((i) (set! is (iset-intersection is (list->iset (cdr op)))))
+                    ((u u:)
+                     (let ((arg (cond ((eq? 'u: (car op))
+                                       (make-iset (cadr op) (car (cddr op))))
+                                      ((iset? (cadr op)) (cadr op))
+                                      (else (list->iset (cdr op))))))
+                       (set! is (iset-union is arg)))
+                     (test-assert name
+                       (every (lambda (x)
+                                (or (not (integer? x))
+                                    (iset-contains? is x)))
+                              (cdr op))))
+                    ((m) (set! is (iset-map (cadr op) is)))
+                    ((s) (test (iset-size is) (cadr op)))
+                    ((z)
+                     (test (iset-empty? is)
+                         (if (pair? (cdr op)) (cadr op) #t)))
+                    (else (error "unknown operation" (car op))))))
+              (cdr tst))
+             ;; optimization
+             (let* ((is2 (iset-optimize is))
+                    (is3 (iset-balance is))
+                    (is4 (iset-balance is2)))
+               (test-assert (iset= is is2))
+               (test-assert (iset= is is3))
+               (test-assert (iset= is is4)))))
+         tests))
+
+      (let ((a (%make-iset 65 90 #f #f (%make-iset 97 122 #f #f #f)))
+            (b (list->iset '(45 46 95 126))))
+        (test-assert (iset-contains? (iset-union a b) 119))
+        (test-assert (iset-contains? (iset-union b a) 119))) 
+
+      (test-end))))

lib/chibi/loop-test.sld

@@ -0,0 +1,174 @@
+(define-library (chibi loop-test)
+  (export run-tests)
+  (import (chibi) (chibi loop) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "loops")
+
+      (test
+          "stepping"
+          '(0 1 2)
+        (loop lp ((with i 0 (+ i 1))
+                  (with res '() (cons i res)))
+          (if (= i 3)
+              (reverse res)
+              (lp))))
+
+      (test
+          "basic in-list"
+          '(c b a)
+        (let ((res '()))
+          (loop ((for x (in-list '(a b c))))
+            (set! res (cons x res)))
+          res))
+
+      (test
+          "in-list with result"
+          '(c b a)
+        (loop ((for x (in-list '(a b c)))
+               (with res '() (cons x res)))
+          => res))
+
+      (test
+          "in-list with listing"
+          '(a b c)
+        (loop ((for x (in-list '(a b c))) (for res (listing x))) => res))
+
+      (test
+          "in-list with listing-reverse"
+          '(c b a)
+        (loop ((for x (in-list '(a b c))) (for res (listing-reverse x)))
+          => res))
+
+      (test
+          "uneven length in-list's"
+          '((a . 1) (b . 2) (c . 3))
+        (loop ((for x (in-list '(a b c)))
+               (for y (in-list '(1 2 3 4)))
+               (for res (listing (cons x y))))
+          => res))
+
+      (test
+          "in-lists"
+          '((a 1) (b 2) (c 3))
+        (loop ((for ls (in-lists '((a b c) (1 2 3))))
+               (for res (listing ls)))
+          => res))
+
+      (define (flatten ls)
+        (reverse
+         (loop lp ((for x ls (in-list ls)) (with res '()))
+           => res
+           (if (pair? x)
+               (lp (=> res (lp (=> ls x))))
+               (lp (=> res (cons x res)))))))
+
+      (test
+          "flatten (recursion test)"
+          '(1 2 3 4 5 6 7)
+        (flatten '(1 (2) (3 (4 (5)) 6) 7)))
+
+      (test
+          "in-string"
+          '(#\h #\e #\l #\l #\o)
+        (loop ((for c (in-string "hello")) (for res (listing c))) => res))
+
+      (test
+          "in-string with start"
+          '(#\l #\o)
+        (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res))
+
+      (test
+          "in-string with start and end"
+          '(#\h #\e #\l #\l)
+        (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res))
+
+      (test
+          "in-string-reverse"
+          '(#\o #\l #\l #\e #\h)
+        (loop ((for c (in-string-reverse "hello")) (for res (listing c)))
+          => res))
+
+      (test
+          "in-vector"
+          '(1 2 3)
+        (loop ((for x (in-vector '#(1 2 3))) (for res (listing x)))
+          => res))
+
+      (test
+          "in-vector-reverse"
+          '(3 2 1)
+        (loop ((for x (in-vector-reverse '#(1 2 3))) (for res (listing x)))
+          => res))
+
+      (test "up-from" '(5 6 7)
+        (loop ((for i (up-from 5 (to 8)))
+               (for res (listing i)))
+          => res))
+
+      (test "up-from by" '(5 10 15)
+        (loop ((for i (up-from 5 (to 20) (by 5)))
+               (for res (listing i)))
+          => res))
+
+      (test "up-from listing if" '(10 12 14 16 18)
+        (loop ((for i (up-from 10 (to 20)))
+               (for res (listing i (if (even? i)))))
+          => res))
+
+      (test "down-from" '(7 6 5)
+        (loop ((for i (down-from 8 (to 5)))
+               (for res (listing i)))
+          => res))
+
+      (test "down-from by" '(15 10 5)
+        (loop ((for i (down-from 20 (to 5) (by 5)))
+               (for res (listing i)))
+          => res))
+
+      (test "down-from listing if" '(18 16 14 12 10)
+        (loop ((for i (down-from 20 (to 10)))
+               (for res (listing i (if (even? i)))))
+          => res))
+
+      (test "appending" '(1 2 3 4 5 6 7 8 9)
+        (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
+               (for res (appending ls)))
+          => res))
+
+      (test "appending-reverse" '(9 8 7 6 5 4 3 2 1)
+        (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
+               (for res (appending-reverse ls)))
+          => res))
+
+      (test "while + up-from" '(5 6 7)
+        (loop ((for i (up-from 5 (to 10)))
+               (while (< i 8))
+               (for res (listing i)))
+          => res))
+
+      (test "up-from by, open-ended" '(5 7 9)
+        (loop ((for i (up-from 5 (by 2)))
+               (while (< i 10))
+               (for res (listing i)))
+          => res))
+
+      (test "up-from open-ended" '(5 6 7)
+        (loop ((for i (up-from 5))
+               (while (< i 8))
+               (for res (listing i)))
+          => res))
+
+      (test "down-from by, open-ended" '(5 3 1)
+        (loop ((for i (down-from 7 (by 2)))
+               (until (< i 1))
+               (for res (listing i)))
+          => res))
+
+      (test "down-from open-ended" '(4 3 2)
+        (loop ((for i (down-from 5))
+               (until (< i 2))
+               (for res (listing i)))
+          => res))
+
+      (test-end))))

lib/chibi/match-test.sld

@@ -0,0 +1,195 @@
+(define-library (chibi match-test)
+  (export run-tests)
+  (import (except (scheme base) equal?)
+          (chibi match)
+          (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "match")
+
+      (test "any" 'ok (match 'any (_ 'ok)))
+      (test "symbol" 'ok (match 'ok (x x)))
+      (test "number" 'ok (match 28 (28 'ok)))
+      (test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
+      (test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
+      (test "null" 'ok (match '() (() 'ok)))
+      (test "pair" 'ok (match '(ok) ((x) x)))
+      (test "vector" 'ok (match '#(ok) (#(x) x)))
+      (test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
+      (test "and empty" 'ok (match '(o k) ((and) 'ok)))
+      (test "and single" 'ok (match 'ok ((and x) x)))
+      (test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
+      (test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
+      (test "or single" 'ok (match 'ok ((or x) 'ok)))
+      (test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
+      (test "not" 'ok (match 28 ((not (a . b)) 'ok)))
+      (test "pred" 'ok (match 28 ((? number?) 'ok)))
+      (test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
+
+      (test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
+      (test "duplicate symbols fail" 'ok
+        (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
+      (test "duplicate symbols samth" 'ok
+        (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
+      (test "duplicate symbols bound" 3
+        (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
+
+      (test "ellipses" '((a b c) (1 2 3))
+        (match '((a . 1) (b . 2) (c . 3))
+          (((x . y) ___) (list x y))))
+
+      (test "real ellipses" '((a b c) (1 2 3))
+        (match '((a . 1) (b . 2) (c . 3))
+          (((x . y) ...) (list x y))))
+
+      (test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
+        (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
+          (#(a b c (hd . tl) ...) (list a b c hd tl))))
+
+      (test "pred ellipses" '(1 2 3)
+        (match '(1 2 3)
+          (((? odd? n) ___) n)
+          (((? number? n) ___) n)))
+
+      (test "failure continuation" 'ok
+        (match '(1 2)
+          ((a . b) (=> next) (if (even? a) 'fail (next)))
+          ((a . b) 'ok)))
+
+      (test "let" '(o k)
+        (match-let ((x 'ok) (y '(o k))) y))
+
+      (test "let*" '(f o o f)
+        (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
+
+      (test "getter car" '(1 2)
+        (match '(1 . 2) (((get! a) . b) (list (a) b))))
+
+      (test "getter cdr" '(1 2)
+        (match '(1 . 2) ((a . (get! b)) (list a (b)))))
+
+      (test "getter vector" '(1 2 3)
+        (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
+
+      (test "setter car" '(3 . 2)
+        (let ((x (cons 1 2)))
+          (match x (((set! a) . b) (a 3)))
+          x))
+
+      (test "setter cdr" '(1 . 3)
+        (let ((x (cons 1 2)))
+          (match x ((a . (set! b)) (b 3)))
+          x))
+
+      (test "setter vector" '#(1 0 3)
+        (let ((x (vector 1 2 3)))
+          (match x (#(a (set! b) c) (b 0)))
+          x))
+
+      (test "single tail" '((a b) (1 2) (c . 3))
+        (match '((a . 1) (b . 2) (c . 3))
+          (((x . y) ... last) (list x y last))))
+
+      (test "single tail 2" '((a b) (1 2) 3)
+        (match '((a . 1) (b . 2) 3)
+          (((x . y) ... last) (list x y last))))
+
+      (test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
+        (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
+          (((x . y) ... u v w) (list x y u v w))))
+
+      (test "tail against improper list" #f
+        (match '(a b c d e f . g)
+          ((x ... y u v w) (list x y u v w))
+          (else #f)))
+
+      (test "Riastradh quasiquote" '(2 3)
+        (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+      (test "trivial tree search" '(1 2 3)
+        (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+      (test "simple tree search" '(1 2 3)
+        (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+      (test "deep tree search" '(1 2 3)
+        (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+      (test "non-tail tree search" '(1 2 3)
+        (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+      (test "restricted tree search" '(1 2 3)
+        (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+      (test "fail restricted tree search" #f
+        (match '(x (y (x a b c (1 2 3) d e f)))
+          (('x *** (a b c)) (list a b c))
+          (else #f)))
+
+      (test "sxml tree search"
+          '(((href . "http://synthcode.com/")) ("synthcode"))
+        (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)))
+
+      (test "failed sxml tree search" #f
+        (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)))
+
+      (test "collect tree search"
+          '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+        (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/"))
+                                      "synthcode") d e f)))
+          (((and tag (or 'p 'ul 'li 'b)) *** ('a ('@ attrs ...) text ...))
+           (list tag attrs text))
+          (else #f)))
+
+      (test "anded tail pattern" '(1 2)
+        (match '(1 2 3) ((and (a ... b) x) a)))
+
+      (test "anded search pattern" '(a b c)
+        (match '(a (b (c d))) ((and (p *** 'd) x) p)))
+
+      (test "joined tail" '(1 2)
+        (match '(1 2 3) ((and (a ... b) x) a)))
+
+      (test "list ..1" '(a b c)
+        (match '(a b c) ((x ..1) x)))
+
+      (test "list ..1 failed" #f
+        (match '()
+          ((x ..1) x)
+          (else #f)))
+
+      (test "list ..1 with predicate" '(a b c)
+        (match '(a b c)
+          (((and x (? symbol?)) ..1) x)))
+
+      (test "list ..1 with failed predicate" #f
+        (match '(a b 3)
+          (((and x (? symbol?)) ..1) x)
+          (else #f)))
+
+      (cond-expand
+       (chibi
+        (define-record-type Point
+          (make-point x y)
+          point?
+          (x point-x point-x-set!)
+          (y point-y point-y-set!))
+        (test "record positional"
+            '(1 0)
+          (match (make-point 0 1)
+            (($ Point x y) (list y x))))
+        (test "record named"
+            '(1 0)
+          (match (make-point 0 1)
+            ((@ Point (x x) (y y)) (list y x)))))
+       (else))
+
+      (test-end))))

lib/chibi/math/prime-test.sld

@@ -0,0 +1,98 @@
+(define-library (chibi math prime-test)
+  (export run-tests)
+  (import (chibi) (chibi math prime) (chibi test))
+  (begin
+    (define (run-tests)
+
+      (test-begin "prime")
+
+      (test 7 (modular-inverse 3 10))
+      (test 4 (modular-inverse 3 11))
+      (test 27 (modular-inverse 3 40))
+      (test 43 (modular-inverse 3 64))
+
+      (test #f (prime? 1))
+      (test #t (prime? 2))
+      (test #t (prime? 3))
+      (test #f (prime? 4))
+      (test #t (prime? 5))
+      (test #f (prime? 6))
+      (test #t (prime? 7))
+      (test #f (prime? 8))
+      (test #f (prime? 9))
+      (test #f (prime? 10))
+      (test #t (prime? 11))
+
+      (test 2 (nth-prime 0))
+      (test 3 (nth-prime 1))
+      (test 5 (nth-prime 2))
+      (test 7 (nth-prime 3))
+      (test 11 (nth-prime 4))
+      (test 997 (nth-prime 167))
+      (test 1009 (nth-prime 168))
+      (test 1013 (nth-prime 169))
+
+      (test 907 (prime-above 888))
+      (test 797 (prime-below 808))
+
+      (test 1 (totient 2))
+      (test 2 (totient 3))
+      (test 2 (totient 4))
+      (test 4 (totient 5))
+      (test 2 (totient 6))
+      (test 6 (totient 7))
+      (test 4 (totient 8))
+      (test 6 (totient 9))
+      (test 4 (totient 10))
+
+      (test #f (perfect? 1))
+      (test #f (perfect? 2))
+      (test #f (perfect? 3))
+      (test #f (perfect? 4))
+      (test #f (perfect? 5))
+      (test #t (perfect? 6))
+      (test #f (perfect? 7))
+      (test #f (perfect? 8))
+      (test #f (perfect? 9))
+      (test #f (perfect? 10))
+      (test #t (perfect? 28))
+      (test #t (perfect? 496))
+      (test #t (perfect? 8128))
+
+      (test '(1) (factor 1))
+      (test '(2) (factor 2))
+      (test '(3) (factor 3))
+      (test '(2 2) (factor 4))
+      (test '(5) (factor 5))
+      (test '(2 3) (factor 6))
+      (test '(7) (factor 7))
+      (test '(2 2 2) (factor 8))
+      (test '(3 3) (factor 9))
+      (test '(2 5) (factor 10))
+      (test '(11) (factor 11))
+      (test '(2 2 3) (factor 12))
+      (test '(2 3 3) (factor 18))
+      (test '(2 2 2 3 3) (factor 72))
+      (test '(3 3 3 5 7) (factor 945))
+
+      (test 975 (aliquot 945))
+
+      (do ((i 3 (+ i 2)))
+          ((>= i 101))
+        (test (number->string i) (prime? i)
+          (probable-prime? i)))
+
+      (test #t (probable-prime? 4611686020149081683))
+      (test #t (probable-prime? 4611686020243253179))
+      (test #t (probable-prime? 4611686020243253219))
+      (test #t (probable-prime? 4611686020243253257))
+      (test #f (probable-prime? 4611686020243253181))
+      (test #f (probable-prime? 4611686020243253183))
+      (test #f (probable-prime? 4611686020243253247))
+
+      (test 5
+          (modular-expt 7670626353261554806
+                        5772301760555853353
+                        (* 2936546443 3213384203)))
+
+      (test-end))))

lib/chibi/memoize-test.sld

@@ -0,0 +1,51 @@
+(define-library (chibi memoize-test)
+  (export run-tests)
+  (import (chibi) (chibi memoize) (chibi filesystem) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "memoize")
+
+      (define-memoized (fib n)
+        (if (<= n 1)
+            1
+            (+ (fib (- n 1)) (fib (- n 2)))))
+
+      (test 1 (fib 1))
+      (test 573147844013817084101 (fib 100))
+
+      (define-memoized (ack m n)
+        (cond
+         ((= m 0) (+ n 1))
+         ((= n 0) (ack (- m 1) 1))
+         (else (ack (- m 1) (ack m (- n 1))))))
+
+      (test 29 (ack 3 2))
+      (test 61 (ack 3 3))
+
+      (let ((n 0))
+        (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x)))))
+          (test 0 n)
+          (test 9 (f 3))
+          (test 1 n)
+          (test 9 (f 3))
+          (test 1 n)))
+
+      (let ((n 0))
+        (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x))
+                          'size-limit: #f)))
+          (test 0 n)
+          (test 9 (f 3))
+          (test 1 n)
+          (test 9 (f 3))
+          (test 1 n)))
+
+      (letrec ((fib (lambda (n)
+                      (if (<= n 1)
+                          1
+                          (+ (fib (- n 1)) (fib (- n 2)))))))
+        (let ((f (memoize-to-file fib 'memo-dir: "/tmp/memo.d/")))
+          (test 89 (f 10))
+          (test-assert (file-exists? "/tmp/memo.d/10.memo"))
+          (test 89 (f 10))))
+
+      (test-end))))

lib/chibi/mime-test.sld

@@ -0,0 +1,149 @@
+(define-library (chibi mime-test)
+  (export run-tests)
+  (import (chibi) (chibi mime) (chibi test)
+          (only (scheme base) string->utf8 open-input-bytevector))
+  (begin
+    (define (run-tests)
+      (test-begin "mime")
+
+      (test '(text/html (charset . "UTF-8") (filename . "index.html"))
+          (mime-parse-content-type
+           "text/html; CHARSET=UTF-8; filename=index.html"))
+
+      (test '(multipart/form-data (boundary . "AaB03x"))
+          (mime-parse-content-type "multipart/form-data, boundary=AaB03x"))
+
+      (test '(mime (@ (from . "\"Dr. Watson <guest@grimpen.moor>\"")
+                      (to . "\"Sherlock Homes <not-really@221B-baker.street>\"")
+                      (subject . "\"First Report\"")
+                      (content-type . "text/plain; charset=\"ISO-8859-1\""))
+                   "Moor is gloomy. Heard strange noise, attached.\n")
+          (call-with-input-string
+              "From:    \"Dr. Watson <guest@grimpen.moor>\"
+To:      \"Sherlock Homes <not-really@221B-baker.street>\"
+Subject: \"First Report\"
+Content-Type: text/plain; charset=\"ISO-8859-1\"
+
+Moor is gloomy. Heard strange noise, attached.
+
+"
+            mime-message->sxml))
+
+      ;; from rfc 1867
+
+      (test '(mime
+              (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+              (mime (@ (content-disposition . "form-data; name=\"field1\""))
+                    "Joe Blow")
+              (mime (@ (content-disposition
+                        . "form-data; name=\"pics\"; filename=\"file1.txt\"")
+                       (content-type . "text/plain"))
+                    " ... contents of file1.txt ..."))
+          (call-with-input-string
+              "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"; filename=\"file1.txt\"
+Content-Type: text/plain
+
+ ... contents of file1.txt ...
+--AaB03x--
+"
+            mime-message->sxml))
+
+      (test '(mime
+              (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+              (mime (@ (content-disposition . "form-data; name=\"field1\""))
+                    "Joe Blow")
+              (mime (@ (content-disposition . "form-data; name=\"pics\"")
+                       (content-type . "multipart/mixed, boundary=BbC04y"))
+                    (mime (@ (content-disposition
+                              . "attachment; filename=\"file1.txt\"")
+                             (content-type . "text/plain"))
+                          "... contents of file1.txt ...")
+                    (mime (@ (content-disposition
+                              . "attachment; filename=\"file2.gif\"")
+                             (content-type . "image/gif")
+                             (content-transfer-encoding . "binary"))
+                          #u8(32 32 46 46 46 99 111 110 116 101 110
+                                 116 115 32 111 102 32 102 105 108 101
+                                 50 46 103 105 102 46 46 46))))
+          (call-with-input-string
+              "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"
+Content-type: multipart/mixed, boundary=BbC04y
+
+--BbC04y
+Content-disposition: attachment; filename=\"file1.txt\"
+Content-Type: text/plain
+
+... contents of file1.txt ...
+--BbC04y
+Content-disposition: attachment; filename=\"file2.gif\"
+Content-type: image/gif
+Content-Transfer-Encoding: binary
+
+  ...contents of file2.gif...
+--BbC04y--
+--AaB03x--
+"
+            mime-message->sxml))
+
+      (test '(mime
+              (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+              (mime (@ (content-disposition . "form-data; name=\"field1\"")
+                       (content-type . "text/plain"))
+                    "Joe Blow")
+              (mime (@ (content-disposition . "form-data; name=\"pics\"")
+                       (content-type . "multipart/mixed, boundary=BbC04y"))
+                    (mime (@ (content-disposition
+                              . "attachment; filename=\"file1.txt\"")
+                             (content-type . "text/plain"))
+                          "... contents of file1.txt ...")
+                    (mime (@ (content-disposition
+                              . "attachment; filename=\"file2.gif\"")
+                             (content-type . "image/gif")
+                             (content-transfer-encoding . "binary"))
+                          #u8(32 32 46 46 46 99 111 110 116 101 110
+                                 116 115 32 111 102 32 102 105 108 101
+                                 50 46 103 105 102 46 46 46))))
+          (mime-message->sxml
+           (open-input-bytevector
+            (string->utf8
+             "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+Content-Type: text/plain
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"
+Content-type: multipart/mixed, boundary=BbC04y
+
+--BbC04y
+Content-disposition: attachment; filename=\"file1.txt\"
+Content-Type: text/plain
+
+... contents of file1.txt ...
+--BbC04y
+Content-disposition: attachment; filename=\"file2.gif\"
+Content-type: image/gif
+Content-Transfer-Encoding: binary
+
+  ...contents of file2.gif...
+--BbC04y--
+--AaB03x--
+"))))
+
+      (test-end))))

lib/chibi/parse-test.sld

@@ -0,0 +1,140 @@
+(define-library (chibi parse-test)
+  (export run-tests)
+  (import (chibi) (chibi test)
+          (chibi char-set) (chibi char-set ascii)
+          (chibi parse) (chibi parse common))
+  (begin
+    (define (run-tests)
+      (test-begin "parse")
+
+      ;; basic
+
+      (test-assert (parse parse-epsilon ""))
+      (test-assert (parse-fully parse-epsilon ""))
+      (test-error (parse-fully parse-epsilon "a"))
+
+      (test-not (parse parse-anything ""))
+      (test-assert (parse-fully parse-anything "a"))
+      (test-error (parse-fully parse-anything "ab"))
+
+      (test-not (parse parse-nothing ""))
+      (test-not (parse parse-nothing "a"))
+
+      (test-not (parse (parse-char #\a) ""))
+      (test-assert (parse-fully (parse-char #\a) "a"))
+      (test-not (parse (parse-char #\a) "b"))
+      (test-error (parse-fully (parse-char #\a) "ab"))
+
+      (let ((f (parse-seq (parse-char #\a) (parse-char #\b))))
+        (test-not (parse f "a"))
+        (test-not (parse f "b"))
+        (test-assert (parse f "ab"))
+        (test-error (parse-fully f "abc")))
+
+      (let ((f (parse-or (parse-char #\a) (parse-char #\b))))
+        (test-not (parse f ""))
+        (test-assert (parse f "a"))
+        (test-assert (parse f "b"))
+        (test-error (parse-fully f "ab")))
+
+      (let ((f (parse-not (parse-char #\a))))
+        (test-assert (parse f ""))
+        (test-error (parse-fully f "a"))
+        (test-assert (parse f "b")))
+
+      (let ((f (parse-repeat (parse-char #\a))))
+        (test-assert (parse-fully f ""))
+        (test-assert (parse-fully f "a"))
+        (test-assert (parse-fully f "aa"))
+        (test-assert (parse-fully f "aaa"))
+        (test-assert (parse f "b"))
+        (test-assert (parse f "aab"))
+        (test-error (parse-fully f "aab")))
+
+      ;; grammars
+
+      (let ()
+        (define-grammar calc
+          (space ((* ,char-set:whitespace)))
+          (number ((=> n (+ ,char-set:digit))
+                   (string->number (list->string n))))
+          (simple ((=> n ,number) n)
+                  ((: "(" (=> e1 ,term) ")") e1))
+          (term-op ("*" *)
+                   ("/" /)
+                   ("%" modulo))
+          (term ((: (=> e1 ,simple) ,space (=> op ,term-op)
+                    ,space (=> e2 ,term))
+                 (op e1 e2))
+                ((=> e1 ,simple)
+                 e1)))
+        (test 88 (parse term "4*22"))
+        (test 42 (parse term "42"))
+        ;; partial match (grammar isn't checking end)
+        (test 42 (parse term "42*")))
+
+      (define calculator
+        (grammar expr
+          (space ((: ,char-set:whitespace ,space))
+                 (() #f))
+          (digit ((=> d ,char-set:digit) d))
+          (number ((=> n (+ ,digit))
+                   (string->number (list->string n))))
+          (simple ((=> n ,number) n)
+                  ((: "(" (=> e1 ,expr) ")") e1))
+          (term-op ("*" *)
+                   ("/" /)
+                   ("%" modulo))
+          (term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
+                 (op e1 e2))
+                ((=> e1 ,simple)
+                 e1))
+          (expr-op ("+" +) ("-" -))
+          (expr ((: ,space (=> e1 ,term) ,space (=> op ,expr-op) ,space (=> e2 ,expr))
+                 (op e1 e2))
+                ((: ,space (=> e1 ,term))
+                 e1))))
+
+      (test 42 (parse calculator "42"))
+      (test 4 (parse calculator "2 + 2"))
+      (test 23 (parse calculator "2 + 2*10 + 1"))
+      (test 25 (parse calculator "2+2 * 10+1 * 3"))
+      (test 41 (parse calculator "(2 + 2) * 10 + 1"))
+
+      (define prec-calc
+        (grammar expr
+          (simple (,(parse-integer))
+                  ((: "(" (=> e1 ,expr) ")") e1))
+          (op
+           ("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
+          (expr
+           (,(parse-binary-op op
+                              `((+ 5) (- 5) (* 3) (/ 3) (^ 1 right))
+                              simple)))))
+
+      (test 42 (parse prec-calc "42"))
+      (test '(+ 2 2) (parse prec-calc "2 + 2"))
+      (test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
+      (test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
+      (test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
+      (test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
+      (test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
+      (test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
+          (parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9"))
+
+      ;; this takes exponential time without memoization
+      (define explode
+        (grammar start
+                 (start ((: ,S eos) #t))
+                 (S ((+ ,A) #t))
+                 (A ((: "a" ,S "b") #t)
+                    ((: "a" ,S "c") #t)
+                    ((: "a") #t))))
+
+      (test-assert (parse explode "aaabb"))
+      (test-not (parse explode "bbaa"))
+      (test-assert
+          (parse explode
+                 (string-append (make-string 10 #\a) (make-string 8 #\c))))
+
+      (test-end))))

lib/chibi/pathname-test.sld

@@ -0,0 +1,206 @@
+(define-library (chibi pathname-test)
+  (export run-tests)
+  (import (chibi) (chibi pathname) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "pathname")
+
+      ;; tests from the dirname(3) manpage
+
+      (test "dirname(3)" "/usr" (path-directory "/usr/lib"))
+      (test "lib"  (path-strip-directory "/usr/lib"))
+
+      (test "/"    (path-directory "/usr/"))
+      (test ""     (path-strip-directory "/usr/"))
+
+      (test "."    (path-directory "usr"))
+      (test "usr"  (path-strip-directory "usr"))
+
+      (test "/"    (path-directory "/"))
+      (test ""     (path-strip-directory "/"))
+
+      (test "."    (path-directory "."))
+      (test "."    (path-strip-directory "."))
+
+      (test "."    (path-directory ".."))
+      (test ".."   (path-strip-directory ".."))
+
+      ;; additional tests (should match GNU dirname/basename behavior)
+
+      (test "path-directory:border"
+          "/"    (path-directory "//"))
+      (test ""     (path-strip-directory "//"))
+
+      (test "."    (path-directory ""))
+      (test ""     (path-strip-directory ""))
+
+      (test "."    (path-directory "../"))
+      (test ""     (path-strip-directory "../"))
+
+      (test ".."   (path-directory "../.."))
+      (test ".."   (path-strip-directory "../.."))
+
+      (test "path-directory:extra"
+          "/usr/local" (path-directory "/usr/local/lib"))
+      (test "lib" (path-strip-directory "/usr/local/lib"))
+
+      (test "/usr" (path-directory "/usr/local/"))
+      (test "" (path-strip-directory "/usr/local/"))
+
+      (test "usr"    (path-directory "usr/local"))
+      (test "local"  (path-strip-directory "usr/local"))
+
+      (test "/" (path-directory "//usr"))
+      (test "usr" (path-strip-directory "//usr"))
+
+      (test "/" (path-directory "//usr/"))
+      (test "" (path-strip-directory "//usr/"))
+
+      (test "path-directory:small"
+          "/a" (path-directory "/a/b"))
+      (test "b" (path-strip-directory "/a/b"))
+
+      (test "a" (path-directory "a/b"))
+      (test "b" (path-strip-directory "a/b"))
+
+      (test "a" (path-directory "a/b/"))
+      (test "" (path-strip-directory "a/b/"))
+
+      (test "/a/b/c" (path-directory "/a/b/c/d"))
+      (test "d" (path-strip-directory "/a/b/c/d"))
+
+      (test "/a/b/c" (path-directory "/a/b/c/d/"))
+      (test "" (path-strip-directory "/a/b/c/d/"))
+
+      (test "a/b/c"    (path-directory "a/b/c/d"))
+      (test "d"  (path-strip-directory "a/b/c/d"))
+
+      (test "/a/b" (path-directory "/a/b/c.d"))
+      (test "c.d" (path-strip-directory "/a/b/c.d"))
+
+      (test "/a/b" (path-directory "/a/b/c.d/"))
+      (test "" (path-strip-directory "/a/b/c.d/"))
+
+      (test "/a/b/c" (path-directory "/a/b/c/."))
+      (test "." (path-strip-directory "/a/b/c/."))
+
+      (test "/a/b/c" (path-directory "/a/b/c/.."))
+      (test ".." (path-strip-directory "/a/b/c/.."))
+
+      (test "/a/b/." (path-directory "/a/b/./c"))
+      (test "c" (path-strip-directory "/a/b/./c"))
+
+      (test "/a/b/.." (path-directory "/a/b/../c"))
+      (test "c" (path-strip-directory "/a/b/../c"))
+
+      (test "/a/b" (path-directory "/a/b/c//"))
+      (test "" (path-strip-directory "/a/b/c//"))
+
+      (test "/a/b" (path-directory "/a/b//c///"))
+      (test "" (path-strip-directory "/a/b//c///"))
+
+      ;; extensions
+
+      (test "path-extension" "scm" (path-extension "foo.scm"))
+      (test "foo" (path-strip-extension "foo.scm"))
+
+      (test "c" (path-extension "foo.scm.c"))
+      (test "foo.scm" (path-strip-extension "foo.scm.c"))
+
+      (test "scm" (path-extension "/home/me/foo.scm"))
+      (test "/home/me/foo" (path-strip-extension "/home/me/foo.scm"))
+
+      (test "scm" (path-extension "foo..scm"))
+      (test "foo." (path-strip-extension "foo..scm"))
+
+      (test "s" (path-extension "foo.s"))
+      (test "foo" (path-strip-extension "foo.s"))
+
+      (test #f (path-extension "foo."))
+      (test "foo." (path-strip-extension "foo."))
+
+      (test #f (path-extension "foo.scm."))
+      (test "foo.scm." (path-strip-extension "foo.scm."))
+
+      (test #f (path-extension "."))
+      (test "." (path-strip-extension "."))
+
+      (test #f (path-extension "a."))
+      (test "a." (path-strip-extension "a."))
+
+      (test #f (path-extension "/."))
+      (test "/." (path-strip-extension "/."))
+
+      (test #f (path-extension "foo.scm/"))
+      (test "foo.scm/" (path-strip-extension "foo.scm/"))
+
+      (test "path-replace-extension"
+          "foo.c" (path-replace-extension "foo.scm" "c"))
+      (test "foo.c" (path-replace-extension "foo" "c"))
+
+      ;; absolute paths
+
+      (test-assert (path-absolute? "/"))
+      (test-assert (path-absolute? "//"))
+      (test-assert (path-absolute? "/usr"))
+      (test-assert (path-absolute? "/usr/"))
+      (test-assert (path-absolute? "/usr/."))
+      (test-assert (path-absolute? "/usr/.."))
+      (test-assert (path-absolute? "/usr/./"))
+      (test-assert (path-absolute? "/usr/../"))
+
+      (test-assert (not (path-absolute? "")))
+      (test-assert (not (path-absolute? ".")))
+      (test-assert (not (path-absolute? "usr")))
+      (test-assert (not (path-absolute? "usr/")))
+
+      ;; normalization & building
+
+      (test "path-normalize" "/a/b/c/d/e" (path-normalize "/a/b/c/d/./e"))
+      (test "/a/b/c/d/e" (path-normalize "/a/b//.///c//d/./e"))
+      (test "/a/b/c/d/e/" (path-normalize "/a/b//.///c//d/./e/"))
+      (test "/a/c/d/e" (path-normalize "/a/b/../c/d/e"))
+      (test "/a/b/c/e" (path-normalize "/a/b//.///c//d/../e"))
+      (test "/a/c/e" (path-normalize "/a/b//..///c//d/../e"))
+      (test "/a/b/c/d/e/"
+          (path-normalize "/a/b//./../c/d/../../b//c/d/e/f/.."))
+      (test "/a/b/c/" (path-normalize "/a/b/c/."))
+
+      (test "path-normalize:border" "" (path-normalize ""))
+      (test "." (path-normalize "."))
+      (test "/" (path-normalize "/"))
+      (test "/" (path-normalize "/."))
+
+      (test "path-normalize:overflow"
+          "/" (path-normalize "/a/b/c/../../../../.."))
+      (test "../.." (path-normalize "a/b/c/../../../../.."))
+      (test "../../.." (path-normalize "../a/b/c/../../../../.."))
+
+      (test "" (path-strip-leading-parents ".."))
+      (test "" (path-strip-leading-parents "../"))
+      (test "a" (path-strip-leading-parents "../a"))
+      (test "a/b" (path-strip-leading-parents "../../a/b"))
+      (test "a/b" (path-strip-leading-parents "../../../a/b"))
+      (test "a/../b" (path-strip-leading-parents "../../../a/../b"))
+
+      (test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b"))
+      (test "c" (path-relative-to "/a/b/c" "/a/b/"))
+      (test "." (path-relative-to "/a/b/" "/a/b/"))
+      (test "." (path-relative-to "/a/b/" "/a/b"))
+      (test "." (path-relative-to "/a/b" "/a/b/"))
+      (test "." (path-relative-to "/a/b" "/a/b"))
+      (test-not (path-relative-to "/d/a/b/c" "/a/b"))
+
+      (test "make-path" "a/b" (make-path "a" "b"))
+      (test "a/b" (make-path "a/" "b"))
+      (test "a/b/./c" (make-path "a" "b" "." "c"))
+      (test "a/b/../c" (make-path "a" "b" ".." "c"))
+      (test "a/b/c" (make-path "a" '("b" "c")))
+      (test "/" (make-path "/" ""))
+      (test "/" (make-path "/" "/"))
+      (test "/." (make-path "/" "."))
+      (test "/a" (make-path "/a" ""))
+      (test "/a" (make-path "/a" "/"))
+      (test "/a/." (make-path "/a" "."))
+
+      (test-end))))

lib/chibi/process-test.sld

@@ -0,0 +1,25 @@
+(define-library (chibi process-test)
+  (export run-tests)
+  (import (chibi) (chibi process) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "processes")
+      (test #t (process-running? (current-process-id)))
+      (test #t (process-running? (parent-process-id)))
+      (test #f (signal-set-contains? (current-signal-mask) signal/alarm))
+      (test #t (signal-set? (make-signal-set)))
+      (test #t (signal-set? (current-signal-mask)))
+      (test #f (signal-set? #f))
+      (test #f (signal-set? '(#f)))
+      (test #f (signal-set-contains? (make-signal-set) signal/interrupt))
+      (test #t (let ((sset (make-signal-set)))
+                 (signal-set-fill! sset)
+                 (signal-set-contains? sset signal/interrupt)))
+      (test #t (let ((sset (make-signal-set)))
+                 (signal-set-add! sset signal/interrupt)
+                 (signal-set-contains? sset signal/interrupt)))
+      (test #f (let ((sset (make-signal-set)))
+                 (signal-set-fill! sset)
+                 (signal-set-delete! sset signal/interrupt)
+                 (signal-set-contains? sset signal/interrupt)))
+      (test-end))))

lib/chibi/regexp-test.sld

@@ -0,0 +1,284 @@
+(define-library (chibi regexp-test)
+  (export run-tests)
+  (import (chibi) (chibi regexp) (chibi regexp pcre)
+          (chibi string) (chibi io) (chibi match) (chibi test))
+  (begin
+    (define (run-tests)
+      (define (maybe-match->sexp rx str . o)
+        (let ((res (apply regexp-matches rx str o)))
+          (and res (regexp-match->sexp res))))
+
+      (define-syntax test-re
+        (syntax-rules ()
+          ((test-re res rx str start end)
+           (test res (maybe-match->sexp rx str start end)))
+          ((test-re res rx str start)
+           (test-re res rx str start (string-length str)))
+          ((test-re res rx str)
+           (test-re res rx str 0))))
+
+      (define (maybe-search->sexp rx str . o)
+        (let ((res (apply regexp-search rx str o)))
+          (and res (regexp-match->sexp res))))
+
+      (define-syntax test-re-search
+        (syntax-rules ()
+          ((test-re-search res rx str start end)
+           (test res (maybe-search->sexp rx str start end)))
+          ((test-re-search res rx str start)
+           (test-re-search res rx str start (string-length str)))
+          ((test-re-search res rx str)
+           (test-re-search res rx str 0))))
+
+      (test-begin "regexp")
+
+      (test-re '("ababc" "abab")
+               '(: ($ (* "ab")) "c")
+               "ababc")
+
+      (test-re '("ababc" "abab")
+               '(: ($ (* "ab")) "c")
+               "xababc"
+               1)
+
+      (test-re-search '("y") '(: "y") "xy")
+
+      (test-re-search '("ababc" "abab")
+                      '(: ($ (* "ab")) "c")
+                      "xababc")
+
+      (test-re #f
+               '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
+               "fooxbafba")
+
+      (test-re '("fooxbarfbar" "fooxbarf" "bar")
+               '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
+               "fooxbarfbar")
+
+      (test-re '("abcd" "abcd")
+               '($ (* (or "ab" "cd")))
+               "abcd")
+
+      ;; first match is a list of ab's, second match is the last (temporary) cd
+      (test-re '("abcdc" (("ab") ("cd")) "cd")
+               '(: (* (*$ (or "ab" "cd"))) "c")
+               "abcdc")
+
+      (test "ab"
+          (regexp-match-submatch
+           (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "ab")
+           'foo))
+
+      (test "cd"
+          (regexp-match-submatch
+           (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "cd")
+           'foo))
+
+      ;; non-deterministic case from issue #229
+      (let* ((elapsed '(: (** 1 2 num) ":" num num (? ":" num num)))
+             (span (rx ,elapsed "-" ,elapsed)))
+        (test-re-search '("1:45:02-2:06:13") span " 1:45:02-2:06:13 "))
+
+      (test-re '("ababc" "abab")
+               '(: bos ($ (* "ab")) "c")
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: ($ (* "ab")) "c" eos)
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: bos ($ (* "ab")) "c" eos)
+               "ababc")
+      (test-re #f
+               '(: bos ($ (* "ab")) eos "c")
+               "ababc")
+      (test-re #f
+               '(: ($ (* "ab")) bos "c" eos)
+               "ababc")
+
+      (test-re '("ababc" "abab")
+               '(: bol ($ (* "ab")) "c")
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: ($ (* "ab")) "c" eol)
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: bol ($ (* "ab")) "c" eol)
+               "ababc")
+      (test-re #f
+               '(: bol ($ (* "ab")) eol "c")
+               "ababc")
+      (test-re #f
+               '(: ($ (* "ab")) bol "c" eol)
+               "ababc")
+      (test-re '("\nabc\n" "abc")
+               '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+               "\nabc\n")
+      (test-re #f
+               '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+               "\n'abc\n")
+      (test-re #f
+               '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+               "\nabc.\n")
+
+      (test-re '("ababc" "abab")
+               '(: bow ($ (* "ab")) "c")
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: ($ (* "ab")) "c" eow)
+               "ababc")
+      (test-re '("ababc" "abab")
+               '(: bow ($ (* "ab")) "c" eow)
+               "ababc")
+      (test-re #f
+               '(: bow ($ (* "ab")) eow "c")
+               "ababc")
+      (test-re #f
+               '(: ($ (* "ab")) bow "c" eow)
+               "ababc")
+      (test-re '("  abc  " "abc")
+               '(: (* space) bow ($ (* alpha)) eow (* space))
+               "  abc  ")
+      (test-re #f
+               '(: (* space) bow ($ (* alpha)) eow (* space))
+               " 'abc  ")
+      (test-re #f
+               '(: (* space) bow ($ (* alpha)) eow (* space))
+               " abc.  ")
+      (test-re-search '("foo") '(: "foo") " foo ")
+      (test-re-search #f '(: nwb "foo" nwb) " foo ")
+      (test-re-search '("foo") '(: nwb "foo" nwb) "xfoox")
+
+      (test-re '("beef")
+               '(* (/"af"))
+               "beef")
+
+      (test-re '("12345beef" "beef")
+               '(: (* digit) ($ (* (/"af"))))
+               "12345beef")
+
+      (let ((number '($ (+ digit))))
+        (test '("555" "867" "5309")
+            (cdr
+             (regexp-match->list
+              (regexp-search `(: ,number "-" ,number "-" ,number)
+                             "555-867-5309"))))
+        (test '("555" "5309")
+            (cdr
+             (regexp-match->list
+              (regexp-search `(: ,number "-" (w/nocapture ,number) "-" ,number)
+                             "555-867-5309")))))
+
+      (test-re '("12345BeeF" "BeeF")
+               '(: (* digit) (w/nocase ($ (* (/"af")))))
+               "12345BeeF")
+
+      (test-re #f '(* lower) "abcD")
+      (test-re '("abcD") '(w/nocase (* lower)) "abcD")
+      (test-re '("σζ") '(* lower) "σζ")
+      (test-re '("Σ") '(* upper) "Σ")
+      (test-re '("\x01C5;") '(* title) "\x01C5;")
+      (test-re '("σζ\x01C5;") '(w/nocase (* lower)) "σζ\x01C5;")
+
+      (test-re '("кириллица") '(* alpha) "кириллица")
+      (test-re #f '(w/ascii (* alpha)) "кириллица")
+      (test-re '("кириллица") '(w/nocase "КИРИЛЛИЦА") "кириллица")
+
+      (test-re '("１２３４５") '(* digit) "１２３４５")
+      (test-re #f '(w/ascii (* digit)) "１２３４５")
+
+      (test-re '("한") 'grapheme "한")
+      (test-re '("글") 'grapheme "글")
+
+      (test-re '("한") '(: bog grapheme eog) "한")
+      (test-re #f '(: "ᄒ" bog grapheme eog "ᆫ") "한")
+
+      (test '("123" "456" "789") (regexp-extract '(+ digit) "abc123def456ghi789"))
+      (test '("123" "456" "789") (regexp-extract '(* digit) "abc123def456ghi789"))
+      (test '("abc" "def" "ghi") (regexp-split '(+ digit) "abc123def456ghi789"))
+      (test '("a" "b" "c" "d" "e" "f" "g" "h" "i")
+          (regexp-split '(* digit) "abc123def456ghi789"))
+      (test '("a" "b") (regexp-split '(+ whitespace) "a b"))
+      (test '("한" "글")
+          (regexp-extract
+           'grapheme
+           (utf8->string '#u8(#xe1 #x84 #x92 #xe1 #x85 #xa1 #xe1 #x86 #xab
+                                   #xe1 #x84 #x80 #xe1 #x85 #xb3 #xe1 #x86 #xaf))))
+
+      (test "abc def" (regexp-replace '(+ space) "abc \t\n def" " "))
+      (test "  abc-abc"
+          (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" 1)))
+      (test "  abc-  abc"
+          (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" pre 1)))
+
+      (test "-abc \t\n d ef  "
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0))
+      (test "-abc \t\n d ef  "
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 0))
+      (test "  abc-d ef  "
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 1))
+      (test "  abc \t\n d-ef  "
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 2))
+      (test "  abc \t\n d ef-"
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 3))
+      (test "  abc \t\n d ef  "
+          (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 4))
+      (test " abc d ef " (regexp-replace-all '(+ space) "  abc \t\n d ef  " " "))
+
+      (define (subst-matches matches input subst)
+        (define (submatch n)
+          (regexp-match-submatch matches n))
+        (and
+         matches
+         (call-with-output-string
+           (lambda (out)
+             (call-with-input-string subst
+               (lambda (in)
+                 (let lp ()
+                   (let ((c (read-char in)))
+                     (cond
+                      ((not (eof-object? c))
+                       (case c
+                         ((#\&)
+                          (display (or (submatch 0) "") out))
+                         ((#\\)
+                          (let ((c (read-char in)))
+                            (if (char-numeric? c)
+                                (let lp ((res (list c)))
+                                  (if (and (char? (peek-char in))
+                                           (char-numeric? (peek-char in)))
+                                      (lp (cons (read-char in) res))
+                                      (display
+                                       (or (submatch (string->number
+                                                      (list->string (reverse res))))
+                                           "")
+                                       out)))
+                                (write-char c out))))
+                         (else
+                          (write-char c out)))
+                       (lp)))))))))))
+
+      (define (test-pcre line)
+        (match (string-split line #\tab)
+          ((pattern input result subst output)
+           (let ((name (string-append pattern " " input " " result " " subst)))
+             (cond
+              ((equal? "c" result)
+               (test-error name (regexp-search (pcre->sre pattern) input)))
+              ((equal? "n" result)
+               (test-assert name (not (regexp-search (pcre->sre pattern) input))))
+              (else
+               (test name output
+                 (subst-matches (regexp-search (pcre->sre pattern) input)
+                                input
+                                subst))))))
+          (else
+           (error "invalid regex test line" line))))
+
+      (test-group "pcre"
+        (call-with-input-file "tests/re-tests.txt"
+          (lambda (in)
+            (for-each
+             (lambda (line) (test-pcre line))
+             (port->list read-line in)))))
+
+      (test-end))))

lib/chibi/scribble-test.sld

@@ -0,0 +1,209 @@
+(define-library (chibi scribble-test)
+  (export run-tests)
+  (import (chibi) (chibi scribble) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+
+      (test-begin "scribble")
+
+      (define (test-scribble expect str)
+        (test (call-with-output-string (lambda (out) (write str out)))
+            expect
+          (call-with-input-string str scribble-parse)))
+
+      (test-scribble '((foo "blah blah blah")) "\\foo{blah blah blah}")
+      (test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
+      (test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
+      (test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
+      (test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
+      (test-scribble '((foo "blah blah" "\n" "     yada yada")) "\\foo{blah blah
+     yada yada}")
+      (test-scribble '((foo "  blah blah" "\n" "  yada yada" "\n")) "\\foo{
+  blah blah
+  yada yada
+}")
+
+      (test-scribble '((foo "bar " (baz "3") "\n" "     blah")) "\\foo{bar \\baz{3}
+     blah}")
+      (test-scribble '((foo (b (u 3) " " (u "4")) "\n" "     blah")) "\\foo{\\b{\\u[3] \\u{4}}
+     blah}")
+      (test-scribble '((C "while (*(p++))" "\n" "     *p = '\\n';")) "\\C{while (*(p++))
+     *p = '\\\"\\\\\"n';}")
+      (test-scribble '(("blah blah")) "\\{blah blah}")
+      (test-scribble '(("blah " (3))) "\\{blah \\[3]}")
+      (test-scribble '(("foo" "\n" "   bar" "\n" "   baz")) "\\{foo
+   bar
+   baz}")
+      (test-scribble '(foo) "\\foo")
+      (test-scribble '(("blah " foo " blah")) "\\{blah \\foo blah}")
+      (test-scribble '(("blah " foo: " blah")) "\\{blah \\foo: blah}")
+      (test-scribble '(("blah " foo ": blah")) "\\{blah \\|foo|: blah}")
+      (test-scribble '((foo "(+ 1 2) -> " (+ 1 2) "!")) "\\foo{(+ 1 2) -> \\(+ 1 2)!}")
+      (test-scribble '((foo "A string escape")) "\\foo{A \\\"string\" escape}")
+      (test-scribble '((foo "eli@barzilay.org")) "\\foo{eli@barzilay.org}")
+      (test-scribble '((foo "eli\\barzilay.org")) "\\foo{eli\\\"\\\\\"barzilay.org}")
+      (test-scribble '((foo "A { begins a block")) "\\foo{A \\\"{\" begins a block}")
+      (test-scribble '((C "while (*(p++)) {" "\n" "     *p = '\\n';" "\n" "   }"))
+                     "\\C{while (*(p++)) {
+     *p = '\\\"\\\\\"n';
+   }}")
+      (test-scribble '((foo "bar}\\{baz")) "\\foo|{bar}\\{baz}|")
+      (test-scribble '((foo "bar " (x "X") " baz")) "\\foo|{bar |\\x{X} baz}|")
+      (test-scribble '((foo "bar " (x "\\") " baz")) "\\foo|{bar |\\x|{\\}| baz}|")
+
+      (test-scribble '((foo "bar}\\|{baz")) "\\foo|--{bar}\\|{baz}--|")
+      (test-scribble '((foo "bar}\\|{baz")) "\\foo|<<{bar}\\|{baz}>>|")
+
+      (test-scribble '((foo "bar " (baz 2 3) " {4 5}")) "\\foo{bar \\baz[2 3] {4 5}}")
+
+      (test-scribble '(`',@(foo "blah")) "\\`',@foo{blah}")
+      ;;(test-scribble '(#`#'#,@(foo "blah")) "\\#`#'#,@foo{blah}")
+      (test-scribble '(((lambda (x) x) "blah")) "\\(lambda (x) x){blah}")
+      (test-scribble '(`(,foo  "blah")) "\\`(unquote foo){blah}")
+
+      (test-scribble '(("foo bar" "\n" "  baz")) "\\{foo bar
+  baz}")
+      (test-scribble '('("foo bar" "\n" "       baz")) "\\'{foo bar
+       baz}")
+      (test-scribble '((foo "bar      baz     blah")) "\\foo{bar \\; comment
+     baz\\;
+     blah}")
+
+      (test-scribble '((foo "x " y " z")) "\\foo{x \\y z}")
+      (test-scribble '((foo "x " (* y 2) " z")) "\\foo{x \\(* y 2) z}")
+      (test-scribble '((foo " bar")) "\\{\\foo bar}")
+      (test-scribble '(((foo "bar") "baz")) "\\\\foo{bar}{baz}")
+
+      (test-scribble '((foo 1 (* 2 3) "bar")) "\\foo[1 (* 2 3)]{bar}")
+      (test-scribble '((foo (bar "...") "blah")) "\\foo[\\bar{...}]{blah}")
+      (test-scribble '((foo bar)) "\\foo[bar]")
+      (test-scribble '((foo "bar " (f x) " baz")) "\\foo{bar \\f[x] baz}")
+      (test-scribble '((foo "bar")) "\\foo[]{bar}")
+      (test-scribble '((foo)) "\\foo[]")
+      (test-scribble '(foo) "\\foo")
+      (test-scribble '((foo)) "\\foo{}")
+
+      (test-scribble '((foo 'style: 'big  "bar")) "\\foo['style: 'big]{bar}")
+
+      (test-scribble '((foo "f{o}o")) "\\foo{f{o}o}")
+      (test-scribble '((foo "{{}}{}")) "\\foo{{{}}{}}")
+      (test-scribble '((foo "bar")) "\\foo{bar}")
+      (test-scribble '((foo " bar ")) "\\foo{ bar }")
+      (test-scribble '((foo 1 " bar ")) "\\foo[1]{ bar }")
+
+      (test-scribble '((foo "a " (bar "b") " c")) "\\foo{a \\bar{b} c}")
+      (test-scribble '((foo "a " bar " c")) "\\foo{a \\bar c}")
+      (test-scribble '((foo "a " (bar 2) " c")) "\\foo{a \\(bar 2) c}")
+      (test-scribble '((foo "A } marks the end")) "\\foo{A \\\"}\" marks the end}")
+      (test-scribble '((foo "The prefix: @.")) "\\foo{The prefix: \\\"@\".}")
+      (test-scribble '((foo "The prefix: \\.")) "\\foo{The prefix: \\\"\\\\\".}")
+      (test-scribble '((foo "\\x{y} --> (x \"y\")")) "\\foo{\\\"\\\\x{y}\" --> (x \"y\")}")
+
+      (test-scribble '((foo "...")) "\\foo|{...}|")
+      (test-scribble '((foo "\"}\" follows \"{\"")) "\\foo|{\"}\" follows \"{\"}|")
+      (test-scribble '((foo "Nesting |{is}| ok")) "\\foo|{Nesting |{is}| ok}|")
+
+      (test-scribble '((foo "Maze" "\n" "      " (bar "is") "\n" "      Life!"))
+                     "\\foo|{Maze
+      |\\bar{is}
+      Life!}|")
+      (test-scribble '((t "In " (i "sub\\s") " too")) "\\t|{In |\\i|{sub|\\\"\\\\\"s}| too}|")
+      (test-scribble '((foo "\\x{foo} |\\{bar}|.")) "\\foo|<<<{\\x{foo} |\\{bar}|.}>>>|")
+      (test-scribble '((foo "X " (b "Y") "...")) "\\foo|!!{X |!!\\b{Y}...}!!|")
+
+      (test-scribble '((foo "foo" bar.)) "\\foo{foo\\bar.}")
+      (test-scribble '((foo "foo" bar ".")) "\\foo{foo\\|bar|.}")
+      (test-scribble '((foo "foo" 3.0)) "\\foo{foo\\3.}")
+      (test-scribble '((foo "foo" 3 ".")) "\\foo{foo\\|3|.}")
+      (test-scribble '((foo "foo" (f 1) "{bar}")) "\\foo{foo\\|(f 1)|{bar}}")
+      (test-scribble '((foo "foo" bar "[1]{baz}")) "\\foo{foo\\|bar|[1]{baz}}")
+      (test-scribble '((foo "xyz")) "\\foo{x\\\"y\"z}")
+      (test-scribble '((foo "x" "y" "z")) "\\foo{x\\|\"y\"|z}")
+      (test-scribble '((foo "x" 1 (+ 2 3) 4 "y")) "\\foo{x\\|1 (+ 2 3) 4|y}")
+      (test-scribble '((foo "x" * * "y")) "\\foo{x\\|*
+        *|y}")
+      (test-scribble '((foo "Alice" "Bob" "Carol")) "\\foo{Alice\\||Bob\\|
+     |Carol}")
+      (test-scribble '((blah)) "\\|{blah}|")
+      (test-scribble '((blah blah)) "\\|{blah blah}|")
+
+      (test-scribble '((foo "First line" "\n" "     Second line")) "\\foo{First line\\;{there is still a
+                  newline here;}
+     Second line}")
+      (test-scribble '((foo "A long      single-     string arg.")) "\\foo{A long \\;
+     single-\\;
+     string arg.}")
+
+      (test-scribble '((foo "bar")) "\\foo{bar}")
+      (test-scribble '((foo " bar ")) "\\foo{ bar }")
+      (test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
+     baz }")
+
+      (test-scribble '((foo "bar" "\n")) "\\foo{bar
+}")
+      (test-scribble '((foo "  bar" "\n") "\n") "\\foo{
+  bar
+}
+")
+      (test-scribble '((foo "  bar" "\n" "\n")) "\\foo{
+
+  bar
+
+}")
+      (test-scribble '((foo "  bar" "\n" "\n" "  baz" "\n")) "\\foo{
+  bar
+
+  baz
+}")
+      (test-scribble '((foo)) "\\foo{
+}")
+      (test-scribble '((foo)) "\\foo{
+
+}")
+      (test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
+     baz }")
+
+      (test-scribble '((foo "  bar" "\n" "  baz" "\n" "  blah" "\n")) "\\foo{
+  bar
+  baz
+  blah
+}")
+      (test-scribble '((foo "  begin" "\n" "    x++;" "\n" "  end")) "\\foo{
+  begin
+    x++;
+  end}")
+      (test-scribble '((foo "    a" "\n" "   b" "\n" "  c")) "\\foo{
+    a
+   b
+  c}")
+
+      (test-scribble '((foo "bar" "\n" "       baz" "\n" "     bbb")) "\\foo{bar
+       baz
+     bbb}")
+      (test-scribble '((foo " bar" "\n" "        baz" "\n" "      bbb")) "\\foo{ bar
+        baz
+      bbb}")
+      (test-scribble '((foo "bar" "\n" "   baz" "\n" "   bbb")) "\\foo{bar
+   baz
+   bbb}")
+      (test-scribble '((foo " bar" "\n" "   baz" "\n" "   bbb")) "\\foo{ bar
+   baz
+   bbb}")
+      (test-scribble
+       '((foo " bar" "\n" "   baz" "\n" "     bbb"))
+       "\\foo{ bar
+   baz
+     bbb}")
+      (test-scribble
+       '((text "Some " (b "bold" "\n" "\n" "  text")", and" "\n" "\n" "  more text."))
+       "\\text{Some \\b{bold
+
+  text}, and
+
+  more text.}")
+
+      (test-scribble '((foo "  " " bar " "\n" "  " " baz")) "\\foo{
+  \\|| bar \\||
+  \\|| baz}")
+
+      (test-end))))

lib/chibi/show-test.sld

@@ -0,0 +1,378 @@
+(define-library (chibi show-test)
+  (export run-tests)
+  (import (scheme base) (scheme read) (chibi test)
+          (chibi show) (chibi show base) (chibi show pretty))
+  (begin
+    (define (run-tests)
+      (test-begin "show")
+
+      ;; basic data types
+
+      (test "hi" (show #f "hi"))
+      (test "\"hi\"" (show #f (written "hi")))
+      (test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
+      (test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
+      (test "#(1 2 3)" (show #f (written '#(1 2 3))))
+      (test "(1 2 3)" (show #f (written '(1 2 3))))
+      (test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
+      (test "ABC" (show #f (upcased "abc")))
+      (test "abc" (show #f (downcased "ABC")))
+
+      (test "abc     def" (show #f "abc" (tab-to) "def"))
+      (test "abc  def" (show #f "abc" (tab-to 5) "def"))
+      (test "abcdef" (show #f "abc" (tab-to 3) "def"))
+
+      ;; numbers
+
+      (test "-1" (show #f -1))
+      (test "0" (show #f 0))
+      (test "1" (show #f 1))
+      (test "10" (show #f 10))
+      (test "100" (show #f 100))
+      (test "-1" (show #f (numeric -1)))
+      (test "0" (show #f (numeric 0)))
+      (test "1" (show #f (numeric 1)))
+      (test "10" (show #f (numeric 10)))
+      (test "100" (show #f (numeric 100)))
+      (test "57005" (show #f #xDEAD))
+      (test "#xdead" (show #f (with ((radix 16)) #xDEAD)))
+      (test "#xdead1234" (show #f (with ((radix 16)) #xDEAD) 1234))
+      (test "de.ad"
+          (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
+      (test "d.ead"
+          (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
+      (test "0.dead"
+          (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
+      (test "1g"
+          (show #f (with ((radix 17)) (numeric 33))))
+
+      (test "3.14159" (show #f 3.14159))
+      (test "3.14" (show #f (with ((precision 2)) 3.14159)))
+      (test "3.14" (show #f (with ((precision 2)) 3.14)))
+      (test "3.00" (show #f (with ((precision 2)) 3.)))
+      (test "1.10" (show #f (with ((precision 2)) 1.099)))
+      (test "0.00" (show #f (with ((precision 2)) 1e-17)))
+      (test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
+      (test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
+      (test "0.000004" (show #f (with ((precision 6)) 0.000004)))
+      (test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
+      (test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
+
+      (test "   3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
+      (test "  31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
+      (test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
+      (test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
+      (test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
+      (test "  -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
+      (test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
+      (test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
+      (test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
+      (test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
+
+      (cond
+       ((exact? (/ 1 3)) ;; exact rationals
+        (test "333.333333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 1000/3))))
+        (test  "33.333333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 100/3))))
+        (test   "3.333333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 10/3))))
+        (test   "0.333333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 1/3))))
+        (test   "0.033333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 1/30))))
+        (test   "0.003333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 1/300))))
+        (test   "0.000333333333333333333333333333"
+            (show #f (with ((precision 30)) (numeric 1/3000))))
+        (test   "0.666666666666666666666666666667"
+            (show #f (with ((precision 30)) (numeric 2/3))))
+        (test   "0.090909090909090909090909090909"
+            (show #f (with ((precision 30)) (numeric 1/11))))
+        (test   "1.428571428571428571428571428571"
+            (show #f (with ((precision 30)) (numeric 10/7))))
+        (test "0.123456789012345678901234567890"
+            (show #f (with ((precision 30))
+                       (numeric (/  123456789012345678901234567890
+                                    1000000000000000000000000000000)))))
+        (test  " 333.333333333333333333333333333333"
+            (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
+        (test  "  33.333333333333333333333333333333"
+            (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
+        (test  "   3.333333333333333333333333333333"
+            (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
+        (test  "   0.333333333333333333333333333333"
+            (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
+        ))
+
+      (test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
+      (test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
+
+      (test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
+
+      (test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
+      (test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
+      (test "-29,97,92,458"
+          (show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
+      (test "299.792.458"
+          (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
+      (test "299.792.458,0"
+          (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
+
+      (test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
+      (test "100,000.0"
+          (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
+      (test "100,000.00"
+          (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
+
+      (cond-expand
+       (complex
+        (test "1+2i" (show #f (string->number "1+2i")))
+        (test "1.00+2.00i"
+            (show #f (with ((precision 2)) (string->number "1+2i"))))
+        (test "3.14+2.00i"
+            (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
+
+      ;; padding/trimming
+
+      (test "abc  " (show #f (padded 5 "abc")))
+      (test "  abc" (show #f (padded/left 5 "abc")))
+      (test " abc " (show #f (padded/both 5 "abc")))
+      (test "abcde" (show #f (padded 5 "abcde")))
+      (test "abcdef" (show #f (padded 5 "abcdef")))
+
+      (test "abc" (show #f (trimmed 3 "abcde")))
+      (test "abc" (show #f (trimmed 3 "abcd")))
+      (test "abc" (show #f (trimmed 3 "abc")))
+      (test "ab" (show #f (trimmed 3 "ab")))
+      (test "a" (show #f (trimmed 3 "a")))
+      (test "cde" (show #f (trimmed/left 3 "abcde")))
+      (test "bcd" (show #f (trimmed/both 3 "abcde")))
+      (test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
+      (test "abc" (show #f (trimmed/lazy 3 "abcde")))
+      (test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
+
+      (test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
+      (test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
+      (test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
+      (test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
+      (test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
+
+      (test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
+      (test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
+      (test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
+      (test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
+      (test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
+
+      (test "abcde"
+          (show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
+      (test "ab..."
+          (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
+      (test "abc..."
+          (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
+      (test "abcde"
+          (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
+      (test "...ef"
+          (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
+      (test "...efg"
+          (show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
+      (test "abcdefg"
+          (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
+      (test "...d..."
+          (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
+      (test "...e..."
+          (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
+
+      (test "abc  " (show #f (fitted 5 "abc")))
+      (test "  abc" (show #f (fitted/left 5 "abc")))
+      (test " abc " (show #f (fitted/both 5 "abc")))
+      (test "abcde" (show #f (fitted 5 "abcde")))
+      (test "abcde" (show #f (fitted/left 5 "abcde")))
+      (test "abcde" (show #f (fitted/both 5 "abcde")))
+      (test "abcde" (show #f (fitted 5 "abcdefgh")))
+      (test "defgh" (show #f (fitted/left 5 "abcdefgh")))
+      (test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
+
+      (test "prefix: abc   :suffix"
+          (show #f "prefix: " (fitted 5 "abc") " :suffix"))
+      (test "prefix:   abc :suffix"
+          (show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
+      (test "prefix:  abc  :suffix"
+          (show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
+      (test "prefix: abcde :suffix"
+          (show #f "prefix: " (fitted 5 "abcde") " :suffix"))
+      (test "prefix: abcde :suffix"
+          (show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
+      (test "prefix: abcde :suffix"
+          (show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
+      (test "prefix: abcde :suffix"
+          (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
+      (test "prefix: defgh :suffix"
+          (show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
+      (test "prefix: bcdef :suffix"
+          (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
+
+      ;; joining
+
+      (test "1 2 3" (show #f (joined each '(1 2 3) " ")))
+
+      (test ":abc:123"
+          (show #f (joined/prefix
+                    (lambda (x) (trimmed 3 x))
+                    '("abcdef" "123456")
+                    ":")))
+
+      (test "abc\n123\n"
+          (show #f (joined/suffix
+                    (lambda (x) (trimmed 3 x))
+                    '("abcdef" "123456")
+                    nl)))
+
+      (test "lions, tigers, and bears"
+          (show #f (joined/last
+                    each
+                    (lambda (x) (each "and " x))
+                    '(lions tigers bears)
+                    ", ")))
+
+      (test "lions, tigers, or bears"
+          (show #f (joined/dot
+                    each
+                    (lambda (x) (each "or " x))
+                    '(lions tigers . bears)
+                    ", ")))
+
+      ;; shared structures
+
+      (test "#0=(1 . #0#)"
+          (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
+      (test "(0 . #0=(1 . #0#))"
+          (show #f (written (let ((ones (list 1)))
+                              (set-cdr! ones ones)
+                              (cons 0 ones)))))
+      (test "(sym . #0=(sym . #0#))"
+          (show #f (written (let ((syms (list 'sym)))
+                              (set-cdr! syms syms)
+                              (cons 'sym syms)))))
+      (test "(#0=(1 . #0#) #1=(2 . #1#))"
+          (show #f (written (let ((ones (list 1))
+                                  (twos (list 2)))
+                              (set-cdr! ones ones)
+                              (set-cdr! twos twos)
+                              (list ones twos)))))
+      (test "(#0=(1 . #0#) #0#)"
+          (show #f (written (let ((ones (list 1)))
+                              (set-cdr! ones ones)
+                              (list ones ones)))))
+      (test "((1) (1))"
+          (show #f (written (let ((ones (list 1)))
+                              (list ones ones)))))
+
+      (test "(#0=(1) #0#)"
+          (show #f (written-shared (let ((ones (list 1)))
+                                     (list ones ones)))))
+
+      ;; cycles without shared detection
+
+      (test "(1 1 1 1 1"
+          (show #f (trimmed/lazy
+                    10
+                    (written-simply
+                     (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+      (test "(1 1 1 1 1 "
+          (show #f (trimmed/lazy
+                    11
+                    (written-simply
+                     (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+      ;; pretty printing
+
+      (define-syntax test-pretty
+        (syntax-rules ()
+          ((test-pretty str)
+           (let ((sexp (read (open-input-string str))))
+             (test str (show #f (pretty sexp)))))))
+
+      (test-pretty "(foo bar)\n")
+
+      (test-pretty
+       "((self . aquanet-paper-1991)
+ (type . paper)
+ (title . \"Aquanet: a hypertext tool to hold your\"))
+")
+
+      (test-pretty
+       "(abracadabra xylophone
+             bananarama
+             yellowstonepark
+             cryptoanalysis
+             zebramania
+             delightful
+             wubbleflubbery)\n")
+
+      (test-pretty
+       "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
+  26 27 28 29 30 31 32 33 34 35 36 37)\n")
+
+      (test-pretty
+       "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
+ 26 27 28 29 30 31 32 33 34 35 36 37)\n")
+
+      (test-pretty
+       "(define (fold kons knil ls)
+  (define (loop ls acc)
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
+  (loop ls knil))\n")
+
+      (test-pretty
+       "(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
+
+      (test-pretty
+       "(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
+  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
+
+      (test-pretty
+       "(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
+    ((= index 5) my-vector)
+  (vector-set! my-vector index index))\n")
+
+      (test-pretty
+       "(define (fold kons knil ls)
+  (let loop ((ls ls) (acc knil))
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
+
+      (test-pretty
+       "(define (file->sexp-list pathname)
+  (call-with-input-file pathname
+    (lambda (port)
+      (let loop ((res '()))
+        (let ((line (read port)))
+          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
+
+      (test-pretty
+       "(design
+ (module (name \"\\\\testshiftregister\")
+         (attributes
+          (attribute (name \"\\\\src\") (value \"testshiftregister.v:10\"))))
+ (wire (name \"\\\\shreg\")
+       (attributes
+        (attribute (name \"\\\\src\") (value \"testshiftregister.v:15\")))))\n")
+
+      (test "(let ((ones '#0=(1 . #0#))) ones)\n"
+          (show #f (pretty (let ((ones (list 1)))
+                             (set-cdr! ones ones)
+                             `(let ((ones ',ones)) ones)))))
+
+      '(test
+           "(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+      (ones '#0=(1 . #0#)))
+  (append zeros ones))\n"
+           (show #f (pretty
+                     (let ((ones (list 1)))
+                       (set-cdr! ones ones)
+                       `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+                              (ones ',ones))
+                          (append zeros ones))))))
+
+      (test-end))))

lib/chibi/string-test.sld

@@ -0,0 +1,82 @@
+(define-library (chibi string-test)
+  (export run-tests)
+  (import (only (chibi test) test-begin test test-end)
+          (chibi string))
+  (begin
+    (define (run-tests)
+      (test-begin "strings")
+
+      (test #t (string-null? ""))
+      (test #f (string-null? " "))
+
+      (test #t (string-every char-alphabetic? "abc"))
+      (test #f (string-every char-alphabetic? "abc0"))
+      (test #f (string-every char-alphabetic? " abc"))
+      (test #f (string-every char-alphabetic? "a.c"))
+
+      (define (digit-value ch)
+        (case ch
+          ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
+          ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
+
+      (test 3 (string-any digit-value "a3c"))
+      (test #f (string-any digit-value "abc"))
+
+      (test 0 (string-find "abc" char-alphabetic?))
+      (test 3 (string-find "abc0" char-numeric?))
+      (test 3 (string-find "abc" char-numeric?))
+
+      (test 3 (string-find-right "abc" char-alphabetic?))
+      (test 4 (string-find-right "abc0" char-numeric?))
+      (test 0 (string-find-right "abc" char-numeric?))
+
+      (test 0 (string-skip "abc" char-numeric?))
+      (test 3 (string-skip "abc0" char-alphabetic?))
+      (test 3 (string-skip "abc" char-alphabetic?))
+
+      (test 3 (string-skip-right "abc" char-numeric?))
+      (test 4 (string-skip-right "abc0" char-alphabetic?))
+      (test 0 (string-skip-right "abc" char-alphabetic?))
+
+      (test "foobarbaz" (string-join '("foo" "bar" "baz")))
+      (test "foo bar baz" (string-join '("foo" "bar" "baz") " "))
+
+      (test '() (string-split ""))
+      (test '("" "") (string-split " "))
+      (test '("foo" "bar" "baz") (string-split "foo bar baz"))
+      (test '("foo" "bar" "baz" "") (string-split "foo bar baz "))
+      (test '("foo" "bar" "baz") (string-split "foo:bar:baz" #\:))
+      (test '("" "foo" "bar" "baz") (string-split ":foo:bar:baz" #\:))
+      (test '("foo" "bar" "baz" "") (string-split "foo:bar:baz:" #\:))
+      (test '("foo" "bar:baz") (string-split "foo:bar:baz" #\: 2))
+
+      (test "abc" (string-trim-left "  abc"))
+      (test "abc  " (string-trim-left "abc  "))
+      (test "abc  " (string-trim-left "  abc  "))
+
+      (test "  abc" (string-trim-right "  abc"))
+      (test "abc" (string-trim-right "abc  "))
+      (test "  abc" (string-trim-right "  abc  "))
+
+      (test "abc" (string-trim "  abc"))
+      (test "abc" (string-trim "abc  "))
+      (test "abc" (string-trim "  abc  "))
+      (test "" (string-trim ""))
+      (test "" (string-trim " "))
+      (test "" (string-trim "  "))
+
+      (test #t (string-prefix? "abc" "abc"))
+      (test #t (string-prefix? "abc" "abcde"))
+      (test #f (string-prefix? "abcde" "abc"))
+
+      (test #t (string-suffix? "abc" "abc"))
+      (test #f (string-suffix? "abc" "abcde"))
+      (test #f (string-suffix? "abcde" "abc"))
+      (test #f (string-suffix? "abcde" "cde"))
+      (test #t (string-suffix? "cde" "abcde"))
+
+      (test 3 (string-count "!a0 bc /.," char-alphabetic?))
+
+      (test "ABC" (string-map char-upcase "abc"))
+
+      (test-end))))

lib/chibi/system-test.sld

@@ -0,0 +1,35 @@
+(define-library (chibi system-test)
+  (export run-tests)
+  (import (chibi) (chibi system) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "system")
+
+      (test #t (user? (user-information (current-user-id))))
+      (test #f (user? #f))
+      (test #f (user? (list #f)))
+      (test #t (string? (user-name (user-information (current-user-id)))))
+      (test #t (string? (user-password (user-information (current-user-id)))))
+      (test #t (integer? (user-id (user-information (current-user-id)))))
+      (test #t (integer? (user-group-id (user-information (current-user-id)))))
+      (test #t (string? (user-gecos (user-information (current-user-id)))))
+      (test #t (string? (user-home (user-information (current-user-id)))))
+      (test #t (string? (user-shell (user-information (current-user-id)))))
+
+      (test (current-user-id) (user-id (user-information (current-user-id))))
+      (test (current-group-id) (user-group-id (user-information (current-user-id))))
+
+      (test (user-id (user-information (current-user-id)))
+          (user-id (user-information (user-name (user-information (current-user-id))))))
+
+      (test #t (integer? (current-session-id)))
+
+      ;; stress test user-name
+      (test (user-name (user-information (current-user-id)))
+          (user-name (user-information (current-user-id))))
+      (define u (user-information (current-user-id)))
+      (test (user-name u) (user-name (user-information (current-user-id))))
+      (define un (user-name (user-information (current-user-id))))
+      (test un (user-name (user-information (current-user-id))))
+
+      (test-end))))

lib/chibi/tar-test.sld

@@ -0,0 +1,74 @@
+(define-library (chibi tar-test)
+  (export run-tests)
+  (import (chibi)
+          (only (scheme base)
+                bytevector-append
+                make-bytevector
+                string->utf8
+                bytevector
+                open-input-bytevector
+                open-output-bytevector
+                get-output-bytevector)
+          (chibi tar)
+          (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "tar")
+
+      ;; Utility to flatten bytevectors, strings and individual bytes
+      ;; (integers) into a single bytevector for generating readable test
+      ;; data.  (<byte> . <repetition>) can be used to repeat a byte.
+      (define (bv . args)
+        (apply bytevector-append
+               (map (lambda (x)
+                      (cond ((string? x) (string->utf8 x))
+                            ((pair? x) (make-bytevector (cdr x) (car x)))
+                            ((integer? x) (bytevector x))
+                            (else x)))
+                    args)))
+
+      (let ((b (bv "foo" '(0 . 97)
+                   "000644 " 0
+                   "000765 " 0
+                   "000765 " 0
+                   "00000000016 "
+                   "12302104616 "
+                   "011512" 0 " "
+                   "0"
+                   '(0 . 100)
+                   "ustar" 0 "00"
+                   "bob" '(0 . 29)
+                   "bob" '(0 . 29)
+                   "000000 " 0
+                   "000000 " 0
+                   '(0 . 155)
+                   '(0 . 12)
+                   )))
+        (let ((x (read-tar (open-input-bytevector b))))
+          (test "foo" (tar-path x))
+          (test 501 (tar-uid x))
+          (test "bob" (tar-owner x)))
+        (let ((x (make-tar)))
+          (tar-path-set! x "bar")
+          (tar-mode-set! x #o644)
+          (tar-uid-set! x 501)
+          (tar-gid-set! x 502)
+          (tar-size-set! x 123)
+          (tar-time-set! x 456)
+          (tar-ustar-set! x "ustar")
+          (tar-owner-set! x "john")
+          (tar-group-set! x "john")
+          (test "bar" (tar-path x))
+          (test-error (tar-mode-set! x "r"))
+          (let ((out (open-output-bytevector)))
+            (write-tar x out)
+            (let ((bv2 (get-output-bytevector out)))
+              (test-assert (bytevector? bv2))
+              (let ((x2 (read-tar (open-input-bytevector bv2))))
+                (test-assert "bar" (tar-path x2))
+                (test-assert #o644 (tar-mode x2))
+                (test-assert 501 (tar-uid x2))
+                (test-assert 502 (tar-gid x2))
+                (test-assert "john" (tar-owner x2)))))))
+
+      (test-end))))

lib/chibi/term/ansi-test.sld

@@ -0,0 +1,188 @@
+(define-library (chibi term ansi-test)
+  (export run-tests)
+  (import (chibi)
+          (only (scheme base) parameterize)
+          (chibi test)
+          (chibi term ansi))
+  (begin
+    (define (run-tests)
+      (test-begin "term.ansi")
+
+      (test-assert (procedure? ansi-escapes-enabled?))
+      (test-assert
+          (let ((tag (cons #t #t)))
+            (eqv? tag
+                  (parameterize ((ansi-escapes-enabled? tag))
+                    (ansi-escapes-enabled?)))))
+
+      (define-syntax test-escape-procedure
+        (syntax-rules ()
+          ((test-escape-procedure p s)
+           (begin
+             (test-assert (procedure? p))
+             (test-error (p #f))
+             (test s (p))))))
+
+      (define-syntax test-wrap-procedure
+        (syntax-rules ()
+          ((test-wrap-procedure p s)
+           (begin
+             (test-assert (procedure? p))
+             (test-error (p))
+             (test-error (p #f))
+             (test-error (p "" #f))
+             (test (p "FOO")
+                 "FOO"
+               (parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
+             (test (p "FOO")
+                 s
+               (parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
+
+      (test-escape-procedure black-escape       "\x1b;[30m")
+      (test-escape-procedure red-escape         "\x1b;[31m")
+      (test-escape-procedure green-escape       "\x1b;[32m")
+      (test-escape-procedure yellow-escape      "\x1b;[33m")
+      (test-escape-procedure blue-escape        "\x1b;[34m")
+      (test-escape-procedure cyan-escape        "\x1b;[36m")
+      (test-escape-procedure magenta-escape     "\x1b;[35m")
+      (test-escape-procedure white-escape       "\x1b;[37m")
+      (test-escape-procedure reset-color-escape "\x1b;[39m")
+
+      (test-assert (procedure? rgb-escape))
+      (test-error (rgb-escape))
+      (test-error (rgb-escape 0))
+      (test-error (rgb-escape 0 0))
+      (test-error (rgb-escape 0 0 0 0))
+      (test-error (rgb-escape 0.0 0 0))
+      (test-error (rgb-escape 0 0.0 0))
+      (test-error (rgb-escape 0 0 0.0))
+      (test-error (rgb-escape -1 0 0))
+      (test-error (rgb-escape 0 -1 0))
+      (test-error (rgb-escape 0 0 -1))
+      (test-error (rgb-escape 6 0 0))
+      (test-error (rgb-escape 0 6 0))
+      (test-error (rgb-escape 0 0 6))
+      (test-escape-procedure (lambda () (rgb-escape 0 0 0)) "\x1B[38;5;16m")
+      (test-escape-procedure (lambda () (rgb-escape 5 0 0)) "\x1B[38;5;196m")
+      (test-escape-procedure (lambda () (rgb-escape 0 5 0)) "\x1B[38;5;46m")
+      (test-escape-procedure (lambda () (rgb-escape 0 0 5)) "\x1B[38;5;21m")
+      (test-escape-procedure (lambda () (rgb-escape 1 1 1)) "\x1B[38;5;59m")
+      (test-escape-procedure (lambda () (rgb-escape 2 2 2)) "\x1B[38;5;102m")
+      (test-escape-procedure (lambda () (rgb-escape 3 3 3)) "\x1B[38;5;145m")
+      (test-escape-procedure (lambda () (rgb-escape 4 4 4)) "\x1B[38;5;188m")
+      (test-escape-procedure (lambda () (rgb-escape 5 5 5)) "\x1B[38;5;231m")
+      (test-escape-procedure (lambda () (rgb-escape 1 3 5)) "\x1B[38;5;75m")
+      (test-escape-procedure (lambda () (rgb-escape 5 1 3)) "\x1B[38;5;205m")
+      (test-escape-procedure (lambda () (rgb-escape 3 5 1)) "\x1B[38;5;155m")
+
+      (test-assert (procedure? gray-escape))
+      (test-error (gray-escape))
+      (test-error (gray-escape 0 0))
+      (test-error (gray-escape 0.0))
+      (test-error (gray-escape -1))
+      (test-error (gray-escape 24))
+      (test-escape-procedure (lambda () (gray-escape  0)) "\x1B[38;5;232m")
+      (test-escape-procedure (lambda () (gray-escape 23)) "\x1B[38;5;255m")
+      (test-escape-procedure (lambda () (gray-escape 12)) "\x1B[38;5;244m")
+
+      (test-wrap-procedure   black       "\x1b;[30mFOO\x1b;[39m")
+      (test-wrap-procedure   red         "\x1b;[31mFOO\x1b;[39m")
+      (test-wrap-procedure   green       "\x1b;[32mFOO\x1b;[39m")
+      (test-wrap-procedure   yellow      "\x1b;[33mFOO\x1b;[39m")
+      (test-wrap-procedure   blue        "\x1b;[34mFOO\x1b;[39m")
+      (test-wrap-procedure   cyan        "\x1b;[36mFOO\x1b;[39m")
+      (test-wrap-procedure   magenta     "\x1b;[35mFOO\x1b;[39m")
+      (test-wrap-procedure   white       "\x1b;[37mFOO\x1b;[39m")
+      (test-wrap-procedure   (rgb 0 0 0) "\x1B[38;5;16mFOO\x1b;[39m")
+      (test-wrap-procedure   (rgb 5 5 5) "\x1B[38;5;231mFOO\x1b;[39m")
+      (test-wrap-procedure   (gray 0)    "\x1B[38;5;232mFOO\x1b;[39m")
+      (test-wrap-procedure   (gray 23)   "\x1B[38;5;255mFOO\x1b;[39m")
+
+      (test-escape-procedure black-background-escape       "\x1b;[40m")
+      (test-escape-procedure red-background-escape         "\x1b;[41m")
+      (test-escape-procedure green-background-escape       "\x1b;[42m")
+      (test-escape-procedure yellow-background-escape      "\x1b;[43m")
+      (test-escape-procedure blue-background-escape        "\x1b;[44m")
+      (test-escape-procedure cyan-background-escape        "\x1b;[46m")
+      (test-escape-procedure magenta-background-escape     "\x1b;[45m")
+      (test-escape-procedure white-background-escape       "\x1b;[47m")
+      (test-escape-procedure reset-background-color-escape "\x1b;[49m")
+
+      (test-assert (procedure? rgb-background-escape))
+      (test-error (rgb-background-escape))
+      (test-error (rgb-background-escape 0))
+      (test-error (rgb-background-escape 0 0))
+      (test-error (rgb-background-escape 0 0 0 0))
+      (test-error (rgb-background-escape 0.0 0 0))
+      (test-error (rgb-background-escape 0 0.0 0))
+      (test-error (rgb-background-escape 0 0 0.0))
+      (test-error (rgb-background-escape -1 0 0))
+      (test-error (rgb-background-escape 0 -1 0))
+      (test-error (rgb-background-escape 0 0 -1))
+      (test-error (rgb-background-escape 6 0 0))
+      (test-error (rgb-background-escape 0 6 0))
+      (test-error (rgb-background-escape 0 0 6))
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 0 0 0)) "\x1B[48;5;16m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 5 0 0)) "\x1B[48;5;196m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 0 5 0)) "\x1B[48;5;46m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 0 0 5)) "\x1B[48;5;21m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 1 1 1)) "\x1B[48;5;59m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 2 2 2)) "\x1B[48;5;102m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 3 3 3)) "\x1B[48;5;145m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 4 4 4)) "\x1B[48;5;188m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 5 5 5)) "\x1B[48;5;231m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 1 3 5)) "\x1B[48;5;75m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 5 1 3)) "\x1B[48;5;205m")
+      (test-escape-procedure
+       (lambda () (rgb-background-escape 3 5 1)) "\x1B[48;5;155m")
+
+      (test-assert (procedure? gray-background-escape))
+      (test-error (gray-background-escape))
+      (test-error (gray-background-escape 0 0))
+      (test-error (gray-background-escape 0.0))
+      (test-error (gray-background-escape -1))
+      (test-error (gray-background-escape 24))
+      (test-escape-procedure
+       (lambda () (gray-background-escape  0)) "\x1B[48;5;232m")
+      (test-escape-procedure
+       (lambda () (gray-background-escape 23)) "\x1B[48;5;255m")
+      (test-escape-procedure
+       (lambda () (gray-background-escape 12)) "\x1B[48;5;244m")
+
+      (test-wrap-procedure   black-background       "\x1b;[40mFOO\x1b;[49m")
+      (test-wrap-procedure   red-background         "\x1b;[41mFOO\x1b;[49m")
+      (test-wrap-procedure   green-background       "\x1b;[42mFOO\x1b;[49m")
+      (test-wrap-procedure   yellow-background      "\x1b;[43mFOO\x1b;[49m")
+      (test-wrap-procedure   blue-background        "\x1b;[44mFOO\x1b;[49m")
+      (test-wrap-procedure   cyan-background        "\x1b;[46mFOO\x1b;[49m")
+      (test-wrap-procedure   magenta-background     "\x1b;[45mFOO\x1b;[49m")
+      (test-wrap-procedure   white-background       "\x1b;[47mFOO\x1b;[49m")
+      (test-wrap-procedure   (rgb-background 0 0 0) "\x1B[48;5;16mFOO\x1b;[49m")
+      (test-wrap-procedure   (rgb-background 5 5 5) "\x1B[48;5;231mFOO\x1b;[49m")
+      (test-wrap-procedure   (gray-background 0)    "\x1B[48;5;232mFOO\x1b;[49m")
+      (test-wrap-procedure   (gray-background 23)   "\x1B[48;5;255mFOO\x1b;[49m")
+
+      (test-escape-procedure bold-escape            "\x1b;[1m")
+      (test-escape-procedure reset-bold-escape      "\x1b;[22m")
+      (test-wrap-procedure   bold                   "\x1b;[1mFOO\x1b;[22m")
+
+      (test-escape-procedure underline-escape       "\x1b;[4m")
+      (test-escape-procedure reset-underline-escape "\x1b;[24m")
+      (test-wrap-procedure   underline              "\x1b;[4mFOO\x1b;[24m")
+
+      (test-escape-procedure negative-escape        "\x1b;[7m")
+      (test-escape-procedure reset-negative-escape  "\x1b;[27m")
+      (test-wrap-procedure   negative               "\x1b;[7mFOO\x1b;[27m")
+
+      (test-end))))

lib/chibi/uri-test.sld

@@ -0,0 +1,67 @@
+(define-library (chibi uri-test)
+  (export run-tests)
+  (import (chibi) (chibi test) (chibi uri))
+  (begin
+    (define (run-tests)
+      (test-begin "uri")
+
+      (test-assert (uri? (make-uri 'http)))
+      (test 'http (uri-scheme (make-uri 'http)))
+      (test "r" (uri-user (make-uri 'http "r")))
+      (test "google.com" (uri-host (make-uri 'http "r" "google.com")))
+      (test 80 (uri-port (make-uri 'http "r" "google.com" 80)))
+      (test "/search" (uri-path (make-uri 'http "r" "google.com" 80 "/search")))
+      (test "q=cats"
+          (uri-query (make-uri 'http "r" "google.com" 80 "/search" "q=cats")))
+      (test "recent"
+          (uri-fragment
+           (make-uri 'http "r" "google.com" 80 "/search" "q=cats" "recent")))
+
+      (let ((str "http://google.com"))
+        (test-assert (uri? (string->uri str)))
+        (test 'http (uri-scheme (string->uri str)))
+        (test "google.com" (uri-host (string->uri str)))
+        (test #f (uri-port (string->uri str)))
+        (test #f (uri-path (string->uri str)))
+        (test #f (uri-query (string->uri str)))
+        (test #f (uri-fragment (string->uri str))))
+
+      (let ((str "http://google.com/"))
+        (test-assert (uri? (string->uri str)))
+        (test 'http (uri-scheme (string->uri str)))
+        (test "google.com" (uri-host (string->uri str)))
+        (test #f (uri-port (string->uri str)))
+        (test "/" (uri-path (string->uri str)))
+        (test #f (uri-query (string->uri str)))
+        (test #f (uri-fragment (string->uri str))))
+
+      (let ((str "http://google.com:80/search?q=cats#recent"))
+        (test-assert (uri? (string->uri str)))
+        (test 'http (uri-scheme (string->uri str)))
+        (test "google.com" (uri-host (string->uri str)))
+        (test 80 (uri-port (string->uri str)))
+        (test "/search" (uri-path (string->uri str)))
+        (test "q=cats" (uri-query (string->uri str)))
+        (test "recent" (uri-fragment (string->uri str))))
+
+      (test "/%73" (uri-path (string->uri "http://google.com/%73")))
+      (test "/s" (uri-path (string->uri "http://google.com/%73" #t)))
+      (test "a=1&b=2;c=3"
+          (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t)))
+      (test '(("a" . "1") ("b" . "2") ("c" . "3"))
+          (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t #t)))
+      (test '(("a" . "1") ("b" . "2+2") ("c" . "3"))
+          (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #f #t)))
+      (test '(("a" . "1") ("b" . "2 2") ("c" . "3"))
+          (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #t #t)))
+
+      (let ((str "/"))
+        (test-assert (uri? (string->path-uri 'http str)))
+        (test 'http (uri-scheme (string->path-uri 'http str)))
+        (test #f (uri-host (string->path-uri 'http str)))
+        (test #f (uri-port (string->path-uri 'http str)))
+        (test "/" (uri-path (string->path-uri 'http str)))
+        (test #f (uri-query (string->path-uri 'http str)))
+        (test #f (uri-fragment (string->path-uri 'http str))))
+
+      (test-end))))

lib/chibi/weak-test.sld

@@ -0,0 +1,48 @@
+(define-library (chibi weak-test)
+  (export run-tests)
+  (import (chibi weak) (chibi ast) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "weak pointers")
+
+      (test "preserved key and value" '("key1" "value1" #f)
+        (let ((key (string-append "key" "1"))
+              (value (string-append "value" "1")))
+          (let ((eph (make-ephemeron key value)))
+            (gc)
+            (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+      (test "unpreserved key and value" '(#f #f #t)
+        (let ((eph (make-ephemeron (string-append "key" "2")
+                                   (string-append "value" "2"))))
+          (gc)
+          (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph))))
+
+      (test "unpreserved key and preserved value" '(#f "value3" #t)
+        (let ((value (string-append "value" "3")))
+          (let ((eph (make-ephemeron (string-append "key" "3") value)))
+            (gc)
+            (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
+
+      (test "unpreserved value references unpreserved key" '(#f #f #t)
+        (let ((key (string-append "key")))
+          (let ((eph (make-ephemeron key (cons (string-append "value") key))))
+            (gc)
+            (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+      ;; disabled - we support weak keys, but not proper ephemerons
+
+      '(test "preserved key and unpreserved value" '("key" "value" #f)
+         (let ((key (string-append "key")))
+           (let ((eph (make-ephemeron key (string-append "value"))))
+             (gc)
+             (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+      '(test "preserved value references unpreserved key" '(#f #f #t)
+         (let* ((key (string-append "key"))
+                (value (cons (string-append "value") key)))
+           (let ((eph (make-ephemeron key value)))
+             (gc)
+             (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
+
+      (test-end))))

lib/srfi/1/test.sld

@@ -0,0 +1,173 @@
+(define-library (srfi 1 test)
+  (export run-tests)
+  (import (chibi) (chibi test) (srfi 1))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-1: list library")
+
+      ;; srfi-1 examples
+      ;; http://srfi.schemers.org/srfi-1/srfi-1.html
+      (test '(a) (cons 'a '()))
+      (test '((a) b c d) (cons '(a) '(b c d)))
+      (test '("a" b c) (cons "a" '(b c)))
+      (test '(a . 3) (cons 'a 3))
+      (test '((a b) . c) (cons '(a b) 'c))
+      (test '(a 7 c) (list 'a (+ 3 4) 'c))
+      (test '() (list))
+      (test '(a b c) (xcons '(b c) 'a))
+      (test '(1 2 3 . 4) (cons* 1 2 3 4))
+      (test 1 (cons* 1))
+      (test '(c c c c) (make-list 4 'c))
+      (test '(0 1 2 3) (list-tabulate 4 values))
+      (test '(z q z q z q) (take (circular-list 'z 'q) 6))
+      (test '(0 1 2 3 4) (iota 5))
+      (test '(0 -0.1 -0.2 -0.3 -0.4)
+          (let ((res (iota 5 0 -0.1)))
+            (cons (inexact->exact (car res)) (cdr res))))
+      (test #t (pair? '(a . b)))
+      (test #t (pair? '(a b c)))
+      (test #f (pair? '()))
+      (test #f (pair? '#(a b)))
+      (test #f (pair? 7))
+      (test #f (pair? 'a))
+      (test #t (list= eq?))
+      (test #t (list= eq? '(a)))
+      (test 'a (car '(a b c)))
+      (test '(b c)   (cdr '(a b c)))
+      (test '(a) (car '((a) b c d)))
+      (test '(b c d) (cdr '((a) b c d)))
+      (test '1 (car '(1 . 2)))
+      (test '2 (cdr '(1 . 2)))
+      (test-error (car '()))
+      (test-error (cdr '()))
+      (test 'c (list-ref '(a b c d) 2))
+      (test 'c (third '(a b c d e)))
+      (test '(a b) (take '(a b c d e)  2))
+      (test '(c d e) (drop '(a b c d e)  2))
+      (test '(1 2) (take '(1 2 3 . d) 2))
+      (test '(3 . d) (drop '(1 2 3 . d) 2))
+      (test '(1 2 3) (take '(1 2 3 . d) 3))
+      (test 'd (drop '(1 2 3 . d) 3))
+      (test '(d e) (take-right '(a b c d e) 2))
+      (test '(a b c) (drop-right '(a b c d e) 2))
+      (test '(2 3 . d) (take-right '(1 2 3 . d) 2))
+      (test '(1) (drop-right '(1 2 3 . d) 2))
+      (test 'd (take-right '(1 2 3 . d) 0))
+      (test '(1 2 3) (drop-right '(1 2 3 . d) 0))
+      (test-assert (member (take! (circular-list 1 3 5) 8) '((1 3) (1 3 5 1 3 5 1 3)) equal?))
+      (test-values (values '(a b c) '(d e f g h)) (split-at '(a b c d e f g h) 3))
+      (test 'c (last '(a b c)))
+      (test '(c) (last-pair '(a b c)))
+      (test '(x y) (append '(x) '(y)))
+      (test '(a b c d) (append '(a) '(b c d)))
+      (test '(a (b) (c)) (append '(a (b)) '((c))))
+      (test '(a b c . d) (append '(a b) '(c . d)))
+      (test 'a (append '() 'a))
+      (test '(x y) (append '(x y)))
+      (test '() (append))
+      (test '(c b a) (reverse '(a b c)))
+      (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+      (test '((one 1 odd) (two 2 even) (three 3 odd)) (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even)))
+      (test '((1) (2) (3)) (zip '(1 2 3)))
+      (test '((3 #f) (1 #t) (4 #f) (1 #t)) (zip '(3 1 4 1) (circular-list #f #t)))
+      (test-values (values '(1 2 3) '(one two three)) (unzip2 '((1 one) (2 two) (3 three))))
+      (test 3 (count even? '(3 1 4 1 5 9 2 5 6)))
+      (test 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
+      (test 2 (count < '(3 1 4 1) (circular-list 1 10)))
+      (test '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
+      (test '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
+      (test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
+      (test '((a b c) (1 2 3) (b c) (2 3) (c) (3)) (pair-fold-right cons* '() '(a b c) '(1 2 3)))
+      (test '(b e h) (map cadr '((a b) (d e) (g h))))
+      (test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+      (test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+      (test-assert (member (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))) '((1 2) (2 1)) equal?))
+      (test '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0)))
+      (test '#(0 1 4 9 16) (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v))
+      (test '(1 -1 3 -3 8 -8) (append-map (lambda (x) (list x (- x))) '(1 3 8)))
+      (test '(1 -1 3 -3 8 -8) (apply append (map (lambda (x) (list x (- x))) '(1 3 8))))
+      (test '(1 -1 3 -3 8 -8) (append-map! (lambda (x) (list x (- x))) '(1 3 8)))
+      (test '(1 -1 3 -3 8 -8) (apply append! (map (lambda (x) (list x (- x))) '(1 3 8))))
+      (test "pair-for-each-1" '((a b c) (b c) (c))
+        (let ((a '()))
+          (pair-for-each (lambda (x) (set! a (cons x a))) '(a b c))
+          (reverse a)))
+      (test '(1 9 49) (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
+      (test '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
+      (test-values (values '(one four five) '(2 3 6)) (partition symbol? '(one 2 3 four five 6)))
+      (test '(7 43) (remove even? '(0 7 8 8 43 -4)))
+      (test 2 (find even? '(1 2 3)))
+      (test #t (any  even? '(1 2 3)))
+      (test #f (find even? '(1 7 3)))
+      (test #f (any  even? '(1 7 3)))
+                                        ;(test-error (find even? '(1 3 . x)))
+                                        ;(test-error (any  even? '(1 3 . x)))
+                                        ;(test 'error/undefined (find even? '(1 2 . x)))
+                                        ;(test 'error/undefined (any  even? '(1 2 . x))) ; success, error or other
+      (test 6 (find even? (circular-list 1 6 3)))
+      (test #t (any  even? (circular-list 1 6 3)))
+                                        ;(test-error (find even? (circular-list 1 3))) ; divergent
+                                        ;(test-error (any even? (circular-list 1 3))) ; divergent
+      (test 4 (find even? '(3 1 4 1 5 9)))
+      (test #f (every odd? '(1 2 3)))
+      (test #t (every < '(1 2 3) '(4 5 6)))
+      (test-error (every odd? '(1 3 . x)))
+      (test '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
+      (test '#f (find-tail even? '(3 1 37 -5)))
+      (test '(2 18) (take-while even? '(2 18 3 10 22 9)))
+      (test '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
+      (test-values (values '(2 18) '(3 10 22 9)) (span even? '(2 18 3 10 22 9)))
+      (test-values (values '(3 1) '(4 1 5 9)) (break even? '(3 1 4 1 5 9)))
+      (test #t (any integer? '(a 3 b 2.7)))
+      (test #f (any integer? '(a 3.1 b 2.7)))
+      (test #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
+      (test 2 (list-index even? '(3 1 4 1 5 9)))
+      (test 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+      (test #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+      (test '(a b c) (memq 'a '(a b c)))
+      (test '(b c) (memq 'b '(a b c)))
+      (test #f (memq 'a '(b c d)))
+      (test #f (memq (list 'a) '(b (a) c)))
+      (test '((a) c) (member (list 'a) '(b (a) c)))
+                                        ;(test '*unspecified* (memq 101 '(100 101 102)))
+      (test '(101 102) (memv 101 '(100 101 102)))
+      (test '(a b c z) (delete-duplicates '(a b a c a b c z)))
+      (test '((a . 3) (b . 7) (c . 1)) (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))))
+      (let ((e '((a 1) (b 2) (c 3))))
+        (test '(a 1) (assq 'a e))
+        (test '(b 2) (assq 'b e))
+        (test #f (assq 'd e))
+        (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+        (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+                                        ;(test '*unspecified* (assq 5 '((2 3) (5 7) (11 13))))
+        (test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))))
+      (test #t (lset<= eq? '(a) '(a b a) '(a b c c)))
+      (test #t (lset<= eq?))
+      (test #t (lset<= eq? '(a)))
+      (test #f (lset= eq? '(a) '()))
+      (test #f (lset= eq? '() '(a)))
+      (test #t (lset= eq? '(b e a) '(a e b) '(e e b a)))
+      (test #t (lset= eq?))
+      (test #t (lset= eq? '(a)))
+      (test #f (lset= = '(2 1) '(2 1 0)))
+      (test #t (lset<= = '(2 1) '(2 1 0)))
+      (test #f (lset<= = '(2 1 0) '(2 1)))
+      (test '(u o i a b c d c e) (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u))
+      (test '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u)))
+      (test '(x a a c) (lset-union eq? '(a a c) '(x a x)))
+      (test '() (lset-union eq?))
+      (test '(a b c) (lset-union eq? '(a b c)))
+      (test '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u)))
+      (test '(a x a) (lset-intersection eq? '(a x y a) '(x a x z)))
+      (test '(a b c) (lset-intersection eq? '(a b c)))
+      (test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
+      (test '(a b c) (lset-difference eq? '(a b c)))
+      (test #t (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))))
+      (test '() (lset-xor eq?))
+      (test '(a b c d e) (lset-xor eq? '(a b c d e)))
+      (let ((f (lambda () (list 'not-a-constant-list)))
+            (g (lambda () '(constant-list))))
+                                        ;(test '*unspecified* (set-car! (f) 3))
+        (test-error (set-car! (g) 3)))
+
+      (test-end))))

lib/srfi/16/test.sld

@@ -0,0 +1,45 @@
+(define-library (srfi 16 test)
+  (export run-tests)
+  (import (chibi) (chibi test) (srfi 16))
+  (begin
+    (define (run-tests)
+      (define plus
+        (case-lambda 
+         (() 0)
+         ((x) x)
+         ((x y) (+ x y))
+         ((x y z) (+ (+ x y) z))
+         (args (apply + args))))
+
+      (test-begin "srfi-16: case-lambda")
+
+      (test 0 (plus))
+      (test 1 (plus 1))
+      (test 6 (plus 1 2 3))
+      (test-error ((case-lambda ((a) a) ((a b) (* a b))) 1 2 3))
+
+      (define print
+        (case-lambda
+         (()
+          (display ""))
+         ((arg)
+          (display arg))
+         ((arg . args)
+          (display arg)
+          (display " ")
+          (apply print args))))
+
+      (define (print-to-string . args)
+        (let ((out (open-output-string))
+              (old-out (current-output-port)))
+          (dynamic-wind
+            (lambda () (current-output-port out))
+            (lambda () (apply print args))
+            (lambda () (current-output-port old-out)))
+          (get-output-string out)))
+
+      (test "" (print-to-string))
+      (test "hi" (print-to-string 'hi))
+      (test "hi there world" (print-to-string 'hi 'there 'world))
+
+      (test-end))))

lib/srfi/18/test.sld

@@ -0,0 +1,114 @@
+(define-library (srfi 18 test)
+  (export run-tests)
+  (import (chibi) (srfi 18) (srfi 39) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-18: threads")
+
+      (test "no threads" 'ok (begin 'ok))
+
+      (test "unstarted thread" 'ok
+        (let ((t (make-thread (lambda () (error "oops"))))) 'ok))
+
+      (test "ignored thread terminates" 'ok
+        (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
+
+      (test "ignored thread hangs" 'ok
+        (let ((t (make-thread (lambda () (let lp () (lp))))))
+          (thread-start! t)
+          'ok))
+
+      (test "joined thread terminates" 'ok
+        (let ((t (make-thread (lambda () 'oops))))
+          (thread-start! t)
+          (thread-join! t)
+          'ok))
+
+      (test "joined thread hangs, timeout" 'timeout
+        (let ((t (make-thread (lambda () (let lp () (lp))))))
+          (thread-start! t)
+          (thread-join! t 0.1 'timeout)))
+
+      (test "basic mutex" 'ok
+        (let ((m (make-mutex)))
+          (and (mutex? m) 'ok)))
+
+      (test "mutex unlock" 'ok
+        (let ((m (make-mutex)))
+          (and (mutex-unlock! m) 'ok)))
+
+      (test "mutex lock/unlock" 'ok
+        (let ((m (make-mutex)))
+          (and (mutex-lock! m)
+               (mutex-unlock! m)
+               'ok)))
+
+      (test "mutex lock/lock" 'timeout
+        (let ((m (make-mutex)))
+          (and (mutex-lock! m)
+               (if (mutex-lock! m 0.1) 'fail 'timeout))))
+
+      (test "mutex lock timeout" 'timeout
+        (let* ((m (make-mutex))
+               (t (make-thread (lambda () (mutex-lock! m)))))
+          (thread-start! t)
+          (thread-yield!)
+          (if (mutex-lock! m 0.1) 'fail 'timeout)))
+
+      (test "mutex lock/unlock/lock/lock" 'timeout
+        (let* ((m (make-mutex))
+               (t (make-thread (lambda () (mutex-unlock! m)))))
+          (mutex-lock! m)
+          (thread-start! t)
+          (if (mutex-lock! m 0.1)
+              (if (mutex-lock! m 0.1) 'fail-second 'timeout)
+              'bad-timeout)))
+
+      (test "thread-join! end result" 5
+        (let* ((th (make-thread (lambda () (+ 3 2)))))
+          (thread-start! th)
+          (thread-join! th)))
+
+      (test-error "thread-join! exception"
+                  (let* ((th (make-thread
+                              (lambda ()
+                                (parameterize ((current-error-port (open-output-string)))
+                                  (+ 3 "2"))))))
+                    (thread-start! th)
+                    (thread-join! th)))
+
+      (test-assert "make-condition-variable"
+        (condition-variable? (make-condition-variable)))
+
+      (test "condition-variable signal" 'ok
+        (let* ((mutex (make-mutex))
+               (cndvar (make-condition-variable))
+               (th (make-thread
+                    (lambda ()
+                      (if (mutex-unlock! mutex cndvar 0.1) 'ok 'timeout1)))))
+          (thread-start! th)
+          (thread-yield!)
+          (condition-variable-signal! cndvar)
+          (thread-join! th 0.1 'timeout2)))
+
+      (test "condition-variable broadcast" '(ok1 ok2)
+        (let* ((mutex (make-mutex))
+               (cndvar (make-condition-variable))
+               (th1 (make-thread
+                     (lambda ()
+                       (mutex-lock! mutex)
+                       (if (mutex-unlock! mutex cndvar 1.0) 'ok1 'timeout1))))
+               (th2 (make-thread
+                     (lambda ()
+                       (mutex-lock! mutex)
+                       (if (mutex-unlock! mutex cndvar 1.0) 'ok2 'timeout2)))))
+          (thread-start! th1)
+          (thread-start! th2)
+          (thread-yield!)
+          (mutex-lock! mutex)
+          (condition-variable-broadcast! cndvar)
+          (mutex-unlock! mutex)
+          (list (thread-join! th1 0.1 'timeout3)
+                (thread-join! th2 0.1 'timeout4))))
+
+      (test-end))))

lib/srfi/2/test.sld

@@ -0,0 +1,45 @@
+(define-library (srfi 2 test)
+  (export run-tests)
+  (import (chibi) (srfi 2) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-2: and-let*")
+      (test 1 (and-let* () 1))
+      (test 2 (and-let* () 1 2))
+      (test #t (and-let* () ))
+      (test #f (let ((x #f)) (and-let* (x))))
+      (test 1 (let ((x 1)) (and-let* (x))))
+      (test #f (and-let* ((x #f)) ))
+      (test 1 (and-let* ((x 1)) ))
+      ;; (test-syntax-error (and-let* ( #f (x 1))))
+      (test #f (and-let* ( (#f) (x 1)) ))
+      ;; (test-syntax-error (and-let* (2 (x 1))))
+      (test 1 (and-let* ( (2) (x 1)) ))
+      (test 2 (and-let* ( (x 1) (2)) ))
+      (test #f (let ((x #f)) (and-let* (x) x)))
+      (test "" (let ((x "")) (and-let* (x) x)))
+      (test "" (let ((x "")) (and-let* (x)  )))
+      (test 2 (let ((x 1)) (and-let* (x) (+ x 1))))
+      (test #f (let ((x #f)) (and-let* (x) (+ x 1))))
+      (test 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1))))
+      (test #t (let ((x 1)) (and-let* (((positive? x))) )))
+      (test #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1))))
+      (test 3  (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))))
+      (test 4
+          (let ((x 1))
+            (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
+      (test 2 (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test 2 (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
+      (test #f (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test #f (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test #f (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
+
+      (test #f
+          (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test #f
+          (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test #f
+          (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test 3/2
+          (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test-end))))

lib/srfi/26/test.sld

@@ -0,0 +1,15 @@
+(define-library (srfi 26 test)
+  (export run-tests)
+  (import (chibi) (srfi 26) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-26: cut")
+      (let ((x 'orig))
+        (let ((f (cute list x)))
+          (set! x 'wrong)
+          (test '(orig) (f))))
+      (let ((x 'wrong))
+        (let ((f (cut list x)))
+          (set! x 'right)
+          (test '(right) (f))))
+      (test-end))))

lib/srfi/27/test.sld

@@ -0,0 +1,27 @@
+(define-library (srfi 27 test)
+  (export run-tests)
+  (import (chibi)
+          (srfi 27)
+          (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-27: random")
+      (define (test-random rand n)
+        (test-assert (<= 0 (rand n) (- n 1))))
+      (let ((rs (make-random-source)))
+        ;; chosen by fair dice roll.  guaranteed to be random
+        (random-source-pseudo-randomize! rs 4 4)
+        (let ((rand (random-source-make-integers rs)))
+          (do ((k 0 (+ k 5))
+               (n 1 (* n 2)))
+              ((> k 1024))
+            (test-random rand n))
+          (let* ((state (random-source-state-ref rs))
+                 (x (rand 1000000)))
+            ;; the next int won't be the same, but it will be after
+            ;; resetting the state
+            (test-not (= x (rand 1000000)))
+            (random-source-state-set! rs state)
+            ;; (test x (rand 1000000))
+            )))
+      (test-end))))

lib/srfi/33/test.sld

@@ -0,0 +1,63 @@
+(define-library (srfi 33 test)
+  (export run-tests)
+  (import (chibi) (srfi 33) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-33: bitwise operations")
+
+      (test 0 (bitwise-and #b0 #b1))
+      (test 1 (bitwise-and #b1 #b1))
+      (test 0 (bitwise-and #b1 #b10))
+      (test #b10 (bitwise-and #b11 #b10))
+      (test #b101 (bitwise-and #b101 #b111))
+      (test #b111 (bitwise-and -1 #b111))
+      (test #b110 (bitwise-and -2 #b111))
+      (test 3769478 (bitwise-and -4290775858 1694076839))
+      (test 1680869008 (bitwise-and -193073517 1689392892))
+      ;; (test -2600468497 (bitwise-ior 1694076839 -4290775858))
+      ;; (test -184549633 (bitwise-ior -193073517 1689392892))
+      ;; (test -2604237975 (bitwise-xor 1694076839 -4290775858))
+      ;; (test -1865418641 (bitwise-xor -193073517 1689392892))
+
+      (test 1 (arithmetic-shift 1 0))
+      (test 2 (arithmetic-shift 1 1))
+      (test 4 (arithmetic-shift 1 2))
+      (test 8 (arithmetic-shift 1 3))
+      (test 16 (arithmetic-shift 1 4))
+      (test (expt 2 31) (arithmetic-shift 1 31))
+      (test (expt 2 32) (arithmetic-shift 1 32))
+      (test (expt 2 33) (arithmetic-shift 1 33))
+      (test (expt 2 63) (arithmetic-shift 1 63))
+      (test (expt 2 64) (arithmetic-shift 1 64))
+      (test (expt 2 65) (arithmetic-shift 1 65))
+      (test (expt 2 127) (arithmetic-shift 1 127))
+      (test (expt 2 128) (arithmetic-shift 1 128))
+      (test (expt 2 129) (arithmetic-shift 1 129))
+      (test 3028397001194014464 (arithmetic-shift 11829675785914119 8))
+
+      (test -1 (arithmetic-shift -1 0))
+      (test -2 (arithmetic-shift -1 1))
+      (test -4 (arithmetic-shift -1 2))
+      (test -8 (arithmetic-shift -1 3))
+      (test -16 (arithmetic-shift -1 4))
+      (test (- (expt 2 31)) (arithmetic-shift -1 31))
+      (test (- (expt 2 32)) (arithmetic-shift -1 32))
+      (test (- (expt 2 33)) (arithmetic-shift -1 33))
+      (test (- (expt 2 63)) (arithmetic-shift -1 63))
+      (test (- (expt 2 64)) (arithmetic-shift -1 64))
+      (test (- (expt 2 65)) (arithmetic-shift -1 65))
+      (test (- (expt 2 127)) (arithmetic-shift -1 127))
+      (test (- (expt 2 128)) (arithmetic-shift -1 128))
+      (test (- (expt 2 129)) (arithmetic-shift -1 129))
+
+      (test 0 (arithmetic-shift 1 -63))
+      (test 0 (arithmetic-shift 1 -64))
+      (test 0 (arithmetic-shift 1 -65))
+
+      (test #x1000000000000000100000000000000000000000000000000
+          (arithmetic-shift #x100000000000000010000000000000000 64))
+
+      (test-not (bit-set? 64 1))
+      (test-assert (bit-set? 64 #x10000000000000000))
+
+      (test-end))))

lib/srfi/38/test.sld

@@ -0,0 +1,98 @@
+(define-library (srfi 38 test)
+  (export run-tests)
+  (import (chibi) (chibi test) (srfi 1) (srfi 38))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-38: shared read/write")
+
+      (define (read-from-string str)
+        (call-with-input-string str
+          (lambda (in) (read/ss in))))
+
+      (define (write-to-string x . o)
+        (call-with-output-string
+          (lambda (out) (apply write/ss x out o))))
+
+      (define-syntax test-io
+        (syntax-rules ()
+          ((test-io str-expr expr)
+           (let ((str str-expr)
+                 (value expr))
+             (test str (write-to-string value))
+             (test str (write-to-string (read-from-string str)))))))
+
+      (define-syntax test-cyclic-io
+        (syntax-rules ()
+          ((test-io str-expr expr)
+           (let ((str str-expr)
+                 (value expr))
+             (test str (write-to-string value #t))
+             (test str (write-to-string (read-from-string str) #t))))))
+
+      (test-io "(1)" (list 1))
+      (test-io "(1 2)" (list 1 2))
+      (test-io "(1 . 2)" (cons 1 2))
+
+      (test-io "#0=(1 . #0#)" (circular-list 1))
+      (test-io "#0=(1 2 . #0#)" (circular-list 1 2))
+      (test-io "(1 . #0=(2 . #0#))" (cons 1 (circular-list 2)))
+      (test-io "#0=(1 #0# 3)"
+               (let ((x (list 1 2 3))) (set-car! (cdr x) x) x))
+      (test-io "(#0=(1 #0# 3))"
+               (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x)))
+      (test-io "(#0=(1 #0# 3) #0#)"
+               (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x x)))
+      (test-io "(#0=(1 . #0#) #1=(1 . #1#))"
+               (list (circular-list 1) (circular-list 1)))
+
+      (test-io "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
+               (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
+                 (list a b c a b c)))
+      (test-cyclic-io "((1 . 2) (1 . 2) (3 . 4) (1 . 2) (1 . 2) (3 . 4))"
+                      (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
+                        (list a b c a b c)))
+      (test-cyclic-io "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
+                      (let* ((a (cons 1 2))
+                             (b (cons 1 2))
+                             (c (cons 3 4))
+                             (ls (list a b c)))
+                        (set-cdr! (cddr ls) ls)
+                        ls))
+
+      (test-io "#0=#(#0#)"
+               (let ((x (vector 1))) (vector-set! x 0 x) x))
+      (test-io "#0=#(1 #0#)"
+               (let ((x (vector 1 2))) (vector-set! x 1 x) x))
+      (test-io "#0=#(1 #0# 3)"
+               (let ((x (vector 1 2 3))) (vector-set! x 1 x) x))
+      (test-io "(#0=#(1 #0# 3))"
+               (let ((x (vector 1 2 3))) (vector-set! x 1 x) (list x)))
+      (test-io "#0=#(#0# 2 #0#)"
+               (let ((x (vector 1 2 3)))
+                 (vector-set! x 0 x)
+                 (vector-set! x 2 x)
+                 x))
+
+      (test 255 (read-from-string "#xff"))
+      (test 99 (read-from-string "#d99"))
+      (test 63 (read-from-string "#o77"))
+      (test 3 (read-from-string "#b11"))
+      (test 5 (read-from-string "#e5.0"))
+      (test 5.0 (read-from-string "#i5"))
+      (test 15 (read-from-string "#e#xf"))
+      (test 15.0 (read-from-string "#i#xf"))
+      (test (expt 10 100) (read-from-string "#e1e100"))
+
+      (cond-expand
+       (chicken
+        (test-io "(#0=\"abc\" #0# #0#)"
+                 (let ((str (string #\a #\b #\c))) (list str str str)))
+        (test "(\"abc\" \"abc\" \"abc\")"
+            (let ((str (string #\a #\b #\c)))
+              (call-with-output-string
+                (lambda (out)
+                  (write/ss (list str str str) out ignore-strings: #t))))))
+       (else
+        ))
+
+      (test-end))))

lib/srfi/69/test.sld

@@ -0,0 +1,182 @@
+(define-library (srfi 69 test)
+  (export run-tests)
+  (import (chibi) (srfi 1) (srfi 69) (chibi test))
+  (begin
+    (define (run-tests)
+
+      (test-begin "srfi-69: hash-tables")
+
+      (define-syntax test-lset-eq?
+        (syntax-rules ()
+          ((test-lset= . args)
+           (test-equal (lambda (a b) (lset= eq? a b)) . args))))
+
+      (define-syntax test-lset-equal?
+        (syntax-rules ()
+          ((test-lset-equal? . args)
+           (test-equal (lambda (a b) (lset= equal? a b)) . args))))
+
+      (let ((ht (make-hash-table eq?)))
+        ;; 3 initial elements
+        (test 0 (hash-table-size ht))
+        (hash-table-set! ht 'cat 'black)
+        (hash-table-set! ht 'dog 'white)
+        (hash-table-set! ht 'elephant 'pink)
+        (test 3 (hash-table-size ht))
+        (test-assert (hash-table-exists? ht 'dog))
+        (test-assert (hash-table-exists? ht 'cat))
+        (test-assert (hash-table-exists? ht 'elephant))
+        (test-not (hash-table-exists? ht 'goose))
+        (test 'white (hash-table-ref ht 'dog))
+        (test 'black (hash-table-ref ht 'cat))
+        (test 'pink (hash-table-ref ht 'elephant))
+        (test-error (hash-table-ref ht 'goose))
+        (test 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
+        (test 'grey (hash-table-ref/default ht 'goose 'grey))
+        (test-lset-eq? '(cat dog elephant) (hash-table-keys ht))
+        (test-lset-eq? '(black white pink) (hash-table-values ht))
+        (test-lset-equal? '((cat . black) (dog . white) (elephant . pink))
+                          (hash-table->alist ht))
+
+        ;; remove an element
+        (hash-table-delete! ht 'dog)
+        (test 2 (hash-table-size ht))
+        (test-not (hash-table-exists? ht 'dog))
+        (test-assert (hash-table-exists? ht 'cat))
+        (test-assert (hash-table-exists? ht 'elephant))
+        (test-error (hash-table-ref ht 'dog))
+        (test 'black (hash-table-ref ht 'cat))
+        (test 'pink (hash-table-ref ht 'elephant))
+        (test-lset-eq? '(cat elephant) (hash-table-keys ht))
+        (test-lset-eq? '(black pink) (hash-table-values ht))
+        (test-lset-equal? '((cat . black) (elephant . pink)) (hash-table->alist ht))
+
+        ;; remove a non-existing element
+        (hash-table-delete! ht 'dog)
+        (test 2 (hash-table-size ht))
+        (test-not (hash-table-exists? ht 'dog))
+
+        ;; overwrite an existing element
+        (hash-table-set! ht 'cat 'calico)
+        (test 2 (hash-table-size ht))
+        (test-not (hash-table-exists? ht 'dog))
+        (test-assert (hash-table-exists? ht 'cat))
+        (test-assert (hash-table-exists? ht 'elephant))
+        (test-error (hash-table-ref ht 'dog))
+        (test 'calico (hash-table-ref ht 'cat))
+        (test 'pink (hash-table-ref ht 'elephant))
+        (test-lset-eq? '(cat elephant) (hash-table-keys ht))
+        (test-lset-eq? '(calico pink) (hash-table-values ht))
+        (test-lset-equal? '((cat . calico) (elephant . pink)) (hash-table->alist ht))
+
+        ;; walk and fold
+        (test-lset-equal?
+         '((cat . calico) (elephant . pink))
+         (let ((a '()))
+           (hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
+           a))
+        (test-lset-equal? '((cat . calico) (elephant . pink))
+                          (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '()))
+
+        ;; copy
+        (let ((ht2 (hash-table-copy ht)))
+          (test 2 (hash-table-size ht2))
+          (test-not (hash-table-exists? ht2 'dog))
+          (test-assert (hash-table-exists? ht2 'cat))
+          (test-assert (hash-table-exists? ht2 'elephant))
+          (test-error (hash-table-ref ht2 'dog))
+          (test 'calico (hash-table-ref ht2 'cat))
+          (test 'pink (hash-table-ref ht2 'elephant))
+          (test-lset-eq? '(cat elephant) (hash-table-keys ht2))
+          (test-lset-eq? '(calico pink) (hash-table-values ht2))
+          (test-lset-equal? '((cat . calico) (elephant . pink))
+                            (hash-table->alist ht2)))
+
+        ;; merge
+        (let ((ht2 (make-hash-table eq?)))
+          (hash-table-set! ht2 'bear 'brown)
+          (test 1 (hash-table-size ht2))
+          (test-not (hash-table-exists? ht2 'dog))
+          (test-assert (hash-table-exists? ht2 'bear))
+          (hash-table-merge! ht2 ht)
+          (test 3 (hash-table-size ht2))
+          (test-assert (hash-table-exists? ht2 'bear))
+          (test-assert (hash-table-exists? ht2 'cat))
+          (test-assert (hash-table-exists? ht2 'elephant))
+          (test-not (hash-table-exists? ht2 'goose))
+          (test 'brown (hash-table-ref ht2 'bear))
+          (test 'calico (hash-table-ref ht2 'cat))
+          (test 'pink (hash-table-ref ht2 'elephant))
+          (test-error (hash-table-ref ht2 'goose))
+          (test 'grey (hash-table-ref/default ht2 'goose 'grey))
+          (test-lset-eq? '(bear cat elephant) (hash-table-keys ht2))
+          (test-lset-eq? '(brown calico pink) (hash-table-values ht2))
+          (test-lset-equal? '((cat . calico) (bear . brown) (elephant . pink))
+                            (hash-table->alist ht2)))
+
+        ;; alist->hash-table
+        (test-lset-equal? (hash-table->alist ht)
+                          (hash-table->alist
+                           (alist->hash-table
+                            '((cat . calico) (elephant . pink))))))
+
+      ;; update
+      (let ((ht (make-hash-table eq?))
+            (add1 (lambda (x) (+ x 1))))
+        (hash-table-set! ht 'sheep 0)
+        (hash-table-update! ht 'sheep add1)
+        (hash-table-update! ht 'sheep add1)
+        (test 2 (hash-table-ref ht 'sheep))
+        (hash-table-update!/default ht 'crows add1 0)
+        (hash-table-update!/default ht 'crows add1 0)
+        (hash-table-update!/default ht 'crows add1 0)
+        (test 3 (hash-table-ref ht 'crows)))
+
+      ;; string keys
+      (let ((ht (make-hash-table equal?)))
+        (hash-table-set! ht "cat" 'black)
+        (hash-table-set! ht "dog" 'white)
+        (hash-table-set! ht "elephant" 'pink)
+        (hash-table-ref/default ht "dog" #f)
+        (test 'white (hash-table-ref ht "dog"))
+        (test 'black (hash-table-ref ht "cat"))
+        (test 'pink (hash-table-ref ht "elephant"))
+        (test-error (hash-table-ref ht "goose"))
+        (test 'grey (hash-table-ref/default ht "goose" 'grey))
+        (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
+        (test-lset-equal? '(black white pink) (hash-table-values ht))
+        (test-lset-equal?
+         '(("cat" . black) ("dog" . white) ("elephant" . pink))
+         (hash-table->alist ht)))
+
+      ;; string-ci keys
+      (let ((ht (make-hash-table string-ci=? string-ci-hash)))
+        (hash-table-set! ht "cat" 'black)
+        (hash-table-set! ht "dog" 'white)
+        (hash-table-set! ht "elephant" 'pink)
+        (hash-table-ref/default ht "DOG" #f)
+        (test 'white (hash-table-ref ht "DOG"))
+        (test 'black (hash-table-ref ht "Cat"))
+        (test 'pink (hash-table-ref ht "eLePhAnT"))
+        (test-error (hash-table-ref ht "goose"))
+        (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
+        (test-lset-equal? '(black white pink) (hash-table-values ht))
+        (test-lset-equal?
+         '(("cat" . black) ("dog" . white) ("elephant" . pink))
+         (hash-table->alist ht)))
+
+      ;; Exception values - this works because the return value from the
+      ;; primitives is a cell, and we use the cdr opcode to retrieve the
+      ;; cell value.  Thus there is no FFI issue with storing exceptions.
+      (let ((ht (make-hash-table)))
+        (hash-table-set! ht 'boom (make-exception 'my-exn-type "boom!" '() #f #f))
+        (test 'my-exn-type (exception-kind (hash-table-ref ht 'boom))))
+
+      ;; stress test
+      (test 625
+          (let ((ht (make-hash-table)))
+            (do ((i 0 (+ i 1))) ((= i 1000))
+              (hash-table-set! ht i (* i i)))
+            (hash-table-ref/default ht 25 #f)))
+
+      (test-end))))

lib/srfi/95/test.sld

@@ -0,0 +1,116 @@
+(define-library (srfi 95 test)
+  (export run-tests)
+  (import (chibi) (srfi 95) (only (chibi test) test-begin test test-end))
+  (begin
+    (define (run-tests)
+
+      (test-begin "srfi-95: sorting")
+
+      (test "sort null" '() (sort '()))
+      (test "sort null <" '() (sort '() <))
+      (test "sort null < car" '() (sort '() < car))
+      (test "sort equal list" '(0 0 0 0 0 0 0 0 0) (sort '(0 0 0 0 0 0 0 0 0)))
+      (test "sort equal list cmp" '(0 0 0 0 0 0 0 0 0)
+        (sort '(0 0 0 0 0 0 0 0 0) (lambda (a b) (< a b))))
+      (test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
+      (test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
+      (test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
+      (test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
+      (test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
+      (test "sort short equal list" '(0 0 0) (sort '(0 0 0)))
+      (test "sort short random list" '(1 2 3) (sort '(2 1 3)))
+      (test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b))))
+      (test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)
+        (sort '(7 5 2 8 1 6 4 9 3) <))
+      (test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9))
+        (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car))
+      (test "sort list (lambda (a b) (< (car a) (car b)))"
+          '((1) (2) (3) (4) (5) (6) (7) (8) (9))
+        (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3))
+              (lambda (a b) (< (car a) (car b)))))
+      (test "sort 1-char symbols" '(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" '(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 symbol"
+          '(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 "sort lists"
+          '((chibi) (scheme r5rs) (scheme write))
+        (sort '((chibi) (scheme r5rs) (scheme write))
+              (lambda (a b)
+                (string<? (call-with-output-string (lambda (out) (write a out)))
+                          (call-with-output-string (lambda (out) (write b out)))))))
+
+      (test "sort numeric inexact vector <" '#(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9)
+        (sort '#(7.7 5.5 2.2 8.8 1.1 6.6 4.4 9.9 3.3) <))
+      (test "sort numeric signed inexact vector <"
+          '#(-9.9 -7.7 -5.5 -3.3 -1.1 2.2 4.4 6.6 8.8)
+        (sort '#(-7.7 -5.5 2.2 8.8 -1.1 6.6 4.4 -9.9 -3.3) <))
+      (test "sort numeric same whole number inexact vector"
+          '#(-5.2155
+             -4.3817
+             -4.3055
+             -4.0415
+             -3.5883
+             -3.5714
+             -3.4059
+             -2.7829
+             -2.6406
+             -2.4985
+             -2.4607
+             -1.2487
+             -0.537800000000001
+             -0.481999999999999
+             -0.469100000000001
+             -0.0932999999999993
+             0.0066999999999986)
+        (sort '#(-5.2155
+                 -3.5714
+                 -4.3817
+                 -3.5883
+                 -4.3055
+                 -2.4985
+                 -4.0415
+                 -3.4059
+                 -0.0932999999999993
+                 -0.537800000000001
+                 -2.6406
+                 -0.481999999999999
+                 -2.7829
+                 -2.4607
+                 -1.2487
+                 -0.469100000000001
+                 0.0066999999999986)
+              <))
+
+      (test "sort watson no dups"
+          '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+                     -0.300599999999999 -0.3003 -0.3002 -0.2942)
+        (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+                         -0.300599999999999 -0.2942 -0.3003 -0.3002)))
+
+      (test "sort watson"
+          '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+                     -0.300599999999999 -0.3003 -0.3003 -0.3002 -0.2942)
+        (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+                         -0.300599999999999 -0.2942 -0.3003 -0.3003 -0.3002)))
+
+      (test "sort ratios" '(1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5)
+        (sort '(1/2 1/3 1/4 1/5 2/3 3/4 2/5 3/5 4/5)))
+
+      (test "sort complex" '(1+1i 1+2i 1+3i 2+2i 3+3i 4+4i 5+5i 6+6i 7+7i 8+8i 9+9i)
+        (sort '(7+7i 1+2i 5+5i 2+2i 8+8i 1+1i 6+6i 4+4i 9+9i 1+3i 3+3i)))
+
+      (test-end))))

lib/srfi/99/test.sld

@@ -0,0 +1,221 @@
+(define-library (srfi 99 test)
+  (export run-tests)
+  (import (chibi)
+          (srfi 99)
+          (only (chibi test) test-begin test-assert test test-end))
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-99: records")
+
+      (define-record-type organism
+        (make-organism name)
+        organism?
+        (name name-of set-name-of!))
+
+      ;; kingdom
+      (define-record-type (animal organism)
+        (make-animal name food)
+        animal?
+        ;; all animals eat
+        (food food-of set-food-of!))
+
+      ;; phylum
+      (define-record-type (chordate animal)
+        (make-chordate name food)
+        chordate?)
+
+      ;; class
+      (define-record-type (mammal chordate)
+        (make-mammal name food num-nipples)
+        mammal?
+        ;; all mammals have nipples
+        (num-nipples num-nipples-of set-num-nipples-of!))
+
+      ;; order
+      (define-record-type (carnivore mammal)
+        (make-carnivore name food num-nipples)
+        carnivore?)
+
+      (define-record-type (rodent mammal)
+        (make-rodent name food num-nipples)
+        rodent?)
+
+      ;; family
+      (define-record-type (felidae carnivore)
+        (make-felidae name food num-nipples)
+        felidae?)
+
+      (define-record-type (muridae rodent)
+        (make-muridae name food num-nipples)
+        muridae?)
+
+      ;; genus
+      (define-record-type (felis felidae)
+        (make-felis name food num-nipples)
+        felis?)
+
+      (define-record-type (mus muridae)
+        (make-mus name food num-nipples)
+        mus?)
+
+      ;; species
+      (define-record-type (cat felis)
+        (make-cat name food num-nipples breed color)
+        cat?
+        (breed breed-of set-breed-of!)
+        (color color-of set-color-of!))
+
+      (define-record-type (mouse mus)
+        (make-mouse name food num-nipples)
+        mouse?)
+
+      (define mickey (make-mouse "Mickey" "cheese" 10))
+      (define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
+
+      (test-assert (organism? mickey))
+      (test-assert (animal? mickey))
+      (test-assert (chordate? mickey))
+      (test-assert (mammal? mickey))
+      (test-assert (rodent? mickey))
+      (test-assert (muridae? mickey))
+      (test-assert (mus? mickey))
+      (test-assert (mouse? mickey))
+
+      (test-assert (not (carnivore? mickey)))
+      (test-assert (not (felidae? mickey)))
+      (test-assert (not (felis? mickey)))
+      (test-assert (not (cat? mickey)))
+
+      (test-assert (organism? felix))
+      (test-assert (animal? felix))
+      (test-assert (chordate? felix))
+      (test-assert (mammal? felix))
+      (test-assert (carnivore? felix))
+      (test-assert (felidae? felix))
+      (test-assert (felis? felix))
+      (test-assert (cat? felix))
+
+      (test-assert (not (rodent? felix)))
+      (test-assert (not (muridae? felix)))
+      (test-assert (not (mus? felix)))
+      (test-assert (not (mouse? felix)))
+
+      (test "Mickey" (name-of mickey))
+      (test "cheese" (food-of mickey))
+      (test 10 (num-nipples-of mickey))
+
+      (test "Felix" (name-of felix))
+      (test mickey (food-of felix))
+      (test 8 (num-nipples-of felix))
+      (test 'mixed (breed-of felix))
+      (test '(and black white) (color-of felix))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (define-record-type person #t #t (name) (sex) (age))
+      (define-record-type (employee person) #t #t (department) (salary))
+
+      (define bob (make-employee "Bob" 'male 28 'hr 50000.0))
+      (define alice (make-employee "Alice" 'female 32 'research 100000.0))
+
+      (test-assert (person? bob))
+      (test-assert (employee? bob))
+      (test "Bob" (person-name bob))
+      (test 'male (person-sex bob))
+      (test 28 (person-age bob))
+      (test 'hr (employee-department bob))
+      (test 50000.0 (employee-salary bob))
+
+      (test-assert (person? alice))
+      (test-assert (employee? alice))
+      (test "Alice" (person-name alice))
+      (test 'female (person-sex alice))
+      (test 32 (person-age alice))
+      (test 'research (employee-department alice))
+      (test 100000.0 (employee-salary alice))
+
+      ;; After a trip to Thailand...
+      (person-sex-set! bob 'female)
+      (person-name-set! bob "Roberta")
+
+      ;; Then Roberta quits!
+      (employee-department-set! bob #f)
+      (employee-salary-set! bob 0.0)
+
+      (test "Roberta" (person-name bob))
+      (test 'female (person-sex bob))
+      (test 28 (person-age bob))
+      (test #f (employee-department bob))
+      (test 0.0 (employee-salary bob))
+
+      ;; SRFI-99 forbids this, but we currently do it anyway.
+      (test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
+                           (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
+
+      (test-assert (record? alice))
+      (test 'person (rtd-name person))
+      (let* ((constructor (rtd-constructor person))
+             (trent (constructor "Trent" 'male 44)))
+        (test "Trent" (person-name trent))
+        (test 'male (person-sex trent))
+        (test 44 ((rtd-accessor person 'age) trent))
+        ((rtd-mutator person 'age) trent 45)
+        (test 45 (person-age trent)))
+
+      (test-assert (rtd-field-mutable? employee 'department))
+
+      ;; We do not retain mutability information ATM.
+      ;; (define-record-type foo
+      ;;   (make-foo x)
+      ;;   foo?
+      ;;   (x foo-x))
+      ;;
+      ;; (test-assert (not (rtd-field-mutable? foo 'x)))
+
+      (define point (make-rtd "point" #(x y)))
+      (define make-point (rtd-constructor point #(x y)))
+      (define point-x (rtd-accessor point 'x))
+      (test 3 (point-x (make-point 3 2)))
+
+      ;; Name conflicts - make sure we rename 
+
+      (define-record-type example make-example #t example)
+      (test-assert (example? (make-example 3)))
+      (test 3 (example-example (make-example 3)))
+
+      ;; record types definitions with #f passed as either the constructor or
+      ;; predicate argument should not create the corresponding function
+
+      (define-record-type abstract
+        #f #t)
+
+      (test #f (memq 'make-abstract (env-exports (current-environment))))
+
+      (define-record-type (derived abstract)
+        #t #f)
+
+      (define instance (make-derived))
+      (test-assert (abstract? instance))
+      (test #f (memq 'derived? (env-exports (current-environment))))
+
+      (define-record-type container
+        #t #t
+        default-immutable
+        (default-mutable)
+        (named-immutable get-container-immutable)
+        (named-mutable get-container-mutable set-container-mutable!))
+
+      (define container-instance (make-container 1 2 3 4))
+
+      (test 1 (container-default-immutable container-instance))
+      (test 2 (container-default-mutable container-instance))
+      (test 3 (get-container-immutable container-instance))
+      (test 4 (get-container-mutable container-instance))
+
+      (container-default-mutable-set! container-instance #t)
+      (test #t (container-default-mutable container-instance))
+
+      (set-container-mutable! container-instance #t)
+      (test #t (get-container-mutable container-instance))
+
+      (test-end))))

tests/base64-tests.scm

@@ -1,40 +0,0 @@
-
-(import (chibi) (chibi base64) (chibi test))
-
-(test-begin "base64")
-
-(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
-    (base64-encode-string "any carnal pleasure."))
-(test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
-    (base64-encode-string "any carnal pleasure"))
-(test "YW55IGNhcm5hbCBwbGVhc3Vy"
-    (base64-encode-string "any carnal pleasur"))
-(test "YW55IGNhcm5hbCBwbGVhc3U="
-    (base64-encode-string "any carnal pleasu"))
-(test "YW55IGNhcm5hbCBwbGVhcw=="
-    (base64-encode-string "any carnal pleas"))
-
-(test "any carnal pleas"
-    (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
-(test "any carnal pleasu"
-    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
-(test "any carnal pleasur"
-    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
-(test "any carnal pleas"
-    (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
-(test "any carnal pleasu"
-    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
-
-(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
-    (call-with-output-string
-      (lambda (out)
-        (call-with-input-string "any carnal pleasure."
-          (lambda (in) (base64-encode in out))))))
-
-(test "any carnal pleasure."
-    (call-with-output-string
-      (lambda (out)
-        (call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
-          (lambda (in) (base64-decode in out))))))
-
-(test-end)

tests/filesystem-tests.scm

@@ -1,74 +0,0 @@
-
-(import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
-
-(test-begin "filesystem")
-
-(define tmp-file "/tmp/chibi-fs-test-0123456789")
-(define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
-(define tmp-link "/tmp/chibi-fs-test-0123456789-link")
-(define tmp-dir "/tmp/chibi-fs-test-0123456789-dir")
-
-(call-with-output-file tmp-file
-  (lambda (out) (display "0123456789" out)))
-
-(test-assert (file-exists? tmp-file))
-(test "0123456789" (call-with-input-file tmp-file port->string))
-
-;; call-with-output-file truncates
-(call-with-output-file tmp-file
-  (lambda (out) (display "xxxxx" out)))
-(test "xxxxx" (call-with-input-file tmp-file port->string))
-
-(call-with-output-file tmp-file
-  (lambda (out) (display "0123456789" out)))
-(test "0123456789" (call-with-input-file tmp-file port->string))
-
-;; open without open/truncate writes in place
-(let* ((fd (open tmp-file open/write))
-       (out (open-output-file-descriptor fd)))
-  (display "xxxxx" out)
-  (close-output-port out))
-(test "xxxxx56789" (call-with-input-file tmp-file port->string))
-
-;; file-truncate can explicitly truncate
-(let* ((fd (open tmp-file open/write))
-       (out (open-output-file-descriptor fd)))
-  (display "01234" out)
-  (file-truncate out 7)
-  (close-output-port out))
-(test "0123456" (call-with-input-file tmp-file port->string))
-
-;; symbolic links
-(test-assert (symbolic-link-file tmp-file tmp-link))
-(test-assert (file-exists? tmp-link))
-(test-assert (file-link? tmp-link))
-(test tmp-file (read-link tmp-link))
-
-;; rename
-(test-assert (rename-file tmp-file tmp-file2))
-(test-not (file-exists? tmp-file))
-(test-not (file-exists? tmp-link))
-(test-assert (file-link? tmp-link))
-(test-assert (delete-file tmp-link))
-(test-not (file-exists? tmp-link))
-
-;; cleanup
-(test-assert (delete-file tmp-file2))
-(test-not (file-exists? tmp-file2))
-
-;; directories
-(test-assert (file-directory? "."))
-(test-assert (file-directory? ".."))
-(test-assert (file-directory? "/"))
-(test-not (file-regular? "."))
-(test-assert (create-directory tmp-dir))
-(test-assert (file-directory? tmp-dir))
-(test-not (file-regular? tmp-dir))
-(test-assert
-  (let ((files (directory-files tmp-dir)))
-    (or (equal? files '("." ".."))
-        (equal? files '(".." ".")))))
-(test-assert (delete-directory tmp-dir))
-(test-not (file-directory? tmp-dir))
-
-(test-end)

tests/generic-tests.scm

@@ -1,35 +0,0 @@
-
-(import (chibi) (chibi generic) (chibi test))
-
-(test-begin "generics")
-
-(let ()
-  (define-generic add)
-  (define-method (add (x number?) (y number?))
-    (+ x y))
-  (define-method (add (x string?) (y string?))
-    (string-append x y))
-  (define-method (add x (y list?))
-    (append x y))
-  (test 4 (add 2 2))
-  (test "22" (add "2" "2"))
-  (test '(2 2) (add '() '(2 2)))
-  (test '(2 2) (add '(2) '(2)))
-  (test '(2 2) (add '(2 2) '()))
-  (test '(2) (add #f '(2)))
-  (test-error (add #(2) #(2))))
-
-(let ()
-  (define-generic mul)
-  (define-method (mul (x number?) (y number?))
-    (* x y))
-  (define-method (mul (x inexact?) (y inexact?))
-    (+ (* x y) 0.1))
-  (define-method (mul (x exact?) (y exact?))
-    (inexact->exact (call-next-method)))
-  (test 21 (mul 3 7))
-  (test 21.0 (mul 3.0 7))
-  (test 21.0 (mul 3 7.0))
-  (test 21.1 (mul 3.0 7.0)))
-
-(test-end)

tests/hash-tests.scm

@@ -1,182 +0,0 @@
-
-(cond-expand
- (modules (import (srfi 1) (srfi 69) (chibi test)))
- (else #f))
-
-(test-begin "hash")
-
-(define-syntax test-lset-eq?
-  (syntax-rules ()
-    ((test-lset= . args)
-     (test-equal (lambda (a b) (lset= eq? a b)) . args))))
-
-(define-syntax test-lset-equal?
-  (syntax-rules ()
-    ((test-lset-equal? . args)
-     (test-equal (lambda (a b) (lset= equal? a b)) . args))))
-
-(let ((ht (make-hash-table eq?)))
-  ;; 3 initial elements
-  (test 0 (hash-table-size ht))
-  (hash-table-set! ht 'cat 'black)
-  (hash-table-set! ht 'dog 'white)
-  (hash-table-set! ht 'elephant 'pink)
-  (test 3 (hash-table-size ht))
-  (test-assert (hash-table-exists? ht 'dog))
-  (test-assert (hash-table-exists? ht 'cat))
-  (test-assert (hash-table-exists? ht 'elephant))
-  (test-not (hash-table-exists? ht 'goose))
-  (test 'white (hash-table-ref ht 'dog))
-  (test 'black (hash-table-ref ht 'cat))
-  (test 'pink (hash-table-ref ht 'elephant))
-  (test-error (hash-table-ref ht 'goose))
-  (test 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
-  (test 'grey (hash-table-ref/default ht 'goose 'grey))
-  (test-lset-eq? '(cat dog elephant) (hash-table-keys ht))
-  (test-lset-eq? '(black white pink) (hash-table-values ht))
-  (test-lset-equal? '((cat . black) (dog . white) (elephant . pink))
-                    (hash-table->alist ht))
-
-  ;; remove an element
-  (hash-table-delete! ht 'dog)
-  (test 2 (hash-table-size ht))
-  (test-not (hash-table-exists? ht 'dog))
-  (test-assert (hash-table-exists? ht 'cat))
-  (test-assert (hash-table-exists? ht 'elephant))
-  (test-error (hash-table-ref ht 'dog))
-  (test 'black (hash-table-ref ht 'cat))
-  (test 'pink (hash-table-ref ht 'elephant))
-  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
-  (test-lset-eq? '(black pink) (hash-table-values ht))
-  (test-lset-equal? '((cat . black) (elephant . pink)) (hash-table->alist ht))
-
-  ;; remove a non-existing element
-  (hash-table-delete! ht 'dog)
-  (test 2 (hash-table-size ht))
-  (test-not (hash-table-exists? ht 'dog))
-
-  ;; overwrite an existing element
-  (hash-table-set! ht 'cat 'calico)
-  (test 2 (hash-table-size ht))
-  (test-not (hash-table-exists? ht 'dog))
-  (test-assert (hash-table-exists? ht 'cat))
-  (test-assert (hash-table-exists? ht 'elephant))
-  (test-error (hash-table-ref ht 'dog))
-  (test 'calico (hash-table-ref ht 'cat))
-  (test 'pink (hash-table-ref ht 'elephant))
-  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
-  (test-lset-eq? '(calico pink) (hash-table-values ht))
-  (test-lset-equal? '((cat . calico) (elephant . pink)) (hash-table->alist ht))
-
-  ;; walk and fold
-  (test-lset-equal?
-   '((cat . calico) (elephant . pink))
-   (let ((a '()))
-     (hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
-     a))
-  (test-lset-equal? '((cat . calico) (elephant . pink))
-                    (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '()))
-
-  ;; copy
-  (let ((ht2 (hash-table-copy ht)))
-    (test 2 (hash-table-size ht2))
-    (test-not (hash-table-exists? ht2 'dog))
-    (test-assert (hash-table-exists? ht2 'cat))
-    (test-assert (hash-table-exists? ht2 'elephant))
-    (test-error (hash-table-ref ht2 'dog))
-    (test 'calico (hash-table-ref ht2 'cat))
-    (test 'pink (hash-table-ref ht2 'elephant))
-    (test-lset-eq? '(cat elephant) (hash-table-keys ht2))
-    (test-lset-eq? '(calico pink) (hash-table-values ht2))
-    (test-lset-equal? '((cat . calico) (elephant . pink))
-                      (hash-table->alist ht2)))
-
-  ;; merge
-  (let ((ht2 (make-hash-table eq?)))
-    (hash-table-set! ht2 'bear 'brown)
-    (test 1 (hash-table-size ht2))
-    (test-not (hash-table-exists? ht2 'dog))
-    (test-assert (hash-table-exists? ht2 'bear))
-    (hash-table-merge! ht2 ht)
-    (test 3 (hash-table-size ht2))
-    (test-assert (hash-table-exists? ht2 'bear))
-    (test-assert (hash-table-exists? ht2 'cat))
-    (test-assert (hash-table-exists? ht2 'elephant))
-    (test-not (hash-table-exists? ht2 'goose))
-    (test 'brown (hash-table-ref ht2 'bear))
-    (test 'calico (hash-table-ref ht2 'cat))
-    (test 'pink (hash-table-ref ht2 'elephant))
-    (test-error (hash-table-ref ht2 'goose))
-    (test 'grey (hash-table-ref/default ht2 'goose 'grey))
-    (test-lset-eq? '(bear cat elephant) (hash-table-keys ht2))
-    (test-lset-eq? '(brown calico pink) (hash-table-values ht2))
-    (test-lset-equal? '((cat . calico) (bear . brown) (elephant . pink))
-                      (hash-table->alist ht2)))
-
-  ;; alist->hash-table
-  (test-lset-equal? (hash-table->alist ht)
-                    (hash-table->alist
-                     (alist->hash-table
-                      '((cat . calico) (elephant . pink))))))
-
-;; update
-(let ((ht (make-hash-table eq?))
-      (add1 (lambda (x) (+ x 1))))
-  (hash-table-set! ht 'sheep 0)
-  (hash-table-update! ht 'sheep add1)
-  (hash-table-update! ht 'sheep add1)
-  (test 2 (hash-table-ref ht 'sheep))
-  (hash-table-update!/default ht 'crows add1 0)
-  (hash-table-update!/default ht 'crows add1 0)
-  (hash-table-update!/default ht 'crows add1 0)
-  (test 3 (hash-table-ref ht 'crows)))
-
-;; string keys
-(let ((ht (make-hash-table equal?)))
-  (hash-table-set! ht "cat" 'black)
-  (hash-table-set! ht "dog" 'white)
-  (hash-table-set! ht "elephant" 'pink)
-  (hash-table-ref/default ht "dog" #f)
-  (test 'white (hash-table-ref ht "dog"))
-  (test 'black (hash-table-ref ht "cat"))
-  (test 'pink (hash-table-ref ht "elephant"))
-  (test-error (hash-table-ref ht "goose"))
-  (test 'grey (hash-table-ref/default ht "goose" 'grey))
-  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
-  (test-lset-equal? '(black white pink) (hash-table-values ht))
-  (test-lset-equal?
-   '(("cat" . black) ("dog" . white) ("elephant" . pink))
-   (hash-table->alist ht)))
-
-;; string-ci keys
-(let ((ht (make-hash-table string-ci=? string-ci-hash)))
-  (hash-table-set! ht "cat" 'black)
-  (hash-table-set! ht "dog" 'white)
-  (hash-table-set! ht "elephant" 'pink)
-  (hash-table-ref/default ht "DOG" #f)
-  (test 'white (hash-table-ref ht "DOG"))
-  (test 'black (hash-table-ref ht "Cat"))
-  (test 'pink (hash-table-ref ht "eLePhAnT"))
-  (test-error (hash-table-ref ht "goose"))
-  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
-  (test-lset-equal? '(black white pink) (hash-table-values ht))
-  (test-lset-equal?
-   '(("cat" . black) ("dog" . white) ("elephant" . pink))
-   (hash-table->alist ht)))
-
-;; Exception values - this works because the return value from the
-;; primitives is a cell, and we use the cdr opcode to retrieve the
-;; cell value.  Thus there is no FFI issue with storing exceptions.
-(let ((ht (make-hash-table)))
-  (hash-table-set! ht 'boom (make-exception 'my-exn-type "boom!" '() #f #f))
-  (test 'my-exn-type (exception-kind (hash-table-ref ht 'boom))))
-
-;; stress test
-(test 625
- (let ((ht (make-hash-table)))
-   (do ((i 0 (+ i 1))) ((= i 1000))
-     (hash-table-set! ht i (* i i)))
-   (hash-table-ref/default ht 25 #f)))
-
-(test-end)
-

tests/io-tests.scm

@@ -1,163 +0,0 @@
-
-(cond-expand
- (modules
-  (import (chibi io)
-          (only (scheme base) read-bytevector write-bytevector)
-          (only (chibi test) test-begin test test-end)))
- (else #f))
-
-(test-begin "io")
-
-(define long-string (make-string 2000 #\a))
-
-(test "input-string-port" 1025
-  (call-with-input-string (substring long-string 0 1025)
-    (lambda (in)
-      (let loop ((c (read-char in)) (i 0))
-        (cond ((eof-object? c) i)
-              ((> i 1025) (error "read past eof"))
-              (else (loop (read-char in) (+ i 1))))))))
-
-(test "read-line" '("abc" "def")
-  (call-with-input-string "abc\ndef\n"
-    (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
-
-(test "read-line" '("abc" "def" "ghi")
-  (call-with-input-string "abcdef\nghi\n"
-    (lambda (in)
-      (let* ((line1 (read-line in 3))
-             (line2 (read-line in 3)))
-        (list line1 line2 (read-line in 3))))))
-
-(test "read-line-to-eof" '("abc" "def")
-  (call-with-input-string "abc\ndef"
-    (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
-
-(test "read-string" '("abc" "def")
-  (call-with-input-string "abcdef"
-    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
-
-(test "read-string-to-eof" '("abc" "de")
-  (call-with-input-string "abcde"
-    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
-
-(test "read-string" '("ab日" "本語f")
-  (call-with-input-string "ab日本語f"
-    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
-
-(test "read-string!" '("abc" "def")
-  (call-with-input-string "abcdef"
-    (lambda (in)
-      (let* ((str1 (make-string 3))
-             (str2 (make-string 3)))
-        (read-string! str1 3 in)
-        (read-string! str2 3 in)
-        (list str1 str2)))))
-
-(test "read-string!-to-eof" '("abc" "de ")
-  (call-with-input-string "abcde"
-    (lambda (in)
-      (let* ((str1 (make-string 3))
-             (str2 (make-string 3 #\space)))
-        (read-string! str1 3 in)
-        (read-string! str2 3 in)
-        (list str1 str2)))))
-
-(test "null-output-port" #t
-  (let ((out (make-null-output-port)))
-    (write 1 out)
-    (close-output-port out)
-    #t))
-
-(test "null-input-port" #t
-  (let ((in (make-null-input-port)))
-    (let ((res (eof-object? (read-char in))))
-      (close-input-port in)
-      res)))
-
-(define (string-upcase str)
-  (list->string (map char-upcase (string->list str))))
-
-(test "upcase-input-port" "ABC"
-  (call-with-input-string "abc"
-    (lambda (in)
-      (let ((in (make-filtered-input-port string-upcase in)))
-        (let ((res (read-line in)))
-          (close-input-port in)
-          res)))))
-
-(test "upcase-output-port" "ABC"
-  (call-with-output-string
-    (lambda (out)
-      (let ((out (make-filtered-output-port string-upcase out)))
-        (display "abc" out)
-        (close-output-port out)))))
-
-(define (strings->input-port str-ls)
-  (make-generated-input-port
-   (lambda ()
-     (and (pair? str-ls)
-          (let ((res (car str-ls)))
-            (set! str-ls (cdr str-ls))
-            res)))))
-
-(test "abcdef" (read-line (strings->input-port '("abcdef"))))
-(test "abcdef" (read-line (strings->input-port '("abc" "def"))))
-(test "abcdef" (read-line (strings->input-port '("a" "b" "c" "d" "e" "f"))))
-(test "日本語" (read-line (strings->input-port '("日本語"))))
-(test "日本語" (read-line (strings->input-port '("日" "本" "語"))))
-(test "abc"
-    (let ((in (strings->input-port
-               (list "日本語" (make-string 4087 #\-) "abc"))))
-      (read-string 4090 in)
-      (read-line in)))
-(test "abc"
-    (let ((in (strings->input-port
-               (list "日本語" (make-string 4087 #\本) "abc"))))
-      (read-string 4090 in)
-      (read-line in)))
-(test "abc"
-    (let ((in (strings->input-port
-               (list "日本語" (make-string 4093 #\-) "abc"))))
-      (read-string 4096 in)
-      (read-line in)))
-
-(let ((in (make-custom-binary-input-port
-           (let ((i 0))
-             (lambda (bv start end)
-               (do ((j start (+ j 1)))
-                   ((= j end))
-                 (bytevector-u8-set! bv j (modulo (+ j i) 256)))
-               (if (> end 0)
-                   (set! i (bytevector-u8-ref bv (- end 1))))
-               (- end start))))))
-  (test #u8(0 1 2 3) (read-bytevector 4 in))
-  (test #u8(4 5 6 7) (read-bytevector 4 in))
-  (test 7 (bytevector-u8-ref (read-bytevector 256 in) 255))
-  (test 6 (bytevector-u8-ref (read-bytevector 1024 in) 1022)))
-
-(let* ((sum 0)
-       (out (make-custom-binary-output-port
-             (lambda (bv start end)
-               (do ((i start (+ i 1))
-                    (x 0 (+ x (bytevector-u8-ref bv i))))
-                   ((= i end) (set! sum x)))))))
-  (write-bytevector #u8(0 1 2 3) out)
-  (flush-output out)
-  (test 6 sum)
-  (write-bytevector #u8(100) out)
-  (flush-output out)
-  (test 106 sum))
-
-(test "file-position"
-    '(0 1 2)
-  (let* ((p (open-input-file "tests/io-tests.scm"))
-         (t0 (file-position p)))
-    (read-char p)
-    (let ((t1 (file-position p)))
-      (read-char p)
-      (let ((t2 (file-position p)))
-        (close-input-port p)
-        (list t0 t1 t2)))))
-
-(test-end)

tests/iset-tests.scm

@@ -1,197 +0,0 @@
-
-(cond-expand
- (modules
-  (import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test)))
- (else #f))
-
-(define (test-name iset op)
-  (call-with-output-string
-    (lambda (out)
-      (let* ((ls (iset->list iset))
-             (ls (if (> (length ls) 10)
-                     `(,@(take ls 5) ... ,@(take-right ls 5))
-                     ls)))
-        (write `(,(car op) (iset ,@ls) ,@(cdr op)) out)))))
-
-(test-begin "iset")
-
-;; Tests to perform repeated operations on an iset.  The first element
-;; in each list is a list of integers to initialize the set `is', which
-;; we generate and verify the size and round-trip list conversion.
-;; Subsequent elements are abbreviated operations on is:
-;;
-;;   (+ a ...)     (iset-adjoin! a) ...
-;;   (- a ...)     (iset-delete! a) ...
-;;   (= a ...)     (test (list a ...) (iset->list is))
-;;   (<= a ...)    (test-assert (iset<= is (iset a ...)))
-;;   (? a ...)     (test-assert (iset-contains? is a)) ...
-;;   (!? a ...)    (test-not (iset-contains? is a)) ...
-;;   (u a ...)     (iset-union is (iset a ...))
-;;   (u: a b)      (iset-union is (make-iset a b))
-;;   (i a ...)     (iset-intersection is (iset a ...))
-;;   (d a ...)     (iset-difference is (iset a ...))
-;;   (m f)         (iset-map f is)
-;;   (s size)      (test size (iset-size iset))
-;;   (z [empty?])  (test empty? (iset-empty? iset))
-(let ((tests
-       `(;; construction
-         ((1 128 127))
-         ((129 2 127))
-         ((1 -128 -126))
-         ((1 2 3 1000 1005))
-         ((97308 97827 97845 97827))
-         ((1 2 3 4 5 6 7 8))
-         ((2 3 4 5 6 7 8))
-         ((1 3 4 5 6 7 8))
-         ((1 2 4 5 6 7 8))
-         ((1 2 3 5 6 7 8))
-         ((1 2 3 4 6 7 8))
-         ((1 2 3 4 5 7 8))
-         ((1 2 3 4 5 6 8))
-         ((1 2 3 4 5 6 7))
-         ;; ordering
-         ((97) (<= 97 117))
-         ((117) (<= 97 117))
-         ;; individual elements
-         (() (+ 99) (u 3 50) (? 99))
-         (() (+ 1) (+ 1000) (+ -1000) (+ 3) (+ -1))
-         ((0) (z #f) (- 0) (z))
-         ((0 1 2) (- 1) (- 2) (? 0))
-         ;; union
-         ((17 29) (u 7 29))
-         ((2 3 4) (u 1 2 3 4 5))
-         ((1 2 3 4 5) (u 2 3 4))
-         ((1 2 3 1000 2000) (u 1 4))
-         ((1 3) (u 1 4) (= 1 3 4))
-         ((1 3) (u 3 4) (= 1 3 4))
-         ((1) (u 1 3) (= 1 3))
-         ((3) (u 1 3) (= 1 3))
-         ((1 4) (u 3 4 5) (= 1 3 4 5))
-         ((1 2 3 4) (u 5 6 7 8) (= 1 2 3 4 5 6 7 8))
-         ((1 3 4) (u 5 6 7 8) (= 1 3 4 5 6 7 8))
-         ((1 2 4) (u 5 6 7 8) (= 1 2 4 5 6 7 8))
-         ((1 2 3) (u 5 6 7 8) (= 1 2 3 5 6 7 8))
-         ((1 2 3 4) (u 6 7 8) (= 1 2 3 4 6 7 8))
-         ((1 2 3 4) (u 5 7 8) (= 1 2 3 4 5 7 8))
-         ((1 2 3 4) (u 5 6 8) (= 1 2 3 4 5 6 8))
-         ((1 2 3) (u 6 7 8) (= 1 2 3 6 7 8))
-         ((1 3) (u 6 8) (= 1 3 6 8))
-         ((1 2 3 4 1001 1002)
-          (u 1003 1004 2001 2002 2003 2004)
-          (= 1 2 3 4 1001 1002 1003 1004 2001 2002 2003 2004))
-         ((1 2 4 1001 1002)
-          (u 1003 1004 2001 2002 2003 2004)
-          (= 1 2 4 1001 1002 1003 1004 2001 2002 2003 2004))
-         ((1 2 3 4 1001 1002)
-          (u 1004 2001 2002 2003 2004)
-          (= 1 2 3 4 1001 1002 1004 2001 2002 2003 2004))
-         ((1 2 3 4 1001 1002)
-          (u 1003 1004 2001 2003 2004)
-          (= 1 2 3 4 1001 1002 1003 1004 2001 2003 2004))
-         (() (u: 349 680) (u: 682 685))
-         (() (u: 64434 64449) (u: 65020 65021) (u #xFE62))
-         (() (u: 716 747) (u: 750 1084))
-         (() (u: 48 57) (u: 65 90) (u: 97 122) (u 45 46 95 126) (? 119))
-         ;; intersection
-         ((1 2 3 4 5) (i 1) (= 1))
-         ((1 2 3 4 5) (i 1 2) (= 1 2))
-         ((1 2 3 4 5) (i 1 2 3) (= 1 2 3))
-         ((1 2 3 4 5) (i 2 3) (= 2 3))
-         ((1 2 3 4 5) (i 2 3 4) (= 2 3 4))
-         ((1 2 3 4 5) (i 5) (= 5))
-         ((1 2 3 4 5) (i 4 5) (= 4 5))
-         ((1 2 3 4 5) (i 1 2 3 4 5) (= 1 2 3 4 5))
-         ((1 2 3 4 5) (i 0 1 5 6) (= 1 5))
-         ;; difference
-         ((1 2 3 4 5) (d 1) (!? 0) (? 2 3 4 5) (!? 6))
-         ((1 2 3 4 5) (d 1 2) (!? 0) (? 3 4 5) (!? 6))
-         ((1 2 3 4 5) (d 1 2 3) (!? 0) (? 4 4) (!? 6))
-         ((1 2 3 4 5) (d 2 3) (!? 0) (? 1 4 5) (!? 6))
-         ((1 2 3 4 5) (d 2 3 4) (!? 0) (? 1 5) (!? 6))
-         ((1 2 3 4 5) (d 5) (!? 0) (? 1 2 3 4) (!? 6))
-         ((1 2 3 4 5) (d 4 5) (!? 0) (? 1 2 3) (!? 6))
-         ((1 2 3 4 5) (d 1 2 3 4 5) (z))
-         ((1 2 3 4 5) (d 0 1 5 6) (? 2 3 4))
-         ;; map
-         ((1 2 3) (m ,(lambda (x) (+ x 1))) (= 2 3 4))
-         )))
-  (for-each
-   (lambda (tst)
-     (let* ((ls (car tst))
-            (is (list->iset ls))
-            (ls2 (delete-duplicates ls =)))
-       ;; initial creation and sanity checks
-       (test-assert (lset= equal? ls2 (iset->list is)))
-       (test (length ls2) (iset-size is))
-       (test-assert (call-with-output-string
-                      (lambda (out)
-                        (display "init: " out)
-                        (write ls out)))
-           (every
-            (lambda (x) (iset-contains? is x))
-            ls))
-       (test (iset-contains? is 42) (member 42 ls))
-       ;; additional operations
-       (for-each
-        (lambda (op)
-          (let ((name (test-name is op)))
-            (case (car op)
-              ((+)
-               (for-each
-                (lambda (x) (iset-adjoin! is x))
-                (cdr op))
-               (test-assert name (iset-contains? is (cadr op))))
-              ((-)
-               (for-each
-                (lambda (x) (iset-delete! is x))
-                (cdr op))
-               (test-assert name (not (iset-contains? is (cadr op)))))
-              ((=)
-               (test name (cdr op) (iset->list is))
-               (test-assert name (iset= (list->iset (cdr op)) is)))
-              ((<=)
-               (test-assert name (iset<= is (list->iset (cdr op)))))
-              ((?)
-               (test-assert name
-                 (every (lambda (x) (iset-contains? is x)) (cdr op))))
-              ((!?)
-               (test-assert name
-                 (every (lambda (x) (not (iset-contains? is x))) (cdr op))))
-              ((d)
-               (set! is (iset-difference is (list->iset (cdr op))))
-               (test-assert name
-                 (every
-                  (lambda (x) (not (iset-contains? is x)))
-                  (cdr op))))
-              ((i) (set! is (iset-intersection is (list->iset (cdr op)))))
-              ((u u:)
-               (let ((arg (cond ((eq? 'u: (car op))
-                                 (make-iset (cadr op) (car (cddr op))))
-                                ((iset? (cadr op)) (cadr op))
-                                (else (list->iset (cdr op))))))
-                 (set! is (iset-union is arg)))
-               (test-assert name
-                 (every (lambda (x)
-                          (or (not (integer? x))
-                              (iset-contains? is x)))
-                        (cdr op))))
-              ((m) (set! is (iset-map (cadr op) is)))
-              ((s) (test (iset-size is) (cadr op)))
-              ((z) (test (iset-empty? is) (if (pair? (cdr op)) (cadr op) #t)))
-              (else (error "unknown operation" (car op))))))
-        (cdr tst))
-       ;; optimization
-       (let* ((is2 (iset-optimize is))
-              (is3 (iset-balance is))
-              (is4 (iset-balance is2)))
-         (test-assert (iset= is is2))
-         (test-assert (iset= is is3))
-         (test-assert (iset= is is4)))))
-   tests))
-
-(let ((a (%make-iset 65 90 #f #f (%make-iset 97 122 #f #f #f)))
-      (b (list->iset '(45 46 95 126))))
-  (test-assert (iset-contains? (iset-union a b) 119))
-  (test-assert (iset-contains? (iset-union b a) 119))) 
-
-(test-end)

tests/lib-tests.scm

@@ -1,51 +1,65 @@
 
-(cond-expand
+(import (scheme base)
- (modules (import (only (chibi) load)
+        (chibi test)
-                  (only (chibi test) test-begin test-end)))
+        (rename (srfi 1 test) (run-tests run-srfi-1-tests))
- (else (load "tests/r5rs-tests.scm")))
+        (rename (srfi 2 test) (run-tests run-srfi-2-tests))
+        (rename (srfi 16 test) (run-tests run-srfi-16-tests))
+        (rename (srfi 18 test) (run-tests run-srfi-18-tests))
+        (rename (srfi 26 test) (run-tests run-srfi-26-tests))
+        (rename (srfi 27 test) (run-tests run-srfi-27-tests))
+        (rename (srfi 38 test) (run-tests run-srfi-38-tests))
+        (rename (srfi 69 test) (run-tests run-srfi-69-tests))
+        (rename (srfi 95 test) (run-tests run-srfi-95-tests))
+        (rename (srfi 99 test) (run-tests run-srfi-99-tests))
+        (rename (chibi base64-test) (run-tests run-base64-tests))
+        (rename (chibi crypto md5-test) (run-tests run-md5-tests))
+        (rename (chibi crypto rsa-test) (run-tests run-rsa-tests))
+        (rename (chibi crypto sha2-test) (run-tests run-sha2-tests))
+        (rename (chibi io-test) (run-tests run-io-tests))
+        (rename (chibi iset-test) (run-tests run-iset-tests))
+        (rename (chibi loop-test) (run-tests run-loop-tests))
+        (rename (chibi match-test) (run-tests run-match-tests))
+        (rename (chibi math prime-test) (run-tests run-prime-tests))
+        (rename (chibi mime-test) (run-tests run-mime-tests))
+        (rename (chibi parse-test) (run-tests run-parse-tests))
+        (rename (chibi process-test) (run-tests run-process-tests))
+        (rename (chibi regexp-test) (run-tests run-regexp-tests))
+        (rename (chibi scribble-test) (run-tests run-scribble-tests))
+        (rename (chibi system-test) (run-tests run-system-tests))
+        (rename (chibi tar-test) (run-tests run-tar-tests))
+        (rename (chibi term ansi-test) (run-tests run-term-ansi-tests))
+        (rename (chibi uri-test) (run-tests run-uri-tests))
+        )
 
 (test-begin "libraries")
 
-(load "tests/srfi-1-tests.scm")
+(run-srfi-1-tests)
-(load "tests/srfi-2-tests.scm")
+(run-srfi-2-tests)
-(load "tests/srfi-16-tests.scm")
+(run-srfi-16-tests)
-(load "tests/srfi-26-tests.scm")
+(run-srfi-18-tests)
-(load "tests/srfi-27-tests.scm")
+(run-srfi-26-tests)
-(load "tests/srfi-38-tests.scm")
+(run-srfi-27-tests)
-(load "tests/flonum-tests.scm")
+(run-srfi-38-tests)
-(load "tests/numeric-tests.scm")
+(run-srfi-69-tests)
-(load "tests/loop-tests.scm")
+(run-srfi-95-tests)
-(load "tests/match-tests.scm")
+(run-srfi-99-tests)
-(load "tests/scribble-tests.scm")
+(run-base64-tests)
-(load "tests/string-tests.scm")
+(run-io-tests)
-(load "tests/iset-tests.scm")
+(run-iset-tests)
-(load "tests/uri-tests.scm")
+(run-loop-tests)
-(load "tests/mime-tests.scm")
+(run-match-tests)
-(load "tests/regexp-tests.scm")
+(run-md5-tests)
-(load "tests/prime-tests.scm")
+(run-mime-tests)
-(load "tests/md5-tests.scm")
+(run-parse-tests)
-(load "tests/sha-tests.scm")
+(run-prime-tests)
-;; (load "tests/rsa-tests.scm")
+(run-process-tests)
-(load "tests/tar-tests.scm")
+(run-regexp-tests)
-(load "tests/term-ansi-tests.scm")
+(run-rsa-tests)
-(cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f))
+(run-scribble-tests)
-
+(run-sha2-tests)
-(cond-expand
+(run-system-tests)
- (modules
+(run-tar-tests)
-  (load "tests/record-tests.scm")
+(run-term-ansi-tests)
-  (load "tests/hash-tests.scm")
+(run-uri-tests)
-  (load "tests/sort-tests.scm")
-  (load "tests/parse-tests.scm")
-  ;; (load "tests/weak-tests.scm")
-  (load "tests/io-tests.scm")
-  (load "tests/process-tests.scm")
-  (load "tests/system-tests.scm")
-  )
- (else #f))
-
-(cond-expand
- ((and modules threads)
-  (load "tests/thread-tests.scm"))
- (else #f))
 
 (test-end)

tests/loop-tests.scm

@@ -1,170 +0,0 @@
-
-(cond-expand
- (modules (import (chibi loop) (only (chibi test) test-begin test test-end)))
- (else (load "lib/chibi/loop/loop.scm")))
-
-(test-begin "loops")
-
-(test
- "stepping"
- '(0 1 2)
- (loop lp ((with i 0 (+ i 1))
-           (with res '() (cons i res)))
-   (if (= i 3)
-     (reverse res)
-     (lp))))
-
-(test
- "basic in-list"
- '(c b a)
- (let ((res '()))
-   (loop ((for x (in-list '(a b c))))
-     (set! res (cons x res)))
-   res))
-
-(test
- "in-list with result"
- '(c b a)
- (loop ((for x (in-list '(a b c)))
-        (with res '() (cons x res)))
-   => res))
-
-(test
- "in-list with listing"
- '(a b c)
- (loop ((for x (in-list '(a b c))) (for res (listing x))) => res))
-
-(test
- "in-list with listing-reverse"
- '(c b a)
- (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res))
-
-(test
- "uneven length in-list's"
- '((a . 1) (b . 2) (c . 3))
- (loop ((for x (in-list '(a b c)))
-        (for y (in-list '(1 2 3 4)))
-        (for res (listing (cons x y))))
-    => res))
-
-(test
- "in-lists"
- '((a 1) (b 2) (c 3))
- (loop ((for ls (in-lists '((a b c) (1 2 3))))
-        (for res (listing ls)))
-   => res))
-
-(define (flatten ls)
-  (reverse
-   (loop lp ((for x ls (in-list ls)) (with res '()))
-     => res
-     (if (pair? x)
-         (lp (=> res (lp (=> ls x))))
-         (lp (=> res (cons x res)))))))
-
-(test
- "flatten (recursion test)"
- '(1 2 3 4 5 6 7)
- (flatten '(1 (2) (3 (4 (5)) 6) 7)))
-
-(test
- "in-string"
- '(#\h #\e #\l #\l #\o)
- (loop ((for c (in-string "hello")) (for res (listing c))) => res))
-
-(test
- "in-string with start"
- '(#\l #\o)
- (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res))
-
-(test
- "in-string with start and end"
- '(#\h #\e #\l #\l)
- (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res))
-
-(test
- "in-string-reverse"
- '(#\o #\l #\l #\e #\h)
- (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res))
-
-(test
- "in-vector"
- '(1 2 3)
- (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res))
-
-(test
- "in-vector-reverse"
- '(3 2 1)
- (loop ((for x (in-vector-reverse '#(1 2 3))) (for res (listing x))) => res))
-
-(test "up-from" '(5 6 7)
-  (loop ((for i (up-from 5 (to 8)))
-         (for res (listing i)))
-    => res))
-
-(test "up-from by" '(5 10 15)
-  (loop ((for i (up-from 5 (to 20) (by 5)))
-         (for res (listing i)))
-    => res))
-
-(test "up-from listing if" '(10 12 14 16 18)
-  (loop ((for i (up-from 10 (to 20)))
-         (for res (listing i (if (even? i)))))
-    => res))
-
-(test "down-from" '(7 6 5)
-  (loop ((for i (down-from 8 (to 5)))
-         (for res (listing i)))
-    => res))
-
-(test "down-from by" '(15 10 5)
-  (loop ((for i (down-from 20 (to 5) (by 5)))
-         (for res (listing i)))
-    => res))
-
-(test "down-from listing if" '(18 16 14 12 10)
-  (loop ((for i (down-from 20 (to 10)))
-         (for res (listing i (if (even? i)))))
-    => res))
-
-(test "appending" '(1 2 3 4 5 6 7 8 9)
-  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
-         (for res (appending ls)))
-    => res))
-
-(test "appending-reverse" '(9 8 7 6 5 4 3 2 1)
-  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
-         (for res (appending-reverse ls)))
-    => res))
-
-(test "while + up-from" '(5 6 7)
-      (loop ((for i (up-from 5 (to 10)))
-             (while (< i 8))
-             (for res (listing i)))
-        => res))
-
-(test "up-from by, open-ended" '(5 7 9)
-  (loop ((for i (up-from 5 (by 2)))
-         (while (< i 10))
-         (for res (listing i)))
-    => res))
-
-(test "up-from open-ended" '(5 6 7)
-  (loop ((for i (up-from 5))
-         (while (< i 8))
-         (for res (listing i)))
-    => res))
-
-(test "down-from by, open-ended" '(5 3 1)
-  (loop ((for i (down-from 7 (by 2)))
-         (until (< i 1))
-         (for res (listing i)))
-    => res))
-
-(test "down-from open-ended" '(4 3 2)
-  (loop ((for i (down-from 5))
-         (until (< i 2))
-         (for res (listing i)))
-    => res))
-
-(test-end)

tests/match-tests.scm

@@ -1,185 +0,0 @@
-
-(cond-expand
- (modules (import (chibi match) (srfi 99) (only (chibi test) test-begin test test-end)))
- (else (load "lib/chibi/match/match.scm")))
-
-(test-begin "match")
-
-(test "any" 'ok (match 'any (_ 'ok)))
-(test "symbol" 'ok (match 'ok (x x)))
-(test "number" 'ok (match 28 (28 'ok)))
-(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
-(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
-(test "null" 'ok (match '() (() 'ok)))
-(test "pair" 'ok (match '(ok) ((x) x)))
-(test "vector" 'ok (match '#(ok) (#(x) x)))
-(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
-(test "and empty" 'ok (match '(o k) ((and) 'ok)))
-(test "and single" 'ok (match 'ok ((and x) x)))
-(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
-(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
-(test "or single" 'ok (match 'ok ((or x) 'ok)))
-(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
-(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
-(test "pred" 'ok (match 28 ((? number?) 'ok)))
-(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
-
-(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
-(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
-(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
-(test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
-
-(test "ellipses" '((a b c) (1 2 3))
-  (match '((a . 1) (b . 2) (c . 3))
-    (((x . y) ___) (list x y))))
-
-(test "real ellipses" '((a b c) (1 2 3))
-  (match '((a . 1) (b . 2) (c . 3))
-    (((x . y) ...) (list x y))))
-
-(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
-  (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
-    (#(a b c (hd . tl) ...) (list a b c hd tl))))
-
-(test "pred ellipses" '(1 2 3)
-  (match '(1 2 3)
-    (((? odd? n) ___) n)
-    (((? number? n) ___) n)))
-
-(test "failure continuation" 'ok
-  (match '(1 2)
-    ((a . b) (=> next) (if (even? a) 'fail (next)))
-    ((a . b) 'ok)))
-
-(test "let" '(o k)
-  (match-let ((x 'ok) (y '(o k))) y))
-
-(test "let*" '(f o o f)
-  (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
-
-(test "getter car" '(1 2)
-  (match '(1 . 2) (((get! a) . b) (list (a) b))))
-
-(test "getter cdr" '(1 2)
-  (match '(1 . 2) ((a . (get! b)) (list a (b)))))
-
-(test "getter vector" '(1 2 3)
-  (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
-
-(test "setter car" '(3 . 2)
-  (let ((x (cons 1 2)))
-    (match x (((set! a) . b) (a 3)))
-    x))
-
-(test "setter cdr" '(1 . 3)
-  (let ((x (cons 1 2)))
-    (match x ((a . (set! b)) (b 3)))
-    x))
-
-(test "setter vector" '#(1 0 3)
-  (let ((x (vector 1 2 3)))
-    (match x (#(a (set! b) c) (b 0)))
-    x))
-
-(test "single tail" '((a b) (1 2) (c . 3))
-  (match '((a . 1) (b . 2) (c . 3))
-    (((x . y) ... last) (list x y last))))
-
-(test "single tail 2" '((a b) (1 2) 3)
-  (match '((a . 1) (b . 2) 3)
-    (((x . y) ... last) (list x y last))))
-
-(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
-  (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
-    (((x . y) ... u v w) (list x y u v w))))
-
-(test "tail against improper list" #f
-  (match '(a b c d e f . g)
-    ((x ... y u v w) (list x y u v w))
-    (else #f)))
-
-(test "Riastradh quasiquote" '(2 3)
-  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
-
-(test "trivial tree search" '(1 2 3)
-  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
-
-(test "simple tree search" '(1 2 3)
-  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
-
-(test "deep tree search" '(1 2 3)
-  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
-
-(test "non-tail tree search" '(1 2 3)
-  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
-
-(test "restricted tree search" '(1 2 3)
-  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
-
-(test "fail restricted tree search" #f
-  (match '(x (y (x a b c (1 2 3) d e f)))
-    (('x *** (a b c)) (list a b c))
-    (else #f)))
-
-(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
-  (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)))
-
-(test "failed sxml tree search" #f
-  (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)))
-
-(test "collect tree search"
-    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
-  (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
-    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('@ attrs ...) text ...))
-     (list tag attrs text))
-    (else #f)))
-
-(test "anded tail pattern" '(1 2)
-      (match '(1 2 3) ((and (a ... b) x) a)))
-
-(test "anded search pattern" '(a b c)
-      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
-
-(test "joined tail" '(1 2)
-      (match '(1 2 3) ((and (a ... b) x) a)))
-
-(test "list ..1" '(a b c)
-    (match '(a b c) ((x ..1) x)))
-
-(test "list ..1 failed" #f
-    (match '()
-      ((x ..1) x)
-      (else #f)))
-
-(test "list ..1 with predicate" '(a b c)
-    (match '(a b c)
-      (((and x (? symbol?)) ..1) x)))
-
-(test "list ..1 with failed predicate" #f
-    (match '(a b 3)
-      (((and x (? symbol?)) ..1) x)
-      (else #f)))
-
-(define-record-type Point
-  (make-point x y)
-  point?
-  (x point-x point-x-set!)
-  (y point-y point-y-set!))
-
-(test "record positional"
-    '(1 0)
-  (match (make-point 0 1)
-    (($ Point x y) (list y x))))
-
-(test "record named"
-    '(1 0)
-  (match (make-point 0 1)
-    ((@ Point (x x) (y y)) (list y x))))
-
-(test-end)

tests/md5-tests.scm

@@ -1,13 +0,0 @@
-
-(import (chibi crypto md5) (chibi test))
-
-(test-begin "md5")
-
-(test "d41d8cd98f00b204e9800998ecf8427e"
-    (md5 ""))
-(test "900150983cd24fb0d6963f7d28e17f72"
-    (md5 "abc"))
-(test "9e107d9d372bb6826bd81d3542a419d6"
-    (md5 "The quick brown fox jumps over the lazy dog"))
-
-(test-end)

tests/memoize-tests.scm

@@ -1,49 +0,0 @@
-
-(import (chibi) (chibi memoize) (chibi filesystem) (chibi test))
-
-(test-begin "memoize")
-
-(define-memoized (fib n)
-  (if (<= n 1)
-      1
-      (+ (fib (- n 1)) (fib (- n 2)))))
-
-(test 1 (fib 1))
-(test 573147844013817084101 (fib 100))
-
-(define-memoized (ack m n)
-  (cond
-   ((= m 0) (+ n 1))
-   ((= n 0) (ack (- m 1) 1))
-   (else (ack (- m 1) (ack m (- n 1))))))
-
-(test 29 (ack 3 2))
-(test 61 (ack 3 3))
-
-(let ((n 0))
-  (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x)))))
-    (test 0 n)
-    (test 9 (f 3))
-    (test 1 n)
-    (test 9 (f 3))
-    (test 1 n)))
-
-(let ((n 0))
-  (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x))
-                    'size-limit: #f)))
-    (test 0 n)
-    (test 9 (f 3))
-    (test 1 n)
-    (test 9 (f 3))
-    (test 1 n)))
-
-(letrec ((fib (lambda (n)
-                (if (<= n 1)
-                    1
-                    (+ (fib (- n 1)) (fib (- n 2)))))))
-  (let ((f (memoize-to-file fib 'memo-dir: "/tmp/memo.d/")))
-    (test 89 (f 10))
-    (test-assert (file-exists? "/tmp/memo.d/10.memo"))
-    (test 89 (f 10))))
-
-(test-end)

tests/mime-tests.scm

@@ -1,146 +0,0 @@
-
-(import (chibi) (chibi mime) (chibi test)
-        (only (scheme base) string->utf8 open-input-bytevector))
-
-(test-begin "mime")
-
-(test '(text/html (charset . "UTF-8") (filename . "index.html"))
-    (mime-parse-content-type "text/html; CHARSET=UTF-8; filename=index.html"))
-
-(test '(multipart/form-data (boundary . "AaB03x"))
-    (mime-parse-content-type "multipart/form-data, boundary=AaB03x"))
-
-(test '(mime (@ (from . "\"Dr. Watson <guest@grimpen.moor>\"")
-                (to . "\"Sherlock Homes <not-really@221B-baker.street>\"")
-                (subject . "\"First Report\"")
-                (content-type . "text/plain; charset=\"ISO-8859-1\""))
-             "Moor is gloomy. Heard strange noise, attached.\n")
-    (call-with-input-string
-     "From:    \"Dr. Watson <guest@grimpen.moor>\"
-To:      \"Sherlock Homes <not-really@221B-baker.street>\"
-Subject: \"First Report\"
-Content-Type: text/plain; charset=\"ISO-8859-1\"
-
-Moor is gloomy. Heard strange noise, attached.
-
-"
-     mime-message->sxml))
-
-;; from rfc 1867
-
-(test '(mime
-        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
-        (mime (@ (content-disposition . "form-data; name=\"field1\""))
-              "Joe Blow")
-        (mime (@ (content-disposition
-                  . "form-data; name=\"pics\"; filename=\"file1.txt\"")
-                 (content-type . "text/plain"))
-              " ... contents of file1.txt ..."))
-    (call-with-input-string
-        "Content-type: multipart/form-data, boundary=AaB03x
-
---AaB03x
-content-disposition: form-data; name=\"field1\"
-
-Joe Blow
---AaB03x
-content-disposition: form-data; name=\"pics\"; filename=\"file1.txt\"
-Content-Type: text/plain
-
- ... contents of file1.txt ...
---AaB03x--
-"
-      mime-message->sxml))
-
-(test '(mime
-        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
-        (mime (@ (content-disposition . "form-data; name=\"field1\""))
-              "Joe Blow")
-        (mime (@ (content-disposition . "form-data; name=\"pics\"")
-                 (content-type . "multipart/mixed, boundary=BbC04y"))
-              (mime (@ (content-disposition
-                        . "attachment; filename=\"file1.txt\"")
-                       (content-type . "text/plain"))
-                    "... contents of file1.txt ...")
-              (mime (@ (content-disposition
-                        . "attachment; filename=\"file2.gif\"")
-                       (content-type . "image/gif")
-                       (content-transfer-encoding . "binary"))
-                    #u8(32 32 46 46 46 99 111 110 116 101 110
-                        116 115 32 111 102 32 102 105 108 101
-                        50 46 103 105 102 46 46 46))))
-    (call-with-input-string
-        "Content-type: multipart/form-data, boundary=AaB03x
-
---AaB03x
-content-disposition: form-data; name=\"field1\"
-
-Joe Blow
---AaB03x
-content-disposition: form-data; name=\"pics\"
-Content-type: multipart/mixed, boundary=BbC04y
-
---BbC04y
-Content-disposition: attachment; filename=\"file1.txt\"
-Content-Type: text/plain
-
-... contents of file1.txt ...
---BbC04y
-Content-disposition: attachment; filename=\"file2.gif\"
-Content-type: image/gif
-Content-Transfer-Encoding: binary
-
-  ...contents of file2.gif...
---BbC04y--
---AaB03x--
-"
-      mime-message->sxml))
-
-(test '(mime
-        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
-        (mime (@ (content-disposition . "form-data; name=\"field1\"")
-                 (content-type . "text/plain"))
-              "Joe Blow")
-        (mime (@ (content-disposition . "form-data; name=\"pics\"")
-                 (content-type . "multipart/mixed, boundary=BbC04y"))
-              (mime (@ (content-disposition
-                        . "attachment; filename=\"file1.txt\"")
-                       (content-type . "text/plain"))
-                    "... contents of file1.txt ...")
-              (mime (@ (content-disposition
-                        . "attachment; filename=\"file2.gif\"")
-                       (content-type . "image/gif")
-                       (content-transfer-encoding . "binary"))
-                    #u8(32 32 46 46 46 99 111 110 116 101 110
-                        116 115 32 111 102 32 102 105 108 101
-                        50 46 103 105 102 46 46 46))))
-    (mime-message->sxml
-     (open-input-bytevector
-      (string->utf8
-       "Content-type: multipart/form-data, boundary=AaB03x
-
---AaB03x
-content-disposition: form-data; name=\"field1\"
-Content-Type: text/plain
-
-Joe Blow
---AaB03x
-content-disposition: form-data; name=\"pics\"
-Content-type: multipart/mixed, boundary=BbC04y
-
---BbC04y
-Content-disposition: attachment; filename=\"file1.txt\"
-Content-Type: text/plain
-
-... contents of file1.txt ...
---BbC04y
-Content-disposition: attachment; filename=\"file2.gif\"
-Content-type: image/gif
-Content-Transfer-Encoding: binary
-
-  ...contents of file2.gif...
---BbC04y--
---AaB03x--
-"))))
-
-(test-end)

tests/parse-tests.scm

@@ -1,134 +0,0 @@
-
-(import (chibi) (chibi test)
-        (chibi char-set) (chibi char-set ascii)
-        (chibi parse) (chibi parse common))
-
-(test-begin "parse")
-
-;; basic
-
-(test-assert (parse parse-epsilon ""))
-(test-assert (parse-fully parse-epsilon ""))
-(test-error (parse-fully parse-epsilon "a"))
-
-(test-not (parse parse-anything ""))
-(test-assert (parse-fully parse-anything "a"))
-(test-error (parse-fully parse-anything "ab"))
-
-(test-not (parse parse-nothing ""))
-(test-not (parse parse-nothing "a"))
-
-(test-not (parse (parse-char #\a) ""))
-(test-assert (parse-fully (parse-char #\a) "a"))
-(test-not (parse (parse-char #\a) "b"))
-(test-error (parse-fully (parse-char #\a) "ab"))
-
-(let ((f (parse-seq (parse-char #\a) (parse-char #\b))))
-  (test-not (parse f "a"))
-  (test-not (parse f "b"))
-  (test-assert (parse f "ab"))
-  (test-error (parse-fully f "abc")))
-
-(let ((f (parse-or (parse-char #\a) (parse-char #\b))))
-  (test-not (parse f ""))
-  (test-assert (parse f "a"))
-  (test-assert (parse f "b"))
-  (test-error (parse-fully f "ab")))
-
-(let ((f (parse-not (parse-char #\a))))
-  (test-assert (parse f ""))
-  (test-error (parse-fully f "a"))
-  (test-assert (parse f "b")))
-
-(let ((f (parse-repeat (parse-char #\a))))
-  (test-assert (parse-fully f ""))
-  (test-assert (parse-fully f "a"))
-  (test-assert (parse-fully f "aa"))
-  (test-assert (parse-fully f "aaa"))
-  (test-assert (parse f "b"))
-  (test-assert (parse f "aab"))
-  (test-error (parse-fully f "aab")))
-
-;; grammars
-
-(let ()
-  (define-grammar calc
-    (space ((* ,char-set:whitespace)))
-    (number ((=> n (+ ,char-set:digit))
-             (string->number (list->string n))))
-    (simple ((=> n ,number) n)
-            ((: "(" (=> e1 ,term) ")") e1))
-    (term-op ("*" *)
-             ("/" /)
-             ("%" modulo))
-    (term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
-           (op e1 e2))
-          ((=> e1 ,simple)
-           e1)))
-  (test 88 (parse term "4*22"))
-  (test 42 (parse term "42"))
-  ;; partial match (grammar isn't checking end)
-  (test 42 (parse term "42*")))
-
-(define calculator
-  (grammar expr
-    (space ((: ,char-set:whitespace ,space))
-           (() #f))
-    (digit ((=> d ,char-set:digit) d))
-    (number ((=> n (+ ,digit))
-             (string->number (list->string n))))
-    (simple ((=> n ,number) n)
-            ((: "(" (=> e1 ,expr) ")") e1))
-    (term-op ("*" *)
-             ("/" /)
-             ("%" modulo))
-    (term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
-           (op e1 e2))
-          ((=> e1 ,simple)
-           e1))
-    (expr-op ("+" +) ("-" -))
-    (expr ((: ,space (=> e1 ,term) ,space (=> op ,expr-op) ,space (=> e2 ,expr))
-           (op e1 e2))
-          ((: ,space (=> e1 ,term))
-           e1))))
-
-(test 42 (parse calculator "42"))
-(test 4 (parse calculator "2 + 2"))
-(test 23 (parse calculator "2 + 2*10 + 1"))
-(test 25 (parse calculator "2+2 * 10+1 * 3"))
-(test 41 (parse calculator "(2 + 2) * 10 + 1"))
-
-(define prec-calc
-  (grammar expr
-    (simple (,(parse-integer))
-            ((: "(" (=> e1 ,expr) ")") e1))
-    (op
-     ("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
-    (expr
-     (,(parse-binary-op op `((+ 5) (- 5) (* 3) (/ 3) (^ 1 right)) simple)))))
-
-(test 42 (parse prec-calc "42"))
-(test '(+ 2 2) (parse prec-calc "2 + 2"))
-(test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
-(test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
-(test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
-(test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
-(test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
-(test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
-    (parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9"))
-
-;; this takes exponential time without memoization
-(define explode
-  (grammar start
-    (start ((: ,S eos) #t))
-    (S ((+ ,A) #t))
-    (A ((: "a" ,S "b") #t)
-       ((: "a" ,S "c") #t)
-       ((: "a") #t))))
-
-(test-assert (parse explode "aaabb"))
-(test-not (parse explode "bbaa"))
-(test-assert
- (parse explode (string-append (make-string 10 #\a) (make-string 8 #\c))))
-
-(test-end)

tests/path-tests.scm

@@ -1,204 +0,0 @@
-
-(import (chibi) (chibi pathname) (chibi test))
-
-(test-begin "pathname")
-
-;; tests from the dirname(3) manpage
-
-(test "dirname(3)" "/usr" (path-directory "/usr/lib"))
-(test "lib"  (path-strip-directory "/usr/lib"))
-
-(test "/"    (path-directory "/usr/"))
-(test ""     (path-strip-directory "/usr/"))
-
-(test "."    (path-directory "usr"))
-(test "usr"  (path-strip-directory "usr"))
-
-(test "/"    (path-directory "/"))
-(test ""     (path-strip-directory "/"))
-
-(test "."    (path-directory "."))
-(test "."    (path-strip-directory "."))
-
-(test "."    (path-directory ".."))
-(test ".."   (path-strip-directory ".."))
-
-;; additional tests (should match GNU dirname/basename behavior)
-
-(test "path-directory:border"
-            "/"    (path-directory "//"))
-(test ""     (path-strip-directory "//"))
-
-(test "."    (path-directory ""))
-(test ""     (path-strip-directory ""))
-
-(test "."    (path-directory "../"))
-(test ""     (path-strip-directory "../"))
-
-(test ".."   (path-directory "../.."))
-(test ".."   (path-strip-directory "../.."))
-
-(test "path-directory:extra"
-            "/usr/local" (path-directory "/usr/local/lib"))
-(test "lib" (path-strip-directory "/usr/local/lib"))
-
-(test "/usr" (path-directory "/usr/local/"))
-(test "" (path-strip-directory "/usr/local/"))
-
-(test "usr"    (path-directory "usr/local"))
-(test "local"  (path-strip-directory "usr/local"))
-
-(test "/" (path-directory "//usr"))
-(test "usr" (path-strip-directory "//usr"))
-
-(test "/" (path-directory "//usr/"))
-(test "" (path-strip-directory "//usr/"))
-
-(test "path-directory:small"
-            "/a" (path-directory "/a/b"))
-(test "b" (path-strip-directory "/a/b"))
-
-(test "a" (path-directory "a/b"))
-(test "b" (path-strip-directory "a/b"))
-
-(test "a" (path-directory "a/b/"))
-(test "" (path-strip-directory "a/b/"))
-
-(test "/a/b/c" (path-directory "/a/b/c/d"))
-(test "d" (path-strip-directory "/a/b/c/d"))
-
-(test "/a/b/c" (path-directory "/a/b/c/d/"))
-(test "" (path-strip-directory "/a/b/c/d/"))
-
-(test "a/b/c"    (path-directory "a/b/c/d"))
-(test "d"  (path-strip-directory "a/b/c/d"))
-
-(test "/a/b" (path-directory "/a/b/c.d"))
-(test "c.d" (path-strip-directory "/a/b/c.d"))
-
-(test "/a/b" (path-directory "/a/b/c.d/"))
-(test "" (path-strip-directory "/a/b/c.d/"))
-
-(test "/a/b/c" (path-directory "/a/b/c/."))
-(test "." (path-strip-directory "/a/b/c/."))
-
-(test "/a/b/c" (path-directory "/a/b/c/.."))
-(test ".." (path-strip-directory "/a/b/c/.."))
-
-(test "/a/b/." (path-directory "/a/b/./c"))
-(test "c" (path-strip-directory "/a/b/./c"))
-
-(test "/a/b/.." (path-directory "/a/b/../c"))
-(test "c" (path-strip-directory "/a/b/../c"))
-
-(test "/a/b" (path-directory "/a/b/c//"))
-(test "" (path-strip-directory "/a/b/c//"))
-
-(test "/a/b" (path-directory "/a/b//c///"))
-(test "" (path-strip-directory "/a/b//c///"))
-
-;; extensions
-
-(test "path-extension" "scm" (path-extension "foo.scm"))
-(test "foo" (path-strip-extension "foo.scm"))
-
-(test "c" (path-extension "foo.scm.c"))
-(test "foo.scm" (path-strip-extension "foo.scm.c"))
-
-(test "scm" (path-extension "/home/me/foo.scm"))
-(test "/home/me/foo" (path-strip-extension "/home/me/foo.scm"))
-
-(test "scm" (path-extension "foo..scm"))
-(test "foo." (path-strip-extension "foo..scm"))
-
-(test "s" (path-extension "foo.s"))
-(test "foo" (path-strip-extension "foo.s"))
-
-(test #f (path-extension "foo."))
-(test "foo." (path-strip-extension "foo."))
-
-(test #f (path-extension "foo.scm."))
-(test "foo.scm." (path-strip-extension "foo.scm."))
-
-(test #f (path-extension "."))
-(test "." (path-strip-extension "."))
-
-(test #f (path-extension "a."))
-(test "a." (path-strip-extension "a."))
-
-(test #f (path-extension "/."))
-(test "/." (path-strip-extension "/."))
-
-(test #f (path-extension "foo.scm/"))
-(test "foo.scm/" (path-strip-extension "foo.scm/"))
-
-(test "path-replace-extension"
-            "foo.c" (path-replace-extension "foo.scm" "c"))
-(test "foo.c" (path-replace-extension "foo" "c"))
-
-;; absolute paths
-
-(test-assert (path-absolute? "/"))
-(test-assert (path-absolute? "//"))
-(test-assert (path-absolute? "/usr"))
-(test-assert (path-absolute? "/usr/"))
-(test-assert (path-absolute? "/usr/."))
-(test-assert (path-absolute? "/usr/.."))
-(test-assert (path-absolute? "/usr/./"))
-(test-assert (path-absolute? "/usr/../"))
-
-(test-assert (not (path-absolute? "")))
-(test-assert (not (path-absolute? ".")))
-(test-assert (not (path-absolute? "usr")))
-(test-assert (not (path-absolute? "usr/")))
-
-;; normalization & building
-
-(test "path-normalize" "/a/b/c/d/e" (path-normalize "/a/b/c/d/./e"))
-(test "/a/b/c/d/e" (path-normalize "/a/b//.///c//d/./e"))
-(test "/a/b/c/d/e/" (path-normalize "/a/b//.///c//d/./e/"))
-(test "/a/c/d/e" (path-normalize "/a/b/../c/d/e"))
-(test "/a/b/c/e" (path-normalize "/a/b//.///c//d/../e"))
-(test "/a/c/e" (path-normalize "/a/b//..///c//d/../e"))
-(test "/a/b/c/d/e/"
-            (path-normalize "/a/b//./../c/d/../../b//c/d/e/f/.."))
-(test "/a/b/c/" (path-normalize "/a/b/c/."))
-
-(test "path-normalize:border" "" (path-normalize ""))
-(test "." (path-normalize "."))
-(test "/" (path-normalize "/"))
-(test "/" (path-normalize "/."))
-
-(test "path-normalize:overflow"
-            "/" (path-normalize "/a/b/c/../../../../.."))
-(test "../.." (path-normalize "a/b/c/../../../../.."))
-(test "../../.." (path-normalize "../a/b/c/../../../../.."))
-
-(test "" (path-strip-leading-parents ".."))
-(test "" (path-strip-leading-parents "../"))
-(test "a" (path-strip-leading-parents "../a"))
-(test "a/b" (path-strip-leading-parents "../../a/b"))
-(test "a/b" (path-strip-leading-parents "../../../a/b"))
-(test "a/../b" (path-strip-leading-parents "../../../a/../b"))
-
-(test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b"))
-(test "c" (path-relative-to "/a/b/c" "/a/b/"))
-(test "." (path-relative-to "/a/b/" "/a/b/"))
-(test "." (path-relative-to "/a/b/" "/a/b"))
-(test "." (path-relative-to "/a/b" "/a/b/"))
-(test "." (path-relative-to "/a/b" "/a/b"))
-(test-not (path-relative-to "/d/a/b/c" "/a/b"))
-
-(test "make-path" "a/b" (make-path "a" "b"))
-(test "a/b" (make-path "a/" "b"))
-(test "a/b/./c" (make-path "a" "b" "." "c"))
-(test "a/b/../c" (make-path "a" "b" ".." "c"))
-(test "a/b/c" (make-path "a" '("b" "c")))
-(test "/" (make-path "/" ""))
-(test "/" (make-path "/" "/"))
-(test "/." (make-path "/" "."))
-(test "/a" (make-path "/a" ""))
-(test "/a" (make-path "/a" "/"))
-(test "/a/." (make-path "/a" "."))
-
-(test-end)

tests/prime-tests.scm

@@ -1,95 +0,0 @@
-
-(import (chibi) (chibi math prime) (chibi test))
-
-(test-begin "prime")
-
-(test 7 (modular-inverse 3 10))
-(test 4 (modular-inverse 3 11))
-(test 27 (modular-inverse 3 40))
-(test 43 (modular-inverse 3 64))
-
-(test #f (prime? 1))
-(test #t (prime? 2))
-(test #t (prime? 3))
-(test #f (prime? 4))
-(test #t (prime? 5))
-(test #f (prime? 6))
-(test #t (prime? 7))
-(test #f (prime? 8))
-(test #f (prime? 9))
-(test #f (prime? 10))
-(test #t (prime? 11))
-
-(test 2 (nth-prime 0))
-(test 3 (nth-prime 1))
-(test 5 (nth-prime 2))
-(test 7 (nth-prime 3))
-(test 11 (nth-prime 4))
-(test 997 (nth-prime 167))
-(test 1009 (nth-prime 168))
-(test 1013 (nth-prime 169))
-
-(test 907 (prime-above 888))
-(test 797 (prime-below 808))
-
-(test 1 (totient 2))
-(test 2 (totient 3))
-(test 2 (totient 4))
-(test 4 (totient 5))
-(test 2 (totient 6))
-(test 6 (totient 7))
-(test 4 (totient 8))
-(test 6 (totient 9))
-(test 4 (totient 10))
-
-(test #f (perfect? 1))
-(test #f (perfect? 2))
-(test #f (perfect? 3))
-(test #f (perfect? 4))
-(test #f (perfect? 5))
-(test #t (perfect? 6))
-(test #f (perfect? 7))
-(test #f (perfect? 8))
-(test #f (perfect? 9))
-(test #f (perfect? 10))
-(test #t (perfect? 28))
-(test #t (perfect? 496))
-(test #t (perfect? 8128))
-
-(test '(1) (factor 1))
-(test '(2) (factor 2))
-(test '(3) (factor 3))
-(test '(2 2) (factor 4))
-(test '(5) (factor 5))
-(test '(2 3) (factor 6))
-(test '(7) (factor 7))
-(test '(2 2 2) (factor 8))
-(test '(3 3) (factor 9))
-(test '(2 5) (factor 10))
-(test '(11) (factor 11))
-(test '(2 2 3) (factor 12))
-(test '(2 3 3) (factor 18))
-(test '(2 2 2 3 3) (factor 72))
-(test '(3 3 3 5 7) (factor 945))
-
-(test 975 (aliquot 945))
-
-(do ((i 3 (+ i 2)))
-    ((>= i 101))
-  (test (number->string i) (prime? i)
-    (probable-prime? i)))
-
-(test #t (probable-prime? 4611686020149081683))
-(test #t (probable-prime? 4611686020243253179))
-(test #t (probable-prime? 4611686020243253219))
-(test #t (probable-prime? 4611686020243253257))
-(test #f (probable-prime? 4611686020243253181))
-(test #f (probable-prime? 4611686020243253183))
-(test #f (probable-prime? 4611686020243253247))
-
-(test 5
-    (modular-expt 7670626353261554806
-                  5772301760555853353
-                  (* 2936546443 3213384203)))
-
-(test-end)

tests/process-tests.scm

@@ -1,28 +0,0 @@
-
-(cond-expand
- (modules (import (chibi process) (only (chibi test) test-begin test test-end)))
- (else #f))
-
-(test-begin "processes")
-
-(test #t (process-running? (current-process-id)))
-(test #t (process-running? (parent-process-id)))
-(test #f (signal-set-contains? (current-signal-mask) signal/alarm))
-
-(test #t (signal-set? (make-signal-set)))
-(test #t (signal-set? (current-signal-mask)))
-(test #f (signal-set? #f))
-(test #f (signal-set? '(#f)))
-(test #f (signal-set-contains? (make-signal-set) signal/interrupt))
-(test #t (let ((sset (make-signal-set)))
-           (signal-set-fill! sset)
-           (signal-set-contains? sset signal/interrupt)))
-(test #t (let ((sset (make-signal-set)))
-           (signal-set-add! sset signal/interrupt)
-           (signal-set-contains? sset signal/interrupt)))
-(test #f (let ((sset (make-signal-set)))
-           (signal-set-fill! sset)
-           (signal-set-delete! sset signal/interrupt)
-           (signal-set-contains? sset signal/interrupt)))
-
-(test-end)

tests/record-tests.scm

@@ -1,222 +0,0 @@
-
-(cond-expand
- (modules
-  (import (srfi 99)
-          (only (chibi) env-exports)
-          (only (chibi test) test-begin test-assert test test-end)))
- (else #f))
-
-(test-begin "records")
-
-(define-record-type organism
-  (make-organism name)
-  organism?
-  (name name-of set-name-of!))
-
-;; kingdom
-(define-record-type (animal organism)
-  (make-animal name food)
-  animal?
-  ;; all animals eat
-  (food food-of set-food-of!))
-
-;; phylum
-(define-record-type (chordate animal)
-  (make-chordate name food)
-  chordate?)
-
-;; class
-(define-record-type (mammal chordate)
-  (make-mammal name food num-nipples)
-  mammal?
-  ;; all mammals have nipples
-  (num-nipples num-nipples-of set-num-nipples-of!))
-
-;; order
-(define-record-type (carnivore mammal)
-  (make-carnivore name food num-nipples)
-  carnivore?)
-
-(define-record-type (rodent mammal)
-  (make-rodent name food num-nipples)
-  rodent?)
-
-;; family
-(define-record-type (felidae carnivore)
-  (make-felidae name food num-nipples)
-  felidae?)
-
-(define-record-type (muridae rodent)
-  (make-muridae name food num-nipples)
-  muridae?)
-
-;; genus
-(define-record-type (felis felidae)
-  (make-felis name food num-nipples)
-  felis?)
-
-(define-record-type (mus muridae)
-  (make-mus name food num-nipples)
-  mus?)
-
-;; species
-(define-record-type (cat felis)
-  (make-cat name food num-nipples breed color)
-  cat?
-  (breed breed-of set-breed-of!)
-  (color color-of set-color-of!))
-
-(define-record-type (mouse mus)
-  (make-mouse name food num-nipples)
-  mouse?)
-
-(define mickey (make-mouse "Mickey" "cheese" 10))
-(define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
-
-(test-assert (organism? mickey))
-(test-assert (animal? mickey))
-(test-assert (chordate? mickey))
-(test-assert (mammal? mickey))
-(test-assert (rodent? mickey))
-(test-assert (muridae? mickey))
-(test-assert (mus? mickey))
-(test-assert (mouse? mickey))
-
-(test-assert (not (carnivore? mickey)))
-(test-assert (not (felidae? mickey)))
-(test-assert (not (felis? mickey)))
-(test-assert (not (cat? mickey)))
-
-(test-assert (organism? felix))
-(test-assert (animal? felix))
-(test-assert (chordate? felix))
-(test-assert (mammal? felix))
-(test-assert (carnivore? felix))
-(test-assert (felidae? felix))
-(test-assert (felis? felix))
-(test-assert (cat? felix))
-
-(test-assert (not (rodent? felix)))
-(test-assert (not (muridae? felix)))
-(test-assert (not (mus? felix)))
-(test-assert (not (mouse? felix)))
-
-(test "Mickey" (name-of mickey))
-(test "cheese" (food-of mickey))
-(test 10 (num-nipples-of mickey))
-
-(test "Felix" (name-of felix))
-(test mickey (food-of felix))
-(test 8 (num-nipples-of felix))
-(test 'mixed (breed-of felix))
-(test '(and black white) (color-of felix))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-record-type person #t #t (name) (sex) (age))
-(define-record-type (employee person) #t #t (department) (salary))
-
-(define bob (make-employee "Bob" 'male 28 'hr 50000.0))
-(define alice (make-employee "Alice" 'female 32 'research 100000.0))
-
-(test-assert (person? bob))
-(test-assert (employee? bob))
-(test "Bob" (person-name bob))
-(test 'male (person-sex bob))
-(test 28 (person-age bob))
-(test 'hr (employee-department bob))
-(test 50000.0 (employee-salary bob))
-
-(test-assert (person? alice))
-(test-assert (employee? alice))
-(test "Alice" (person-name alice))
-(test 'female (person-sex alice))
-(test 32 (person-age alice))
-(test 'research (employee-department alice))
-(test 100000.0 (employee-salary alice))
-
-;; After a trip to Thailand...
-(person-sex-set! bob 'female)
-(person-name-set! bob "Roberta")
-
-;; Then Roberta quits!
-(employee-department-set! bob #f)
-(employee-salary-set! bob 0.0)
-
-(test "Roberta" (person-name bob))
-(test 'female (person-sex bob))
-(test 28 (person-age bob))
-(test #f (employee-department bob))
-(test 0.0 (employee-salary bob))
-
-;; SRFI-99 forbids this, but we currently do it anyway.
-(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
-                     (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
-
-(test-assert (record? alice))
-(test 'person (rtd-name person))
-(let* ((constructor (rtd-constructor person))
-       (trent (constructor "Trent" 'male 44)))
-  (test "Trent" (person-name trent))
-  (test 'male (person-sex trent))
-  (test 44 ((rtd-accessor person 'age) trent))
-  ((rtd-mutator person 'age) trent 45)
-  (test 45 (person-age trent)))
-
-(test-assert (rtd-field-mutable? employee 'department))
-
-;;; We do not retain mutability information ATM.
-;; (define-record-type foo
-;;   (make-foo x)
-;;   foo?
-;;   (x foo-x))
-;;
-;; (test-assert (not (rtd-field-mutable? foo 'x)))
-
-(define point (make-rtd "point" #(x y)))
-(define make-point (rtd-constructor point #(x y)))
-(define point-x (rtd-accessor point 'x))
-(test 3 (point-x (make-point 3 2)))
-
-;; Name conflicts - make sure we rename 
-
-(define-record-type example make-example #t example)
-(test-assert (example? (make-example 3)))
-(test 3 (example-example (make-example 3)))
-
-;; record types definitions with #f passed as either the constructor or
-;; predicate argument should not create the corresponding function
-
-(define-record-type abstract
-  #f #t)
-
-(test #f (memq 'make-abstract (env-exports (current-environment))))
-
-(define-record-type (derived abstract)
-  #t #f)
-
-(define instance (make-derived))
-(test-assert (abstract? instance))
-(test #f (memq 'derived? (env-exports (current-environment))))
-
-(define-record-type container
-  #t #t
-  default-immutable
-  (default-mutable)
-  (named-immutable get-container-immutable)
-  (named-mutable get-container-mutable set-container-mutable!))
-
-(define container-instance (make-container 1 2 3 4))
-
-(test 1 (container-default-immutable container-instance))
-(test 2 (container-default-mutable container-instance))
-(test 3 (get-container-immutable container-instance))
-(test 4 (get-container-mutable container-instance))
-
-(container-default-mutable-set! container-instance #t)
-(test #t (container-default-mutable container-instance))
-
-(set-container-mutable! container-instance #t)
-(test #t (get-container-mutable container-instance))
-
-(test-end)

tests/regexp-tests.scm

@@ -1,282 +0,0 @@
-
-(import (chibi) (chibi regexp) (chibi regexp pcre)
-        (chibi string) (chibi io) (chibi match) (chibi test))
-
-(define (maybe-match->sexp rx str . o)
-  (let ((res (apply regexp-matches rx str o)))
-    (and res (regexp-match->sexp res))))
-
-(define-syntax test-re
-  (syntax-rules ()
-    ((test-re res rx str start end)
-     (test res (maybe-match->sexp rx str start end)))
-    ((test-re res rx str start)
-     (test-re res rx str start (string-length str)))
-    ((test-re res rx str)
-     (test-re res rx str 0))))
-
-(define (maybe-search->sexp rx str . o)
-  (let ((res (apply regexp-search rx str o)))
-    (and res (regexp-match->sexp res))))
-
-(define-syntax test-re-search
-  (syntax-rules ()
-    ((test-re-search res rx str start end)
-     (test res (maybe-search->sexp rx str start end)))
-    ((test-re-search res rx str start)
-     (test-re-search res rx str start (string-length str)))
-    ((test-re-search res rx str)
-     (test-re-search res rx str 0))))
-
-(test-begin "regexp")
-
-(test-re '("ababc" "abab")
-         '(: ($ (* "ab")) "c")
-         "ababc")
-
-(test-re '("ababc" "abab")
-         '(: ($ (* "ab")) "c")
-         "xababc"
-         1)
-
-(test-re-search '("y") '(: "y") "xy")
-
-(test-re-search '("ababc" "abab")
-                '(: ($ (* "ab")) "c")
-                "xababc")
-
-(test-re #f
-         '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
-         "fooxbafba")
-
-(test-re '("fooxbarfbar" "fooxbarf" "bar")
-         '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
-         "fooxbarfbar")
-
-(test-re '("abcd" "abcd")
-         '($ (* (or "ab" "cd")))
-         "abcd")
-
-;; first match is a list of ab's, second match is the last (temporary) cd
-(test-re '("abcdc" (("ab") ("cd")) "cd")
-         '(: (* (*$ (or "ab" "cd"))) "c")
-         "abcdc")
-
-(test "ab"
-    (regexp-match-submatch
-     (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "ab")
-     'foo))
-
-(test "cd"
-    (regexp-match-submatch
-     (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "cd")
-     'foo))
-
-;; non-deterministic case from issue #229
-(let* ((elapsed '(: (** 1 2 num) ":" num num (? ":" num num)))
-       (span (rx ,elapsed "-" ,elapsed)))
-  (test-re-search '("1:45:02-2:06:13") span " 1:45:02-2:06:13 "))
-
-(test-re '("ababc" "abab")
-         '(: bos ($ (* "ab")) "c")
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: ($ (* "ab")) "c" eos)
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: bos ($ (* "ab")) "c" eos)
-         "ababc")
-(test-re #f
-         '(: bos ($ (* "ab")) eos "c")
-         "ababc")
-(test-re #f
-         '(: ($ (* "ab")) bos "c" eos)
-         "ababc")
-
-(test-re '("ababc" "abab")
-         '(: bol ($ (* "ab")) "c")
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: ($ (* "ab")) "c" eol)
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: bol ($ (* "ab")) "c" eol)
-         "ababc")
-(test-re #f
-         '(: bol ($ (* "ab")) eol "c")
-         "ababc")
-(test-re #f
-         '(: ($ (* "ab")) bol "c" eol)
-         "ababc")
-(test-re '("\nabc\n" "abc")
-         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
-         "\nabc\n")
-(test-re #f
-         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
-         "\n'abc\n")
-(test-re #f
-         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
-         "\nabc.\n")
-
-(test-re '("ababc" "abab")
-         '(: bow ($ (* "ab")) "c")
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: ($ (* "ab")) "c" eow)
-         "ababc")
-(test-re '("ababc" "abab")
-         '(: bow ($ (* "ab")) "c" eow)
-         "ababc")
-(test-re #f
-         '(: bow ($ (* "ab")) eow "c")
-         "ababc")
-(test-re #f
-         '(: ($ (* "ab")) bow "c" eow)
-         "ababc")
-(test-re '("  abc  " "abc")
-         '(: (* space) bow ($ (* alpha)) eow (* space))
-         "  abc  ")
-(test-re #f
-         '(: (* space) bow ($ (* alpha)) eow (* space))
-         " 'abc  ")
-(test-re #f
-         '(: (* space) bow ($ (* alpha)) eow (* space))
-         " abc.  ")
-(test-re-search '("foo") '(: "foo") " foo ")
-(test-re-search #f '(: nwb "foo" nwb) " foo ")
-(test-re-search '("foo") '(: nwb "foo" nwb) "xfoox")
-
-(test-re '("beef")
-         '(* (/"af"))
-         "beef")
-
-(test-re '("12345beef" "beef")
-         '(: (* digit) ($ (* (/"af"))))
-         "12345beef")
-
-(let ((number '($ (+ digit))))
-  (test '("555" "867" "5309")
-      (cdr
-       (regexp-match->list
-        (regexp-search `(: ,number "-" ,number "-" ,number)
-                       "555-867-5309"))))
-  (test '("555" "5309")
-      (cdr
-       (regexp-match->list
-        (regexp-search `(: ,number "-" (w/nocapture ,number) "-" ,number)
-                       "555-867-5309")))))
-
-(test-re '("12345BeeF" "BeeF")
-         '(: (* digit) (w/nocase ($ (* (/"af")))))
-         "12345BeeF")
-
-(test-re #f '(* lower) "abcD")
-(test-re '("abcD") '(w/nocase (* lower)) "abcD")
-(test-re '("σζ") '(* lower) "σζ")
-(test-re '("Σ") '(* upper) "Σ")
-(test-re '("\x01C5;") '(* title) "\x01C5;")
-(test-re '("σζ\x01C5;") '(w/nocase (* lower)) "σζ\x01C5;")
-
-(test-re '("кириллица") '(* alpha) "кириллица")
-(test-re #f '(w/ascii (* alpha)) "кириллица")
-(test-re '("кириллица") '(w/nocase "КИРИЛЛИЦА") "кириллица")
-
-(test-re '("１２３４５") '(* digit) "１２３４５")
-(test-re #f '(w/ascii (* digit)) "１２３４５")
-
-(test-re '("한") 'grapheme "한")
-(test-re '("글") 'grapheme "글")
-
-(test-re '("한") '(: bog grapheme eog) "한")
-(test-re #f '(: "ᄒ" bog grapheme eog "ᆫ") "한")
-
-(test '("123" "456" "789") (regexp-extract '(+ digit) "abc123def456ghi789"))
-(test '("123" "456" "789") (regexp-extract '(* digit) "abc123def456ghi789"))
-(test '("abc" "def" "ghi") (regexp-split '(+ digit) "abc123def456ghi789"))
-(test '("a" "b" "c" "d" "e" "f" "g" "h" "i")
-    (regexp-split '(* digit) "abc123def456ghi789"))
-(test '("a" "b") (regexp-split '(+ whitespace) "a b"))
-(test '("한" "글")
-    (regexp-extract
-     'grapheme
-     (utf8->string '#u8(#xe1 #x84 #x92 #xe1 #x85 #xa1 #xe1 #x86 #xab
-                        #xe1 #x84 #x80 #xe1 #x85 #xb3 #xe1 #x86 #xaf))))
-
-(test "abc def" (regexp-replace '(+ space) "abc \t\n def" " "))
-(test "  abc-abc"
-    (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" 1)))
-(test "  abc-  abc"
-    (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" pre 1)))
-
-(test "-abc \t\n d ef  "
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0))
-(test "-abc \t\n d ef  "
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 0))
-(test "  abc-d ef  "
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 1))
-(test "  abc \t\n d-ef  "
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 2))
-(test "  abc \t\n d ef-"
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 3))
-(test "  abc \t\n d ef  "
-    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 4))
-(test " abc d ef " (regexp-replace-all '(+ space) "  abc \t\n d ef  " " "))
-
-(define (subst-matches matches input subst)
-  (define (submatch n)
-    (regexp-match-submatch matches n))
-  (and
-   matches
-   (call-with-output-string
-     (lambda (out)
-       (call-with-input-string subst
-         (lambda (in)
-           (let lp ()
-             (let ((c (read-char in)))
-               (cond
-                ((not (eof-object? c))
-                 (case c
-                   ((#\&)
-                    (display (or (submatch 0) "") out))
-                   ((#\\)
-                    (let ((c (read-char in)))
-                      (if (char-numeric? c)
-                          (let lp ((res (list c)))
-                            (if (and (char? (peek-char in))
-                                     (char-numeric? (peek-char in)))
-                                (lp (cons (read-char in) res))
-                                (display
-                                 (or (submatch (string->number
-                                                (list->string (reverse res))))
-                                     "")
-                                 out)))
-                          (write-char c out))))
-                   (else
-                    (write-char c out)))
-                 (lp)))))))))))
-
-(define (test-pcre line)
-  (match (string-split line #\tab)
-    ((pattern input result subst output)
-     (let ((name (string-append pattern " " input " " result " " subst)))
-       (cond
-        ((equal? "c" result)
-         (test-error name (regexp-search (pcre->sre pattern) input)))
-        ((equal? "n" result)
-         (test-assert name (not (regexp-search (pcre->sre pattern) input))))
-        (else
-         (test name output
-           (subst-matches (regexp-search (pcre->sre pattern) input)
-                          input
-                          subst))))))
-    (else
-     (error "invalid regex test line" line))))
-
-(test-group "pcre"
-  (call-with-input-file "tests/re-tests.txt"
-    (lambda (in)
-      (for-each
-       (lambda (line) (test-pcre line))
-       (port->list read-line in)))))
-
-(test-end)

tests/rsa-tests.scm

@@ -1,81 +0,0 @@
-
-(import (scheme base)
-        (chibi crypto rsa)
-        (chibi crypto sha2)
-        (chibi test))
-
-(test-begin "rsa")
-
-;; Verify an explicit key.
-
-;; p = 61, q = 53
-(define priv-key (rsa-key-gen-from-primes 8 61 53))
-(define pub-key (rsa-pub-key priv-key))
-
-(test 439 (rsa-sign priv-key 42))
-(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
-
-(let ((msg 42))
-  (test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
-
-(define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
-(define pub-key2 (rsa-pub-key priv-key2))
-
-(let ((msg 42))
-  (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
-
-(let ((msg #u8(42)))
-  (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
-
-(let ((msg "*"))
-  (test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
-
-(let ((msg "*"))
-  (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
-
-(let ((msg #u8(42)))
-  (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
-
-;; Key generation.
-
-(define (test-key key)
-  (test #t (rsa-key? key))
-  (test #t (positive? (rsa-key-n key)))
-  (test #t (positive? (rsa-key-e key)))
-  (test #t (positive? (rsa-key-d key)))
-  (test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
-
-(test-key (rsa-key-gen 8))
-(test-key (rsa-key-gen 16))
-(test-key (rsa-key-gen 32))
-(test-key (rsa-key-gen-from-primes 32 2936546443 3213384203))
-
-;; These are expensive to test.  Times with -h1G:
-;; (test-key (rsa-key-gen 128))   ; 0.04s
-;; (test-key (rsa-key-gen 256))   ; 0.4s
-;; (test-key (rsa-key-gen 512))   ; 4s
-;; (test-key (rsa-key-gen 1024))  ; 92s
-
-;; padding
-
-(test #u8(8 8 8 8 8 8 8 8) (pkcs1-pad #u8()))
-(test #u8(1 7 7 7 7 7 7 7) (pkcs1-pad #u8(1)))
-(test #u8(1 2 6 6 6 6 6 6) (pkcs1-pad #u8(1 2)))
-(test #u8(1 2 3 5 5 5 5 5) (pkcs1-pad #u8(1 2 3)))
-(test #u8(1 2 3 4 4 4 4 4) (pkcs1-pad #u8(1 2 3 4)))
-(test #u8(1 2 3 4 5 3 3 3) (pkcs1-pad #u8(1 2 3 4 5)))
-(test #u8(1 2 3 4 5 6 2 2) (pkcs1-pad #u8(1 2 3 4 5 6)))
-(test #u8(1 2 3 4 5 6 7 1) (pkcs1-pad #u8(1 2 3 4 5 6 7)))
-(test #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8) (pkcs1-pad #u8(1 2 3 4 5 6 7 8)))
-
-(test #u8() (pkcs1-unpad #u8(8 8 8 8 8 8 8 8)))
-(test #u8(1) (pkcs1-unpad #u8(1 7 7 7 7 7 7 7)))
-(test #u8(1 2) (pkcs1-unpad #u8(1 2 6 6 6 6 6 6)))
-(test #u8(1 2 3) (pkcs1-unpad #u8(1 2 3 5 5 5 5 5)))
-(test #u8(1 2 3 4) (pkcs1-unpad #u8(1 2 3 4 4 4 4 4)))
-(test #u8(1 2 3 4 5) (pkcs1-unpad #u8(1 2 3 4 5 3 3 3)))
-(test #u8(1 2 3 4 5 6) (pkcs1-unpad #u8(1 2 3 4 5 6 2 2)))
-(test #u8(1 2 3 4 5 6 7) (pkcs1-unpad #u8(1 2 3 4 5 6 7 1)))
-(test #u8(1 2 3 4 5 6 7 8) (pkcs1-unpad #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8)))
-
-(test-end)

tests/scribble-tests.scm

@@ -1,212 +0,0 @@
-
-(cond-expand
- (modules (import (chibi scribble) (only (chibi test) test-begin test test-end)))
- (else (load "lib/chibi/scribble.scm")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(test-begin "scribble")
-
-(define (test-scribble expect str)
-  (test (call-with-output-string (lambda (out) (write str out)))
-      expect
-    (call-with-input-string str scribble-parse)))
-
-(test-scribble '((foo "blah blah blah")) "\\foo{blah blah blah}")
-(test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
-(test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
-(test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
-(test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
-(test-scribble '((foo "blah blah" "\n" "     yada yada")) "\\foo{blah blah
-     yada yada}")
-(test-scribble '((foo "  blah blah" "\n" "  yada yada" "\n")) "\\foo{
-  blah blah
-  yada yada
-}")
-
-(test-scribble '((foo "bar " (baz "3") "\n" "     blah")) "\\foo{bar \\baz{3}
-     blah}")
-(test-scribble '((foo (b (u 3) " " (u "4")) "\n" "     blah")) "\\foo{\\b{\\u[3] \\u{4}}
-     blah}")
-(test-scribble '((C "while (*(p++))" "\n" "     *p = '\\n';")) "\\C{while (*(p++))
-     *p = '\\\"\\\\\"n';}")
-(test-scribble '(("blah blah")) "\\{blah blah}")
-(test-scribble '(("blah " (3))) "\\{blah \\[3]}")
-(test-scribble '(("foo" "\n" "   bar" "\n" "   baz")) "\\{foo
-   bar
-   baz}")
-(test-scribble '(foo) "\\foo")
-(test-scribble '(("blah " foo " blah")) "\\{blah \\foo blah}")
-(test-scribble '(("blah " foo: " blah")) "\\{blah \\foo: blah}")
-(test-scribble '(("blah " foo ": blah")) "\\{blah \\|foo|: blah}")
-(test-scribble '((foo "(+ 1 2) -> " (+ 1 2) "!")) "\\foo{(+ 1 2) -> \\(+ 1 2)!}")
-(test-scribble '((foo "A string escape")) "\\foo{A \\\"string\" escape}")
-(test-scribble '((foo "eli@barzilay.org")) "\\foo{eli@barzilay.org}")
-(test-scribble '((foo "eli\\barzilay.org")) "\\foo{eli\\\"\\\\\"barzilay.org}")
-(test-scribble '((foo "A { begins a block")) "\\foo{A \\\"{\" begins a block}")
-(test-scribble '((C "while (*(p++)) {" "\n" "     *p = '\\n';" "\n" "   }"))
- "\\C{while (*(p++)) {
-     *p = '\\\"\\\\\"n';
-   }}")
-(test-scribble '((foo "bar}\\{baz")) "\\foo|{bar}\\{baz}|")
-(test-scribble '((foo "bar " (x "X") " baz")) "\\foo|{bar |\\x{X} baz}|")
-(test-scribble '((foo "bar " (x "\\") " baz")) "\\foo|{bar |\\x|{\\}| baz}|")
-
-(test-scribble '((foo "bar}\\|{baz")) "\\foo|--{bar}\\|{baz}--|")
-(test-scribble '((foo "bar}\\|{baz")) "\\foo|<<{bar}\\|{baz}>>|")
-
-(test-scribble '((foo "bar " (baz 2 3) " {4 5}")) "\\foo{bar \\baz[2 3] {4 5}}")
-
-(test-scribble '(`',@(foo "blah")) "\\`',@foo{blah}")
-;;(test-scribble '(#`#'#,@(foo "blah")) "\\#`#'#,@foo{blah}")
-(test-scribble '(((lambda (x) x) "blah")) "\\(lambda (x) x){blah}")
-(test-scribble '(`(,foo  "blah")) "\\`(unquote foo){blah}")
-
-(test-scribble '(("foo bar" "\n" "  baz")) "\\{foo bar
-  baz}")
-(test-scribble '('("foo bar" "\n" "       baz")) "\\'{foo bar
-       baz}")
-(test-scribble '((foo "bar      baz     blah")) "\\foo{bar \\; comment
-     baz\\;
-     blah}")
-
-(test-scribble '((foo "x " y " z")) "\\foo{x \\y z}")
-(test-scribble '((foo "x " (* y 2) " z")) "\\foo{x \\(* y 2) z}")
-(test-scribble '((foo " bar")) "\\{\\foo bar}")
-(test-scribble '(((foo "bar") "baz")) "\\\\foo{bar}{baz}")
-
-(test-scribble '((foo 1 (* 2 3) "bar")) "\\foo[1 (* 2 3)]{bar}")
-(test-scribble '((foo (bar "...") "blah")) "\\foo[\\bar{...}]{blah}")
-(test-scribble '((foo bar)) "\\foo[bar]")
-(test-scribble '((foo "bar " (f x) " baz")) "\\foo{bar \\f[x] baz}")
-(test-scribble '((foo "bar")) "\\foo[]{bar}")
-(test-scribble '((foo)) "\\foo[]")
-(test-scribble '(foo) "\\foo")
-(test-scribble '((foo)) "\\foo{}")
-
-(test-scribble '((foo 'style: 'big  "bar")) "\\foo['style: 'big]{bar}")
-
-(test-scribble '((foo "f{o}o")) "\\foo{f{o}o}")
-(test-scribble '((foo "{{}}{}")) "\\foo{{{}}{}}")
-(test-scribble '((foo "bar")) "\\foo{bar}")
-(test-scribble '((foo " bar ")) "\\foo{ bar }")
-(test-scribble '((foo 1 " bar ")) "\\foo[1]{ bar }")
-
-(test-scribble '((foo "a " (bar "b") " c")) "\\foo{a \\bar{b} c}")
-(test-scribble '((foo "a " bar " c")) "\\foo{a \\bar c}")
-(test-scribble '((foo "a " (bar 2) " c")) "\\foo{a \\(bar 2) c}")
-(test-scribble '((foo "A } marks the end")) "\\foo{A \\\"}\" marks the end}")
-(test-scribble '((foo "The prefix: @.")) "\\foo{The prefix: \\\"@\".}")
-(test-scribble '((foo "The prefix: \\.")) "\\foo{The prefix: \\\"\\\\\".}")
-(test-scribble '((foo "\\x{y} --> (x \"y\")")) "\\foo{\\\"\\\\x{y}\" --> (x \"y\")}")
-
-(test-scribble '((foo "...")) "\\foo|{...}|")
-(test-scribble '((foo "\"}\" follows \"{\"")) "\\foo|{\"}\" follows \"{\"}|")
-(test-scribble '((foo "Nesting |{is}| ok")) "\\foo|{Nesting |{is}| ok}|")
-
-(test-scribble '((foo "Maze" "\n" "      " (bar "is") "\n" "      Life!"))
- "\\foo|{Maze
-      |\\bar{is}
-      Life!}|")
-(test-scribble '((t "In " (i "sub\\s") " too")) "\\t|{In |\\i|{sub|\\\"\\\\\"s}| too}|")
-(test-scribble '((foo "\\x{foo} |\\{bar}|.")) "\\foo|<<<{\\x{foo} |\\{bar}|.}>>>|")
-(test-scribble '((foo "X " (b "Y") "...")) "\\foo|!!{X |!!\\b{Y}...}!!|")
-
-(test-scribble '((foo "foo" bar.)) "\\foo{foo\\bar.}")
-(test-scribble '((foo "foo" bar ".")) "\\foo{foo\\|bar|.}")
-(test-scribble '((foo "foo" 3.0)) "\\foo{foo\\3.}")
-(test-scribble '((foo "foo" 3 ".")) "\\foo{foo\\|3|.}")
-(test-scribble '((foo "foo" (f 1) "{bar}")) "\\foo{foo\\|(f 1)|{bar}}")
-(test-scribble '((foo "foo" bar "[1]{baz}")) "\\foo{foo\\|bar|[1]{baz}}")
-(test-scribble '((foo "xyz")) "\\foo{x\\\"y\"z}")
-(test-scribble '((foo "x" "y" "z")) "\\foo{x\\|\"y\"|z}")
-(test-scribble '((foo "x" 1 (+ 2 3) 4 "y")) "\\foo{x\\|1 (+ 2 3) 4|y}")
-(test-scribble '((foo "x" * * "y")) "\\foo{x\\|*
-        *|y}")
-(test-scribble '((foo "Alice" "Bob" "Carol")) "\\foo{Alice\\||Bob\\|
-     |Carol}")
-(test-scribble '((blah)) "\\|{blah}|")
-(test-scribble '((blah blah)) "\\|{blah blah}|")
-
-(test-scribble '((foo "First line" "\n" "     Second line")) "\\foo{First line\\;{there is still a
-                  newline here;}
-     Second line}")
-(test-scribble '((foo "A long      single-     string arg.")) "\\foo{A long \\;
-     single-\\;
-     string arg.}")
-
-(test-scribble '((foo "bar")) "\\foo{bar}")
-(test-scribble '((foo " bar ")) "\\foo{ bar }")
-(test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
-     baz }")
-
-(test-scribble '((foo "bar" "\n")) "\\foo{bar
-}")
-(test-scribble '((foo "  bar" "\n") "\n") "\\foo{
-  bar
-}
-")
-(test-scribble '((foo "  bar" "\n" "\n")) "\\foo{
-
-  bar
-
-}")
-(test-scribble '((foo "  bar" "\n" "\n" "  baz" "\n")) "\\foo{
-  bar
-
-  baz
-}")
-(test-scribble '((foo)) "\\foo{
-}")
-(test-scribble '((foo)) "\\foo{
-
-}")
-(test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
-     baz }")
-
-(test-scribble '((foo "  bar" "\n" "  baz" "\n" "  blah" "\n")) "\\foo{
-  bar
-  baz
-  blah
-}")
-(test-scribble '((foo "  begin" "\n" "    x++;" "\n" "  end")) "\\foo{
-  begin
-    x++;
-  end}")
-(test-scribble '((foo "    a" "\n" "   b" "\n" "  c")) "\\foo{
-    a
-   b
-  c}")
-
-(test-scribble '((foo "bar" "\n" "       baz" "\n" "     bbb")) "\\foo{bar
-       baz
-     bbb}")
-(test-scribble '((foo " bar" "\n" "        baz" "\n" "      bbb")) "\\foo{ bar
-        baz
-      bbb}")
-(test-scribble '((foo "bar" "\n" "   baz" "\n" "   bbb")) "\\foo{bar
-   baz
-   bbb}")
-(test-scribble '((foo " bar" "\n" "   baz" "\n" "   bbb")) "\\foo{ bar
-   baz
-   bbb}")
-(test-scribble
- '((foo " bar" "\n" "   baz" "\n" "     bbb"))
- "\\foo{ bar
-   baz
-     bbb}")
-(test-scribble
- '((text "Some " (b "bold" "\n" "\n" "  text")", and" "\n" "\n" "  more text."))
- "\\text{Some \\b{bold
-
-  text}, and
-
-  more text.}")
-
-(test-scribble '((foo "  " " bar " "\n" "  " " baz")) "\\foo{
-  \\|| bar \\||
-  \\|| baz}")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(test-end)

tests/sha-tests.scm

@@ -1,24 +0,0 @@
-
-(import (chibi crypto sha2) (chibi test))
-
-(test-begin "sha2")
-
-(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
-    (sha-224 ""))
-(test "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7"
-    (sha-224 "abc"))
-(test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
-    (sha-224 "The quick brown fox jumps over the lazy dog"))
-
-(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
-    (sha-256 ""))
-(test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
-    (sha-256 "abc"))
-(test "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592"
-    (sha-256 "The quick brown fox jumps over the lazy dog"))
-(test "61f8fe4c4cdc8b3e10673933fcd0c5b1f6b46d3392550e42b265daefc7bc0d31"
-    (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
-(test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
-    (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
-
-(test-end)

tests/show-tests.scm

@@ -1,376 +0,0 @@
-
-(import (scheme base) (scheme read) (chibi test)
-        (chibi show) (chibi show base) (chibi show pretty))
-
-(test-begin "show")
-
-;; basic data types
-
-(test "hi" (show #f "hi"))
-(test "\"hi\"" (show #f (written "hi")))
-(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
-(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
-(test "#(1 2 3)" (show #f (written '#(1 2 3))))
-(test "(1 2 3)" (show #f (written '(1 2 3))))
-(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
-(test "ABC" (show #f (upcased "abc")))
-(test "abc" (show #f (downcased "ABC")))
-
-(test "abc     def" (show #f "abc" (tab-to) "def"))
-(test "abc  def" (show #f "abc" (tab-to 5) "def"))
-(test "abcdef" (show #f "abc" (tab-to 3) "def"))
-
-;; numbers
-
-(test "-1" (show #f -1))
-(test "0" (show #f 0))
-(test "1" (show #f 1))
-(test "10" (show #f 10))
-(test "100" (show #f 100))
-(test "-1" (show #f (numeric -1)))
-(test "0" (show #f (numeric 0)))
-(test "1" (show #f (numeric 1)))
-(test "10" (show #f (numeric 10)))
-(test "100" (show #f (numeric 100)))
-(test "57005" (show #f #xDEAD))
-(test "#xdead" (show #f (with ((radix 16)) #xDEAD)))
-(test "#xdead1234" (show #f (with ((radix 16)) #xDEAD) 1234))
-(test "de.ad"
-    (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
-(test "d.ead"
-    (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
-(test "0.dead"
-    (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
-(test "1g"
-    (show #f (with ((radix 17)) (numeric 33))))
-
-(test "3.14159" (show #f 3.14159))
-(test "3.14" (show #f (with ((precision 2)) 3.14159)))
-(test "3.14" (show #f (with ((precision 2)) 3.14)))
-(test "3.00" (show #f (with ((precision 2)) 3.)))
-(test "1.10" (show #f (with ((precision 2)) 1.099)))
-(test "0.00" (show #f (with ((precision 2)) 1e-17)))
-(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
-(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
-(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
-(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
-(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
-
-(test "   3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
-(test "  31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
-(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
-(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
-(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
-(test "  -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
-(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
-(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
-(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
-(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
-
-(cond
- ((exact? (/ 1 3)) ;; exact rationals
-  (test "333.333333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 1000/3))))
-  (test  "33.333333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 100/3))))
-  (test   "3.333333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 10/3))))
-  (test   "0.333333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 1/3))))
-  (test   "0.033333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 1/30))))
-  (test   "0.003333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 1/300))))
-  (test   "0.000333333333333333333333333333"
-      (show #f (with ((precision 30)) (numeric 1/3000))))
-  (test   "0.666666666666666666666666666667"
-      (show #f (with ((precision 30)) (numeric 2/3))))
-  (test   "0.090909090909090909090909090909"
-      (show #f (with ((precision 30)) (numeric 1/11))))
-  (test   "1.428571428571428571428571428571"
-      (show #f (with ((precision 30)) (numeric 10/7))))
-  (test "0.123456789012345678901234567890"
-      (show #f (with ((precision 30))
-                 (numeric (/  123456789012345678901234567890
-                              1000000000000000000000000000000)))))
-  (test  " 333.333333333333333333333333333333"
-      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
-  (test  "  33.333333333333333333333333333333"
-      (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
-  (test  "   3.333333333333333333333333333333"
-      (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
-  (test  "   0.333333333333333333333333333333"
-      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
-  ))
-
-(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
-(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
-
-(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
-
-(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
-(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
-(test "-29,97,92,458"
-    (show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
-(test "299.792.458"
-    (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
-(test "299.792.458,0"
-    (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
-
-(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
-(test "100,000.0"
-    (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
-(test "100,000.00"
-    (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
-
-(cond-expand
- (complex
-  (test "1+2i" (show #f (string->number "1+2i")))
-  (test "1.00+2.00i"
-      (show #f (with ((precision 2)) (string->number "1+2i"))))
-  (test "3.14+2.00i"
-      (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
-
-;; padding/trimming
-
-(test "abc  " (show #f (padded 5 "abc")))
-(test "  abc" (show #f (padded/left 5 "abc")))
-(test " abc " (show #f (padded/both 5 "abc")))
-(test "abcde" (show #f (padded 5 "abcde")))
-(test "abcdef" (show #f (padded 5 "abcdef")))
-
-(test "abc" (show #f (trimmed 3 "abcde")))
-(test "abc" (show #f (trimmed 3 "abcd")))
-(test "abc" (show #f (trimmed 3 "abc")))
-(test "ab" (show #f (trimmed 3 "ab")))
-(test "a" (show #f (trimmed 3 "a")))
-(test "cde" (show #f (trimmed/left 3 "abcde")))
-(test "bcd" (show #f (trimmed/both 3 "abcde")))
-(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
-(test "abc" (show #f (trimmed/lazy 3 "abcde")))
-(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
-
-(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
-(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
-(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
-(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
-(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
-
-(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
-(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
-(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
-(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
-(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
-
-(test "abcde"
-    (show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
-(test "ab..."
-    (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
-(test "abc..."
-    (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
-(test "abcde"
-    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
-(test "...ef"
-    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
-(test "...efg"
-    (show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
-(test "abcdefg"
-    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
-(test "...d..."
-    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
-(test "...e..."
-    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
-
-(test "abc  " (show #f (fitted 5 "abc")))
-(test "  abc" (show #f (fitted/left 5 "abc")))
-(test " abc " (show #f (fitted/both 5 "abc")))
-(test "abcde" (show #f (fitted 5 "abcde")))
-(test "abcde" (show #f (fitted/left 5 "abcde")))
-(test "abcde" (show #f (fitted/both 5 "abcde")))
-(test "abcde" (show #f (fitted 5 "abcdefgh")))
-(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
-(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
-
-(test "prefix: abc   :suffix"
-    (show #f "prefix: " (fitted 5 "abc") " :suffix"))
-(test "prefix:   abc :suffix"
-    (show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
-(test "prefix:  abc  :suffix"
-    (show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
-(test "prefix: abcde :suffix"
-    (show #f "prefix: " (fitted 5 "abcde") " :suffix"))
-(test "prefix: abcde :suffix"
-    (show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
-(test "prefix: abcde :suffix"
-    (show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
-(test "prefix: abcde :suffix"
-    (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
-(test "prefix: defgh :suffix"
-    (show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
-(test "prefix: bcdef :suffix"
-    (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
-
-;; joining
-
-(test "1 2 3" (show #f (joined each '(1 2 3) " ")))
-
-(test ":abc:123"
-    (show #f (joined/prefix
-              (lambda (x) (trimmed 3 x))
-              '("abcdef" "123456")
-              ":")))
-
-(test "abc\n123\n"
-    (show #f (joined/suffix
-              (lambda (x) (trimmed 3 x))
-              '("abcdef" "123456")
-              nl)))
-
-(test "lions, tigers, and bears"
-    (show #f (joined/last
-              each
-              (lambda (x) (each "and " x))
-              '(lions tigers bears)
-              ", ")))
-
-(test "lions, tigers, or bears"
-    (show #f (joined/dot
-              each
-              (lambda (x) (each "or " x))
-              '(lions tigers . bears)
-              ", ")))
-
-;; shared structures
-
-(test "#0=(1 . #0#)"
-    (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
-(test "(0 . #0=(1 . #0#))"
-    (show #f (written (let ((ones (list 1)))
-                        (set-cdr! ones ones)
-                        (cons 0 ones)))))
-(test "(sym . #0=(sym . #0#))"
-    (show #f (written (let ((syms (list 'sym)))
-                        (set-cdr! syms syms)
-                        (cons 'sym syms)))))
-(test "(#0=(1 . #0#) #1=(2 . #1#))"
-    (show #f (written (let ((ones (list 1))
-                            (twos (list 2)))
-                        (set-cdr! ones ones)
-                        (set-cdr! twos twos)
-                        (list ones twos)))))
-(test "(#0=(1 . #0#) #0#)"
-    (show #f (written (let ((ones (list 1)))
-                        (set-cdr! ones ones)
-                        (list ones ones)))))
-(test "((1) (1))"
-    (show #f (written (let ((ones (list 1)))
-                        (list ones ones)))))
-
-(test "(#0=(1) #0#)"
-    (show #f (written-shared (let ((ones (list 1)))
-                               (list ones ones)))))
-
-;; cycles without shared detection
-
-(test "(1 1 1 1 1"
-    (show #f (trimmed/lazy
-             10
-             (written-simply
-              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
-
-(test "(1 1 1 1 1 "
-    (show #f (trimmed/lazy
-             11
-             (written-simply
-              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
-
-;; pretty printing
-
-(define-syntax test-pretty
-  (syntax-rules ()
-    ((test-pretty str)
-     (let ((sexp (read (open-input-string str))))
-       (test str (show #f (pretty sexp)))))))
-
-(test-pretty "(foo bar)\n")
-
-(test-pretty
-"((self . aquanet-paper-1991)
- (type . paper)
- (title . \"Aquanet: a hypertext tool to hold your\"))
-")
-
-(test-pretty
-"(abracadabra xylophone
-             bananarama
-             yellowstonepark
-             cryptoanalysis
-             zebramania
-             delightful
-             wubbleflubbery)\n")
-
-(test-pretty
- "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
-  26 27 28 29 30 31 32 33 34 35 36 37)\n")
-
-(test-pretty
- "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
- 26 27 28 29 30 31 32 33 34 35 36 37)\n")
-
-(test-pretty
- "(define (fold kons knil ls)
-  (define (loop ls acc)
-    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
-  (loop ls knil))\n")
-
-(test-pretty
-"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
-
-(test-pretty
-"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
-  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
-
-(test-pretty
-"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
-    ((= index 5) my-vector)
-  (vector-set! my-vector index index))\n")
-
-(test-pretty
- "(define (fold kons knil ls)
-  (let loop ((ls ls) (acc knil))
-    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
-
-(test-pretty
- "(define (file->sexp-list pathname)
-  (call-with-input-file pathname
-    (lambda (port)
-      (let loop ((res '()))
-        (let ((line (read port)))
-          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
-
-(test-pretty
- "(design
- (module (name \"\\\\testshiftregister\")
-         (attributes
-          (attribute (name \"\\\\src\") (value \"testshiftregister.v:10\"))))
- (wire (name \"\\\\shreg\")
-       (attributes
-        (attribute (name \"\\\\src\") (value \"testshiftregister.v:15\")))))\n")
-
-(test "(let ((ones '#0=(1 . #0#))) ones)\n"
-    (show #f (pretty (let ((ones (list 1)))
-                       (set-cdr! ones ones)
-                       `(let ((ones ',ones)) ones)))))
-
-'(test
-"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
-      (ones '#0=(1 . #0#)))
-  (append zeros ones))\n"
-    (show #f (pretty
-              (let ((ones (list 1)))
-                (set-cdr! ones ones)
-                `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
-                       (ones ',ones))
-                   (append zeros ones))))))
-
-(test-end)

tests/sort-tests.scm

@@ -1,115 +0,0 @@
-
-(cond-expand
- (modules (import (srfi 95) (only (chibi test) test-begin test test-end)))
- (else #f))
-
-(test-begin "sorting")
-
-(test "sort null" '() (sort '()))
-(test "sort null <" '() (sort '() <))
-(test "sort null < car" '() (sort '() < car))
-(test "sort equal list" '(0 0 0 0 0 0 0 0 0) (sort '(0 0 0 0 0 0 0 0 0)))
-(test "sort equal list cmp" '(0 0 0 0 0 0 0 0 0)
-  (sort '(0 0 0 0 0 0 0 0 0) (lambda (a b) (< a b))))
-(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
-(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
-(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
-(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
-(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
-(test "sort short equal list" '(0 0 0) (sort '(0 0 0)))
-(test "sort short random list" '(1 2 3) (sort '(2 1 3)))
-(test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b))))
-(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)
-  (sort '(7 5 2 8 1 6 4 9 3) <))
-(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9))
-  (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car))
-(test "sort list (lambda (a b) (< (car a) (car b)))"
-    '((1) (2) (3) (4) (5) (6) (7) (8) (9))
-  (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3))
-        (lambda (a b) (< (car a) (car b)))))
-(test "sort 1-char symbols" '(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" '(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 symbol"
-    '(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 "sort lists"
-    '((chibi) (scheme r5rs) (scheme write))
-  (sort '((chibi) (scheme r5rs) (scheme write))
-        (lambda (a b)
-          (string<? (call-with-output-string (lambda (out) (write a out)))
-                    (call-with-output-string (lambda (out) (write b out)))))))
-
-(test "sort numeric inexact vector <" '#(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9)
-  (sort '#(7.7 5.5 2.2 8.8 1.1 6.6 4.4 9.9 3.3) <))
-(test "sort numeric signed inexact vector <"
-    '#(-9.9 -7.7 -5.5 -3.3 -1.1 2.2 4.4 6.6 8.8)
-  (sort '#(-7.7 -5.5 2.2 8.8 -1.1 6.6 4.4 -9.9 -3.3) <))
-(test "sort numeric same whole number inexact vector"
-    '#(-5.2155
-       -4.3817
-       -4.3055
-       -4.0415
-       -3.5883
-       -3.5714
-       -3.4059
-       -2.7829
-       -2.6406
-       -2.4985
-       -2.4607
-       -1.2487
-       -0.537800000000001
-       -0.481999999999999
-       -0.469100000000001
-       -0.0932999999999993
-       0.0066999999999986)
-  (sort '#(-5.2155
-           -3.5714
-           -4.3817
-           -3.5883
-           -4.3055
-           -2.4985
-           -4.0415
-           -3.4059
-           -0.0932999999999993
-           -0.537800000000001
-           -2.6406
-           -0.481999999999999
-           -2.7829
-           -2.4607
-           -1.2487
-           -0.469100000000001
-           0.0066999999999986)
-        <))
-
-(test "sort watson no dups"
-    '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
-       -0.300599999999999 -0.3003 -0.3002 -0.2942)
-  (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
-           -0.300599999999999 -0.2942 -0.3003 -0.3002)))
-
-(test "sort watson"
-    '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
-       -0.300599999999999 -0.3003 -0.3003 -0.3002 -0.2942)
-  (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
-           -0.300599999999999 -0.2942 -0.3003 -0.3003 -0.3002)))
-
-(test "sort ratios" '(1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5)
-  (sort '(1/2 1/3 1/4 1/5 2/3 3/4 2/5 3/5 4/5)))
-
-(test "sort complex" '(1+1i 1+2i 1+3i 2+2i 3+3i 4+4i 5+5i 6+6i 7+7i 8+8i 9+9i)
-  (sort '(7+7i 1+2i 5+5i 2+2i 8+8i 1+1i 6+6i 4+4i 9+9i 1+3i 3+3i)))
-
-(test-end)

tests/srfi-1-tests.scm

@@ -1,170 +0,0 @@
-(import (chibi) (chibi test) (srfi 1))
-
-(test-begin "srfi-1")
-
-;; srfi-1 examples
-;; http://srfi.schemers.org/srfi-1/srfi-1.html
-(test '(a) (cons 'a '()))
-(test '((a) b c d) (cons '(a) '(b c d)))
-(test '("a" b c) (cons "a" '(b c)))
-(test '(a . 3) (cons 'a 3))
-(test '((a b) . c) (cons '(a b) 'c))
-(test '(a 7 c) (list 'a (+ 3 4) 'c))
-(test '() (list))
-(test '(a b c) (xcons '(b c) 'a))
-(test '(1 2 3 . 4) (cons* 1 2 3 4))
-(test 1 (cons* 1))
-(test '(c c c c) (make-list 4 'c))
-(test '(0 1 2 3) (list-tabulate 4 values))
-(test '(z q z q z q) (take (circular-list 'z 'q) 6))
-(test '(0 1 2 3 4) (iota 5))
-(test '(0 -0.1 -0.2 -0.3 -0.4)
-    (let ((res (iota 5 0 -0.1)))
-      (cons (inexact->exact (car res)) (cdr res))))
-(test #t (pair? '(a . b)))
-(test #t (pair? '(a b c)))
-(test #f (pair? '()))
-(test #f (pair? '#(a b)))
-(test #f (pair? 7))
-(test #f (pair? 'a))
-(test #t (list= eq?))
-(test #t (list= eq? '(a)))
-(test 'a (car '(a b c)))
-(test '(b c)   (cdr '(a b c)))
-(test '(a) (car '((a) b c d)))
-(test '(b c d) (cdr '((a) b c d)))
-(test '1 (car '(1 . 2)))
-(test '2 (cdr '(1 . 2)))
-(test-error (car '()))
-(test-error (cdr '()))
-(test 'c (list-ref '(a b c d) 2))
-(test 'c (third '(a b c d e)))
-(test '(a b) (take '(a b c d e)  2))
-(test '(c d e) (drop '(a b c d e)  2))
-(test '(1 2) (take '(1 2 3 . d) 2))
-(test '(3 . d) (drop '(1 2 3 . d) 2))
-(test '(1 2 3) (take '(1 2 3 . d) 3))
-(test 'd (drop '(1 2 3 . d) 3))
-(test '(d e) (take-right '(a b c d e) 2))
-(test '(a b c) (drop-right '(a b c d e) 2))
-(test '(2 3 . d) (take-right '(1 2 3 . d) 2))
-(test '(1) (drop-right '(1 2 3 . d) 2))
-(test 'd (take-right '(1 2 3 . d) 0))
-(test '(1 2 3) (drop-right '(1 2 3 . d) 0))
-(test-assert (member (take! (circular-list 1 3 5) 8) '((1 3) (1 3 5 1 3 5 1 3)) equal?))
-(test-values (values '(a b c) '(d e f g h)) (split-at '(a b c d e f g h) 3))
-(test 'c (last '(a b c)))
-(test '(c) (last-pair '(a b c)))
-(test '(x y) (append '(x) '(y)))
-(test '(a b c d) (append '(a) '(b c d)))
-(test '(a (b) (c)) (append '(a (b)) '((c))))
-(test '(a b c . d) (append '(a b) '(c . d)))
-(test 'a (append '() 'a))
-(test '(x y) (append '(x y)))
-(test '() (append))
-(test '(c b a) (reverse '(a b c)))
-(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
-(test '((one 1 odd) (two 2 even) (three 3 odd)) (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even)))
-(test '((1) (2) (3)) (zip '(1 2 3)))
-(test '((3 #f) (1 #t) (4 #f) (1 #t)) (zip '(3 1 4 1) (circular-list #f #t)))
-(test-values (values '(1 2 3) '(one two three)) (unzip2 '((1 one) (2 two) (3 three))))
-(test 3 (count even? '(3 1 4 1 5 9 2 5 6)))
-(test 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
-(test 2 (count < '(3 1 4 1) (circular-list 1 10)))
-(test '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
-(test '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
-(test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
-(test '((a b c) (1 2 3) (b c) (2 3) (c) (3)) (pair-fold-right cons* '() '(a b c) '(1 2 3)))
-(test '(b e h) (map cadr '((a b) (d e) (g h))))
-(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
-(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
-(test-assert (member (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))) '((1 2) (2 1)) equal?))
-(test '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0)))
-(test '#(0 1 4 9 16) (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v))
-(test '(1 -1 3 -3 8 -8) (append-map (lambda (x) (list x (- x))) '(1 3 8)))
-(test '(1 -1 3 -3 8 -8) (apply append (map (lambda (x) (list x (- x))) '(1 3 8))))
-(test '(1 -1 3 -3 8 -8) (append-map! (lambda (x) (list x (- x))) '(1 3 8)))
-(test '(1 -1 3 -3 8 -8) (apply append! (map (lambda (x) (list x (- x))) '(1 3 8))))
-(test "pair-for-each-1" '((a b c) (b c) (c))
-      (let ((a '()))
-        (pair-for-each (lambda (x) (set! a (cons x a))) '(a b c))
-        (reverse a)))
-(test '(1 9 49) (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
-(test '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
-(test-values (values '(one four five) '(2 3 6)) (partition symbol? '(one 2 3 four five 6)))
-(test '(7 43) (remove even? '(0 7 8 8 43 -4)))
-(test 2 (find even? '(1 2 3)))
-(test #t (any  even? '(1 2 3)))
-(test #f (find even? '(1 7 3)))
-(test #f (any  even? '(1 7 3)))
-;(test-error (find even? '(1 3 . x)))
-;(test-error (any  even? '(1 3 . x)))
-;(test 'error/undefined (find even? '(1 2 . x)))
-;(test 'error/undefined (any  even? '(1 2 . x))) ; success, error or other
-(test 6 (find even? (circular-list 1 6 3)))
-(test #t (any  even? (circular-list 1 6 3)))
-;(test-error (find even? (circular-list 1 3))) ; divergent
-;(test-error (any even? (circular-list 1 3))) ; divergent
-(test 4 (find even? '(3 1 4 1 5 9)))
-(test #f (every odd? '(1 2 3)))
-(test #t (every < '(1 2 3) '(4 5 6)))
-(test-error (every odd? '(1 3 . x)))
-(test '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
-(test '#f (find-tail even? '(3 1 37 -5)))
-(test '(2 18) (take-while even? '(2 18 3 10 22 9)))
-(test '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
-(test-values (values '(2 18) '(3 10 22 9)) (span even? '(2 18 3 10 22 9)))
-(test-values (values '(3 1) '(4 1 5 9)) (break even? '(3 1 4 1 5 9)))
-(test #t (any integer? '(a 3 b 2.7)))
-(test #f (any integer? '(a 3.1 b 2.7)))
-(test #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
-(test 2 (list-index even? '(3 1 4 1 5 9)))
-(test 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
-(test #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
-(test '(a b c) (memq 'a '(a b c)))
-(test '(b c) (memq 'b '(a b c)))
-(test #f (memq 'a '(b c d)))
-(test #f (memq (list 'a) '(b (a) c)))
-(test '((a) c) (member (list 'a) '(b (a) c)))
-;(test '*unspecified* (memq 101 '(100 101 102)))
-(test '(101 102) (memv 101 '(100 101 102)))
-(test '(a b c z) (delete-duplicates '(a b a c a b c z)))
-(test '((a . 3) (b . 7) (c . 1)) (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))))
-(let ((e '((a 1) (b 2) (c 3))))
-  (test '(a 1) (assq 'a e))
-  (test '(b 2) (assq 'b e))
-  (test #f (assq 'd e))
-  (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
-  (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
-  ;(test '*unspecified* (assq 5 '((2 3) (5 7) (11 13))))
-  (test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))))
-(test #t (lset<= eq? '(a) '(a b a) '(a b c c)))
-(test #t (lset<= eq?))
-(test #t (lset<= eq? '(a)))
-(test #f (lset= eq? '(a) '()))
-(test #f (lset= eq? '() '(a)))
-(test #t (lset= eq? '(b e a) '(a e b) '(e e b a)))
-(test #t (lset= eq?))
-(test #t (lset= eq? '(a)))
-(test #f (lset= = '(2 1) '(2 1 0)))
-(test #t (lset<= = '(2 1) '(2 1 0)))
-(test #f (lset<= = '(2 1 0) '(2 1)))
-(test '(u o i a b c d c e) (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u))
-(test '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u)))
-(test '(x a a c) (lset-union eq? '(a a c) '(x a x)))
-(test '() (lset-union eq?))
-(test '(a b c) (lset-union eq? '(a b c)))
-(test '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u)))
-(test '(a x a) (lset-intersection eq? '(a x y a) '(x a x z)))
-(test '(a b c) (lset-intersection eq? '(a b c)))
-(test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
-(test '(a b c) (lset-difference eq? '(a b c)))
-(test #t (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))))
-(test '() (lset-xor eq?))
-(test '(a b c d e) (lset-xor eq? '(a b c d e)))
-(let ((f (lambda () (list 'not-a-constant-list)))
-      (g (lambda () '(constant-list))))
-  ;(test '*unspecified* (set-car! (f) 3))
-  (test-error (set-car! (g) 3)))
-
-(test-end)

tests/srfi-16-tests.scm

@@ -1,45 +0,0 @@
-
-(cond-expand
- (modules (import (chibi) (chibi test) (srfi 16)))
- (else #f))
-
-(define plus
-  (case-lambda 
-   (() 0)
-   ((x) x)
-   ((x y) (+ x y))
-   ((x y z) (+ (+ x y) z))
-   (args (apply + args))))
-
-(test-begin "case-lambda")
-
-(test 0 (plus))
-(test 1 (plus 1))
-(test 6 (plus 1 2 3))
-(test-error ((case-lambda ((a) a) ((a b) (* a b))) 1 2 3))
-
-(define print
-  (case-lambda
-   (()
-    (display ""))
-   ((arg)
-    (display arg))
-   ((arg . args)
-    (display arg)
-    (display " ")
-    (apply print args))))
-
-(define (print-to-string . args)
-  (let ((out (open-output-string))
-        (old-out (current-output-port)))
-    (dynamic-wind
-      (lambda () (current-output-port out))
-      (lambda () (apply print args))
-      (lambda () (current-output-port old-out)))
-    (get-output-string out)))
-
-(test "" (print-to-string))
-(test "hi" (print-to-string 'hi))
-(test "hi there world" (print-to-string 'hi 'there 'world))
-
-(test-end)

tests/srfi-2-tests.scm

@@ -1,43 +0,0 @@
-
-(import (chibi) (srfi 2) (chibi test))
-
-(test-begin "srfi-2")
-
-(test 1 (and-let* () 1))
-(test 2 (and-let* () 1 2))
-(test #t (and-let* () ))
-
-(test #f (let ((x #f)) (and-let* (x))))
-(test 1 (let ((x 1)) (and-let* (x))))
-(test #f (and-let* ((x #f)) ))
-(test 1 (and-let* ((x 1)) ))
-;; (test-syntax-error (and-let* ( #f (x 1))))
-(test #f (and-let* ( (#f) (x 1)) ))
-;; (test-syntax-error (and-let* (2 (x 1))))
-(test 1 (and-let* ( (2) (x 1)) ))
-(test 2 (and-let* ( (x 1) (2)) ))
-(test #f (let ((x #f)) (and-let* (x) x)))
-(test "" (let ((x "")) (and-let* (x) x)))
-(test "" (let ((x "")) (and-let* (x)  )))
-(test 2 (let ((x 1)) (and-let* (x) (+ x 1))))
-(test #f (let ((x #f)) (and-let* (x) (+ x 1))))
-(test 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1))))
-(test #t (let ((x 1)) (and-let* (((positive? x))) )))
-(test #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1))))
-(test 3  (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))))
-(test 4
-    (let ((x 1))
-      (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
-
-(test 2 (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))))
-(test 2 (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
-(test #f (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))))
-(test #f (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))))
-(test #f (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
-
-(test  #f (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
-(test  #f (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
-(test  #f (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
-(test  3/2 (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
-
-(test-end)

tests/srfi-26-tests.scm

@@ -1,16 +0,0 @@
-
-(import (chibi) (srfi 26) (chibi test))
-
-(test-begin "srfi-26")
-
-(let ((x 'orig))
-  (let ((f (cute list x)))
-    (set! x 'wrong)
-    (test '(orig) (f))))
-
-(let ((x 'wrong))
-  (let ((f (cut list x)))
-    (set! x 'right)
-    (test '(right) (f))))
-
-(test-end)

tests/srfi-27-tests.scm

@@ -1,28 +0,0 @@
-
-(import (chibi)
-        (srfi 27)
-        (chibi test))
-
-(test-begin "srfi-27")
-
-(define (test-random rand n)
-  (test-assert (<= 0 (rand n) (- n 1))))
-
-(let ((rs (make-random-source)))
-  ;; chosen by fair dice roll.  guaranteed to be random
-  (random-source-pseudo-randomize! rs 4 4)
-  (let ((rand (random-source-make-integers rs)))
-    (do ((k 0 (+ k 5))
-         (n 1 (* n 2)))
-        ((> k 1024))
-      (test-random rand n))
-    (let* ((state (random-source-state-ref rs))
-           (x (rand 1000000)))
-      ;; the next int won't be the same, but it will be after
-      ;; resetting the state
-      (test-not (= x (rand 1000000)))
-      (random-source-state-set! rs state)
-      ;; (test x (rand 1000000))
-      )))
-
-(test-end)

tests/srfi-33-tests.scm

@@ -1,61 +0,0 @@
-
-(import (chibi) (srfi 33) (chibi test))
-
-(test-begin "srfi-33")
-
-(test 0 (bitwise-and #b0 #b1))
-(test 1 (bitwise-and #b1 #b1))
-(test 0 (bitwise-and #b1 #b10))
-(test #b10 (bitwise-and #b11 #b10))
-(test #b101 (bitwise-and #b101 #b111))
-(test #b111 (bitwise-and -1 #b111))
-(test #b110 (bitwise-and -2 #b111))
-(test 3769478 (bitwise-and -4290775858 1694076839))
-(test 1680869008 (bitwise-and -193073517 1689392892))
-;; (test -2600468497 (bitwise-ior 1694076839 -4290775858))
-;; (test -184549633 (bitwise-ior -193073517 1689392892))
-;; (test -2604237975 (bitwise-xor 1694076839 -4290775858))
-;; (test -1865418641 (bitwise-xor -193073517 1689392892))
-
-(test 1 (arithmetic-shift 1 0))
-(test 2 (arithmetic-shift 1 1))
-(test 4 (arithmetic-shift 1 2))
-(test 8 (arithmetic-shift 1 3))
-(test 16 (arithmetic-shift 1 4))
-(test (expt 2 31) (arithmetic-shift 1 31))
-(test (expt 2 32) (arithmetic-shift 1 32))
-(test (expt 2 33) (arithmetic-shift 1 33))
-(test (expt 2 63) (arithmetic-shift 1 63))
-(test (expt 2 64) (arithmetic-shift 1 64))
-(test (expt 2 65) (arithmetic-shift 1 65))
-(test (expt 2 127) (arithmetic-shift 1 127))
-(test (expt 2 128) (arithmetic-shift 1 128))
-(test (expt 2 129) (arithmetic-shift 1 129))
-(test 3028397001194014464 (arithmetic-shift 11829675785914119 8))
-
-(test -1 (arithmetic-shift -1 0))
-(test -2 (arithmetic-shift -1 1))
-(test -4 (arithmetic-shift -1 2))
-(test -8 (arithmetic-shift -1 3))
-(test -16 (arithmetic-shift -1 4))
-(test (- (expt 2 31)) (arithmetic-shift -1 31))
-(test (- (expt 2 32)) (arithmetic-shift -1 32))
-(test (- (expt 2 33)) (arithmetic-shift -1 33))
-(test (- (expt 2 63)) (arithmetic-shift -1 63))
-(test (- (expt 2 64)) (arithmetic-shift -1 64))
-(test (- (expt 2 65)) (arithmetic-shift -1 65))
-(test (- (expt 2 127)) (arithmetic-shift -1 127))
-(test (- (expt 2 128)) (arithmetic-shift -1 128))
-(test (- (expt 2 129)) (arithmetic-shift -1 129))
-
-(test 0 (arithmetic-shift 1 -63))
-(test 0 (arithmetic-shift 1 -64))
-(test 0 (arithmetic-shift 1 -65))
-
-(test #x1000000000000000100000000000000000000000000000000
-    (arithmetic-shift #x100000000000000010000000000000000 64))
-
-(test-not (bit-set? 64 1))
-(test-assert (bit-set? 64 #x10000000000000000))
-
-(test-end)

tests/srfi-38-tests.scm

@@ -1,98 +0,0 @@
-
-(cond-expand
- (chibi (import (chibi) (chibi test) (srfi 1) (srfi 38)))
- (chicken (use chicken test srfi-38)))
-
-(test-begin "read/write")
-
-(define (read-from-string str)
-  (call-with-input-string str
-    (lambda (in) (read/ss in))))
-
-(define (write-to-string x . o)
-  (call-with-output-string
-    (lambda (out) (apply write/ss x out o))))
-
-(define-syntax test-io
-  (syntax-rules ()
-    ((test-io str-expr expr)
-     (let ((str str-expr)
-           (value expr))
-       (test str (write-to-string value))
-       (test str (write-to-string (read-from-string str)))))))
-
-(define-syntax test-cyclic-io
-  (syntax-rules ()
-    ((test-io str-expr expr)
-     (let ((str str-expr)
-           (value expr))
-       (test str (write-to-string value #t))
-       (test str (write-to-string (read-from-string str) #t))))))
-
-(test-io "(1)" (list 1))
-(test-io "(1 2)" (list 1 2))
-(test-io "(1 . 2)" (cons 1 2))
-
-(test-io "#0=(1 . #0#)" (circular-list 1))
-(test-io "#0=(1 2 . #0#)" (circular-list 1 2))
-(test-io "(1 . #0=(2 . #0#))" (cons 1 (circular-list 2)))
-(test-io "#0=(1 #0# 3)"
-         (let ((x (list 1 2 3))) (set-car! (cdr x) x) x))
-(test-io "(#0=(1 #0# 3))"
-         (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x)))
-(test-io "(#0=(1 #0# 3) #0#)"
-         (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x x)))
-(test-io "(#0=(1 . #0#) #1=(1 . #1#))"
-         (list (circular-list 1) (circular-list 1)))
-
-(test-io "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
-         (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
-           (list a b c a b c)))
-(test-cyclic-io "((1 . 2) (1 . 2) (3 . 4) (1 . 2) (1 . 2) (3 . 4))"
-                (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
-                  (list a b c a b c)))
-(test-cyclic-io "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
-                (let* ((a (cons 1 2))
-                       (b (cons 1 2))
-                       (c (cons 3 4))
-                       (ls (list a b c)))
-                  (set-cdr! (cddr ls) ls)
-                  ls))
-
-(test-io "#0=#(#0#)"
-         (let ((x (vector 1))) (vector-set! x 0 x) x))
-(test-io "#0=#(1 #0#)"
-         (let ((x (vector 1 2))) (vector-set! x 1 x) x))
-(test-io "#0=#(1 #0# 3)"
-         (let ((x (vector 1 2 3))) (vector-set! x 1 x) x))
-(test-io "(#0=#(1 #0# 3))"
-         (let ((x (vector 1 2 3))) (vector-set! x 1 x) (list x)))
-(test-io "#0=#(#0# 2 #0#)"
-         (let ((x (vector 1 2 3)))
-           (vector-set! x 0 x)
-           (vector-set! x 2 x)
-           x))
-
-(test 255 (read-from-string "#xff"))
-(test 99 (read-from-string "#d99"))
-(test 63 (read-from-string "#o77"))
-(test 3 (read-from-string "#b11"))
-(test 5 (read-from-string "#e5.0"))
-(test 5.0 (read-from-string "#i5"))
-(test 15 (read-from-string "#e#xf"))
-(test 15.0 (read-from-string "#i#xf"))
-(test (expt 10 100) (read-from-string "#e1e100"))
-
-(cond-expand
- (chicken
-  (test-io "(#0=\"abc\" #0# #0#)"
-           (let ((str (string #\a #\b #\c))) (list str str str)))
-  (test "(\"abc\" \"abc\" \"abc\")"
-      (let ((str (string #\a #\b #\c)))
-        (call-with-output-string
-          (lambda (out)
-            (write/ss (list str str str) out ignore-strings: #t))))))
- (else
-  ))
-
-(test-end)

tests/string-tests.scm

@@ -1,82 +0,0 @@
-
-(cond-expand
- (modules (import (only (chibi test) test-begin test test-end)
-                  (chibi string)))
- (else #f))
-
-(test-begin "strings")
-
-(test #t (string-null? ""))
-(test #f (string-null? " "))
-
-(test #t (string-every char-alphabetic? "abc"))
-(test #f (string-every char-alphabetic? "abc0"))
-(test #f (string-every char-alphabetic? " abc"))
-(test #f (string-every char-alphabetic? "a.c"))
-
-(define (digit-value ch)
-  (case ch
-    ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
-    ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
-
-(test 3 (string-any digit-value "a3c"))
-(test #f (string-any digit-value "abc"))
-
-(test 0 (string-find "abc" char-alphabetic?))
-(test 3 (string-find "abc0" char-numeric?))
-(test 3 (string-find "abc" char-numeric?))
-
-(test 3 (string-find-right "abc" char-alphabetic?))
-(test 4 (string-find-right "abc0" char-numeric?))
-(test 0 (string-find-right "abc" char-numeric?))
-
-(test 0 (string-skip "abc" char-numeric?))
-(test 3 (string-skip "abc0" char-alphabetic?))
-(test 3 (string-skip "abc" char-alphabetic?))
-
-(test 3 (string-skip-right "abc" char-numeric?))
-(test 4 (string-skip-right "abc0" char-alphabetic?))
-(test 0 (string-skip-right "abc" char-alphabetic?))
-
-(test "foobarbaz" (string-join '("foo" "bar" "baz")))
-(test "foo bar baz" (string-join '("foo" "bar" "baz") " "))
-
-(test '() (string-split ""))
-(test '("" "") (string-split " "))
-(test '("foo" "bar" "baz") (string-split "foo bar baz"))
-(test '("foo" "bar" "baz" "") (string-split "foo bar baz "))
-(test '("foo" "bar" "baz") (string-split "foo:bar:baz" #\:))
-(test '("" "foo" "bar" "baz") (string-split ":foo:bar:baz" #\:))
-(test '("foo" "bar" "baz" "") (string-split "foo:bar:baz:" #\:))
-(test '("foo" "bar:baz") (string-split "foo:bar:baz" #\: 2))
-
-(test "abc" (string-trim-left "  abc"))
-(test "abc  " (string-trim-left "abc  "))
-(test "abc  " (string-trim-left "  abc  "))
-
-(test "  abc" (string-trim-right "  abc"))
-(test "abc" (string-trim-right "abc  "))
-(test "  abc" (string-trim-right "  abc  "))
-
-(test "abc" (string-trim "  abc"))
-(test "abc" (string-trim "abc  "))
-(test "abc" (string-trim "  abc  "))
-(test "" (string-trim ""))
-(test "" (string-trim " "))
-(test "" (string-trim "  "))
-
-(test #t (string-prefix? "abc" "abc"))
-(test #t (string-prefix? "abc" "abcde"))
-(test #f (string-prefix? "abcde" "abc"))
-
-(test #t (string-suffix? "abc" "abc"))
-(test #f (string-suffix? "abc" "abcde"))
-(test #f (string-suffix? "abcde" "abc"))
-(test #f (string-suffix? "abcde" "cde"))
-(test #t (string-suffix? "cde" "abcde"))
-
-(test 3 (string-count "!a0 bc /.," char-alphabetic?))
-
-(test "ABC" (string-map char-upcase "abc"))
-
-(test-end)

tests/system-tests.scm

@@ -1,35 +0,0 @@
-
-(cond-expand
- (modules (import (chibi system) (only (chibi test) test-begin test test-end)))
- (else #f))
-
-(test-begin "system")
-
-(test #t (user? (user-information (current-user-id))))
-(test #f (user? #f))
-(test #f (user? (list #f)))
-(test #t (string? (user-name (user-information (current-user-id)))))
-(test #t (string? (user-password (user-information (current-user-id)))))
-(test #t (integer? (user-id (user-information (current-user-id)))))
-(test #t (integer? (user-group-id (user-information (current-user-id)))))
-(test #t (string? (user-gecos (user-information (current-user-id)))))
-(test #t (string? (user-home (user-information (current-user-id)))))
-(test #t (string? (user-shell (user-information (current-user-id)))))
-
-(test (current-user-id) (user-id (user-information (current-user-id))))
-(test (current-group-id) (user-group-id (user-information (current-user-id))))
-
-(test (user-id (user-information (current-user-id)))
-    (user-id (user-information (user-name (user-information (current-user-id))))))
-
-(test #t (integer? (current-session-id)))
-
-;; stress test user-name
-(test (user-name (user-information (current-user-id)))
-    (user-name (user-information (current-user-id))))
-(define u (user-information (current-user-id)))
-(test (user-name u) (user-name (user-information (current-user-id))))
-(define un (user-name (user-information (current-user-id))))
-(test un (user-name (user-information (current-user-id))))
-
-(test-end)

tests/tar-tests.scm

@@ -1,73 +0,0 @@
-
-(import (chibi)
-        (only (scheme base)
-              bytevector-append
-              make-bytevector
-              string->utf8
-              bytevector
-              open-input-bytevector
-              open-output-bytevector
-              get-output-bytevector
-              )
-        (chibi tar)
-        (chibi test))
-
-(test-begin "tar")
-
-;; Utility to flatten bytevectors, strings and individual bytes
-;; (integers) into a single bytevector for generating readable test
-;; data.  (<byte> . <repetition>) can be used to repeat a byte.
-(define (bv . args)
-  (apply bytevector-append
-         (map (lambda (x)
-                (cond ((string? x) (string->utf8 x))
-                      ((pair? x) (make-bytevector (cdr x) (car x)))
-                      ((integer? x) (bytevector x))
-                      (else x)))
-              args)))
-
-(let ((b (bv "foo" '(0 . 97)
-             "000644 " 0
-             "000765 " 0
-             "000765 " 0
-             "00000000016 "
-             "12302104616 "
-             "011512" 0 " "
-             "0"
-             '(0 . 100)
-             "ustar" 0 "00"
-             "bob" '(0 . 29)
-             "bob" '(0 . 29)
-             "000000 " 0
-             "000000 " 0
-             '(0 . 155)
-             '(0 . 12)
-             )))
-  (let ((x (read-tar (open-input-bytevector b))))
-    (test "foo" (tar-path x))
-    (test 501 (tar-uid x))
-    (test "bob" (tar-owner x)))
-  (let ((x (make-tar)))
-    (tar-path-set! x "bar")
-    (tar-mode-set! x #o644)
-    (tar-uid-set! x 501)
-    (tar-gid-set! x 502)
-    (tar-size-set! x 123)
-    (tar-time-set! x 456)
-    (tar-ustar-set! x "ustar")
-    (tar-owner-set! x "john")
-    (tar-group-set! x "john")
-    (test "bar" (tar-path x))
-    (test-error (tar-mode-set! x "r"))
-    (let ((out (open-output-bytevector)))
-      (write-tar x out)
-      (let ((bv2 (get-output-bytevector out)))
-        (test-assert (bytevector? bv2))
-        (let ((x2 (read-tar (open-input-bytevector bv2))))
-          (test-assert "bar" (tar-path x2))
-          (test-assert #o644 (tar-mode x2))
-          (test-assert 501 (tar-uid x2))
-          (test-assert 502 (tar-gid x2))
-          (test-assert "john" (tar-owner x2)))))))
-
-(test-end)

tests/term-ansi-tests.scm

@@ -1,170 +0,0 @@
-(import (chibi)
-        (only (scheme base) parameterize)
-        (chibi test)
-        (chibi term ansi))
-
-(test-begin "term.ansi")
-
-(test-assert (procedure? ansi-escapes-enabled?))
-(test-assert
- (let ((tag (cons #t #t)))
-   (eqv? tag
-         (parameterize ((ansi-escapes-enabled? tag))
-           (ansi-escapes-enabled?)))))
-
-(define-syntax test-escape-procedure
-  (syntax-rules ()
-    ((test-escape-procedure p s)
-     (begin
-       (test-assert (procedure? p))
-       (test-error (p #f))
-       (test s (p))))))
-
-(define-syntax test-wrap-procedure
-  (syntax-rules ()
-    ((test-wrap-procedure p s)
-     (begin
-       (test-assert (procedure? p))
-       (test-error (p))
-       (test-error (p #f))
-       (test-error (p "" #f))
-       (test (p "FOO")
-             "FOO"
-             (parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
-       (test (p "FOO")
-             s
-             (parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
-
-(test-escape-procedure black-escape       "\x1b;[30m")
-(test-escape-procedure red-escape         "\x1b;[31m")
-(test-escape-procedure green-escape       "\x1b;[32m")
-(test-escape-procedure yellow-escape      "\x1b;[33m")
-(test-escape-procedure blue-escape        "\x1b;[34m")
-(test-escape-procedure cyan-escape        "\x1b;[36m")
-(test-escape-procedure magenta-escape     "\x1b;[35m")
-(test-escape-procedure white-escape       "\x1b;[37m")
-(test-escape-procedure reset-color-escape "\x1b;[39m")
-
-(test-assert (procedure? rgb-escape))
-(test-error (rgb-escape))
-(test-error (rgb-escape 0))
-(test-error (rgb-escape 0 0))
-(test-error (rgb-escape 0 0 0 0))
-(test-error (rgb-escape 0.0 0 0))
-(test-error (rgb-escape 0 0.0 0))
-(test-error (rgb-escape 0 0 0.0))
-(test-error (rgb-escape -1 0 0))
-(test-error (rgb-escape 0 -1 0))
-(test-error (rgb-escape 0 0 -1))
-(test-error (rgb-escape 6 0 0))
-(test-error (rgb-escape 0 6 0))
-(test-error (rgb-escape 0 0 6))
-(test-escape-procedure (lambda () (rgb-escape 0 0 0)) "\x1B[38;5;16m")
-(test-escape-procedure (lambda () (rgb-escape 5 0 0)) "\x1B[38;5;196m")
-(test-escape-procedure (lambda () (rgb-escape 0 5 0)) "\x1B[38;5;46m")
-(test-escape-procedure (lambda () (rgb-escape 0 0 5)) "\x1B[38;5;21m")
-(test-escape-procedure (lambda () (rgb-escape 1 1 1)) "\x1B[38;5;59m")
-(test-escape-procedure (lambda () (rgb-escape 2 2 2)) "\x1B[38;5;102m")
-(test-escape-procedure (lambda () (rgb-escape 3 3 3)) "\x1B[38;5;145m")
-(test-escape-procedure (lambda () (rgb-escape 4 4 4)) "\x1B[38;5;188m")
-(test-escape-procedure (lambda () (rgb-escape 5 5 5)) "\x1B[38;5;231m")
-(test-escape-procedure (lambda () (rgb-escape 1 3 5)) "\x1B[38;5;75m")
-(test-escape-procedure (lambda () (rgb-escape 5 1 3)) "\x1B[38;5;205m")
-(test-escape-procedure (lambda () (rgb-escape 3 5 1)) "\x1B[38;5;155m")
-
-(test-assert (procedure? gray-escape))
-(test-error (gray-escape))
-(test-error (gray-escape 0 0))
-(test-error (gray-escape 0.0))
-(test-error (gray-escape -1))
-(test-error (gray-escape 24))
-(test-escape-procedure (lambda () (gray-escape  0)) "\x1B[38;5;232m")
-(test-escape-procedure (lambda () (gray-escape 23)) "\x1B[38;5;255m")
-(test-escape-procedure (lambda () (gray-escape 12)) "\x1B[38;5;244m")
-
-(test-wrap-procedure   black       "\x1b;[30mFOO\x1b;[39m")
-(test-wrap-procedure   red         "\x1b;[31mFOO\x1b;[39m")
-(test-wrap-procedure   green       "\x1b;[32mFOO\x1b;[39m")
-(test-wrap-procedure   yellow      "\x1b;[33mFOO\x1b;[39m")
-(test-wrap-procedure   blue        "\x1b;[34mFOO\x1b;[39m")
-(test-wrap-procedure   cyan        "\x1b;[36mFOO\x1b;[39m")
-(test-wrap-procedure   magenta     "\x1b;[35mFOO\x1b;[39m")
-(test-wrap-procedure   white       "\x1b;[37mFOO\x1b;[39m")
-(test-wrap-procedure   (rgb 0 0 0) "\x1B[38;5;16mFOO\x1b;[39m")
-(test-wrap-procedure   (rgb 5 5 5) "\x1B[38;5;231mFOO\x1b;[39m")
-(test-wrap-procedure   (gray 0)    "\x1B[38;5;232mFOO\x1b;[39m")
-(test-wrap-procedure   (gray 23)   "\x1B[38;5;255mFOO\x1b;[39m")
-
-(test-escape-procedure black-background-escape       "\x1b;[40m")
-(test-escape-procedure red-background-escape         "\x1b;[41m")
-(test-escape-procedure green-background-escape       "\x1b;[42m")
-(test-escape-procedure yellow-background-escape      "\x1b;[43m")
-(test-escape-procedure blue-background-escape        "\x1b;[44m")
-(test-escape-procedure cyan-background-escape        "\x1b;[46m")
-(test-escape-procedure magenta-background-escape     "\x1b;[45m")
-(test-escape-procedure white-background-escape       "\x1b;[47m")
-(test-escape-procedure reset-background-color-escape "\x1b;[49m")
-
-(test-assert (procedure? rgb-background-escape))
-(test-error (rgb-background-escape))
-(test-error (rgb-background-escape 0))
-(test-error (rgb-background-escape 0 0))
-(test-error (rgb-background-escape 0 0 0 0))
-(test-error (rgb-background-escape 0.0 0 0))
-(test-error (rgb-background-escape 0 0.0 0))
-(test-error (rgb-background-escape 0 0 0.0))
-(test-error (rgb-background-escape -1 0 0))
-(test-error (rgb-background-escape 0 -1 0))
-(test-error (rgb-background-escape 0 0 -1))
-(test-error (rgb-background-escape 6 0 0))
-(test-error (rgb-background-escape 0 6 0))
-(test-error (rgb-background-escape 0 0 6))
-(test-escape-procedure (lambda () (rgb-background-escape 0 0 0)) "\x1B[48;5;16m")
-(test-escape-procedure (lambda () (rgb-background-escape 5 0 0)) "\x1B[48;5;196m")
-(test-escape-procedure (lambda () (rgb-background-escape 0 5 0)) "\x1B[48;5;46m")
-(test-escape-procedure (lambda () (rgb-background-escape 0 0 5)) "\x1B[48;5;21m")
-(test-escape-procedure (lambda () (rgb-background-escape 1 1 1)) "\x1B[48;5;59m")
-(test-escape-procedure (lambda () (rgb-background-escape 2 2 2)) "\x1B[48;5;102m")
-(test-escape-procedure (lambda () (rgb-background-escape 3 3 3)) "\x1B[48;5;145m")
-(test-escape-procedure (lambda () (rgb-background-escape 4 4 4)) "\x1B[48;5;188m")
-(test-escape-procedure (lambda () (rgb-background-escape 5 5 5)) "\x1B[48;5;231m")
-(test-escape-procedure (lambda () (rgb-background-escape 1 3 5)) "\x1B[48;5;75m")
-(test-escape-procedure (lambda () (rgb-background-escape 5 1 3)) "\x1B[48;5;205m")
-(test-escape-procedure (lambda () (rgb-background-escape 3 5 1)) "\x1B[48;5;155m")
-
-(test-assert (procedure? gray-background-escape))
-(test-error (gray-background-escape))
-(test-error (gray-background-escape 0 0))
-(test-error (gray-background-escape 0.0))
-(test-error (gray-background-escape -1))
-(test-error (gray-background-escape 24))
-(test-escape-procedure (lambda () (gray-background-escape  0)) "\x1B[48;5;232m")
-(test-escape-procedure (lambda () (gray-background-escape 23)) "\x1B[48;5;255m")
-(test-escape-procedure (lambda () (gray-background-escape 12)) "\x1B[48;5;244m")
-
-(test-wrap-procedure   black-background       "\x1b;[40mFOO\x1b;[49m")
-(test-wrap-procedure   red-background         "\x1b;[41mFOO\x1b;[49m")
-(test-wrap-procedure   green-background       "\x1b;[42mFOO\x1b;[49m")
-(test-wrap-procedure   yellow-background      "\x1b;[43mFOO\x1b;[49m")
-(test-wrap-procedure   blue-background        "\x1b;[44mFOO\x1b;[49m")
-(test-wrap-procedure   cyan-background        "\x1b;[46mFOO\x1b;[49m")
-(test-wrap-procedure   magenta-background     "\x1b;[45mFOO\x1b;[49m")
-(test-wrap-procedure   white-background       "\x1b;[47mFOO\x1b;[49m")
-(test-wrap-procedure   (rgb-background 0 0 0) "\x1B[48;5;16mFOO\x1b;[49m")
-(test-wrap-procedure   (rgb-background 5 5 5) "\x1B[48;5;231mFOO\x1b;[49m")
-(test-wrap-procedure   (gray-background 0)    "\x1B[48;5;232mFOO\x1b;[49m")
-(test-wrap-procedure   (gray-background 23)   "\x1B[48;5;255mFOO\x1b;[49m")
-
-(test-escape-procedure bold-escape            "\x1b;[1m")
-(test-escape-procedure reset-bold-escape      "\x1b;[22m")
-(test-wrap-procedure   bold                   "\x1b;[1mFOO\x1b;[22m")
-
-(test-escape-procedure underline-escape       "\x1b;[4m")
-(test-escape-procedure reset-underline-escape "\x1b;[24m")
-(test-wrap-procedure   underline              "\x1b;[4mFOO\x1b;[24m")
-
-(test-escape-procedure negative-escape        "\x1b;[7m")
-(test-escape-procedure reset-negative-escape  "\x1b;[27m")
-(test-wrap-procedure   negative               "\x1b;[7mFOO\x1b;[27m")
-
-(test-end)

tests/thread-tests.scm

@@ -1,114 +0,0 @@
-
-(cond-expand
- (modules (import (srfi 18) (srfi 39) (chibi test)))
- (else #f))
-
-(test-begin "threads")
-
-(test "no threads" 'ok (begin 'ok))
-
-(test "unstarted thread" 'ok
-  (let ((t (make-thread (lambda () (error "oops"))))) 'ok))
-
-(test "ignored thread terminates" 'ok
-  (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
-
-(test "ignored thread hangs" 'ok
-  (let ((t (make-thread (lambda () (let lp () (lp))))))
-    (thread-start! t)
-    'ok))
-
-(test "joined thread terminates" 'ok
-  (let ((t (make-thread (lambda () 'oops))))
-    (thread-start! t)
-    (thread-join! t)
-    'ok))
-
-(test "joined thread hangs, timeout" 'timeout
-  (let ((t (make-thread (lambda () (let lp () (lp))))))
-    (thread-start! t)
-    (thread-join! t 0.1 'timeout)))
-
-(test "basic mutex" 'ok
-  (let ((m (make-mutex)))
-    (and (mutex? m) 'ok)))
-
-(test "mutex unlock" 'ok
-  (let ((m (make-mutex)))
-    (and (mutex-unlock! m) 'ok)))
-
-(test "mutex lock/unlock" 'ok
-  (let ((m (make-mutex)))
-    (and (mutex-lock! m)
-         (mutex-unlock! m)
-         'ok)))
-
-(test "mutex lock/lock" 'timeout
-  (let ((m (make-mutex)))
-    (and (mutex-lock! m)
-         (if (mutex-lock! m 0.1) 'fail 'timeout))))
-
-(test "mutex lock timeout" 'timeout
-  (let* ((m (make-mutex))
-         (t (make-thread (lambda () (mutex-lock! m)))))
-    (thread-start! t)
-    (thread-yield!)
-    (if (mutex-lock! m 0.1) 'fail 'timeout)))
-
-(test "mutex lock/unlock/lock/lock" 'timeout
-  (let* ((m (make-mutex))
-         (t (make-thread (lambda () (mutex-unlock! m)))))
-    (mutex-lock! m)
-    (thread-start! t)
-    (if (mutex-lock! m 0.1)
-        (if (mutex-lock! m 0.1) 'fail-second 'timeout)
-        'bad-timeout)))
-
-(test "thread-join! end result" 5
-  (let* ((th (make-thread (lambda () (+ 3 2)))))
-    (thread-start! th)
-    (thread-join! th)))
-
-(test-error "thread-join! exception"
-  (let* ((th (make-thread
-              (lambda ()
-                (parameterize ((current-error-port (open-output-string)))
-                  (+ 3 "2"))))))
-    (thread-start! th)
-    (thread-join! th)))
-
-(test-assert "make-condition-variable"
-  (condition-variable? (make-condition-variable)))
-
-(test "condition-variable signal" 'ok
-  (let* ((mutex (make-mutex))
-         (cndvar (make-condition-variable))
-         (th (make-thread
-              (lambda ()
-                (if (mutex-unlock! mutex cndvar 0.1) 'ok 'timeout1)))))
-    (thread-start! th)
-    (thread-yield!)
-    (condition-variable-signal! cndvar)
-    (thread-join! th 0.1 'timeout2)))
-
-(test "condition-variable broadcast" '(ok1 ok2)
-  (let* ((mutex (make-mutex))
-         (cndvar (make-condition-variable))
-         (th1 (make-thread
-               (lambda ()
-                 (mutex-lock! mutex)
-                 (if (mutex-unlock! mutex cndvar 1.0) 'ok1 'timeout1))))
-         (th2 (make-thread
-               (lambda ()
-                 (mutex-lock! mutex)
-                 (if (mutex-unlock! mutex cndvar 1.0) 'ok2 'timeout2)))))
-    (thread-start! th1)
-    (thread-start! th2)
-    (thread-yield!)
-    (mutex-lock! mutex)
-    (condition-variable-broadcast! cndvar)
-    (mutex-unlock! mutex)
-    (list (thread-join! th1 0.1 'timeout3)
-          (thread-join! th2 0.1 'timeout4))))
-
-(test-end)

tests/uri-tests.scm

@@ -1,65 +0,0 @@
-
-(import (chibi) (chibi test) (chibi uri))
-
-(test-begin "uri")
-
-(test-assert (uri? (make-uri 'http)))
-(test 'http (uri-scheme (make-uri 'http)))
-(test "r" (uri-user (make-uri 'http "r")))
-(test "google.com" (uri-host (make-uri 'http "r" "google.com")))
-(test 80 (uri-port (make-uri 'http "r" "google.com" 80)))
-(test "/search" (uri-path (make-uri 'http "r" "google.com" 80 "/search")))
-(test "q=cats"
-    (uri-query (make-uri 'http "r" "google.com" 80 "/search" "q=cats")))
-(test "recent"
-    (uri-fragment
-     (make-uri 'http "r" "google.com" 80 "/search" "q=cats" "recent")))
-
-(let ((str "http://google.com"))
-  (test-assert (uri? (string->uri str)))
-  (test 'http (uri-scheme (string->uri str)))
-  (test "google.com" (uri-host (string->uri str)))
-  (test #f (uri-port (string->uri str)))
-  (test #f (uri-path (string->uri str)))
-  (test #f (uri-query (string->uri str)))
-  (test #f (uri-fragment (string->uri str))))
-
-(let ((str "http://google.com/"))
-  (test-assert (uri? (string->uri str)))
-  (test 'http (uri-scheme (string->uri str)))
-  (test "google.com" (uri-host (string->uri str)))
-  (test #f (uri-port (string->uri str)))
-  (test "/" (uri-path (string->uri str)))
-  (test #f (uri-query (string->uri str)))
-  (test #f (uri-fragment (string->uri str))))
-
-(let ((str "http://google.com:80/search?q=cats#recent"))
-  (test-assert (uri? (string->uri str)))
-  (test 'http (uri-scheme (string->uri str)))
-  (test "google.com" (uri-host (string->uri str)))
-  (test 80 (uri-port (string->uri str)))
-  (test "/search" (uri-path (string->uri str)))
-  (test "q=cats" (uri-query (string->uri str)))
-  (test "recent" (uri-fragment (string->uri str))))
-
-(test "/%73" (uri-path (string->uri "http://google.com/%73")))
-(test "/s" (uri-path (string->uri "http://google.com/%73" #t)))
-(test "a=1&b=2;c=3"
-    (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t)))
-(test '(("a" . "1") ("b" . "2") ("c" . "3"))
-    (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t #t)))
-(test '(("a" . "1") ("b" . "2+2") ("c" . "3"))
-    (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #f #t)))
-(test '(("a" . "1") ("b" . "2 2") ("c" . "3"))
-    (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #t #t)))
-
-(let ((str "/"))
-  (test-assert (uri? (string->path-uri 'http str)))
-  (test 'http (uri-scheme (string->path-uri 'http str)))
-  (test #f (uri-host (string->path-uri 'http str)))
-  (test #f (uri-port (string->path-uri 'http str)))
-  (test "/" (uri-path (string->path-uri 'http str)))
-  (test #f (uri-query (string->path-uri 'http str)))
-  (test #f (uri-fragment (string->path-uri 'http str))))
-
-(test-end)

tests/weak-tests.scm

@@ -1,46 +0,0 @@
-
-(import (chibi weak) (chibi ast) (only (chibi test) test-begin test test-end))
-
-(test-begin "weak pointers")
-
-(test "preserved key and value" '("key1" "value1" #f)
-  (let ((key (string-append "key" "1"))
-        (value (string-append "value" "1")))
-    (let ((eph (make-ephemeron key value)))
-      (gc)
-      (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
-
-(test "unpreserved key and value" '(#f #f #t)
-  (let ((eph (make-ephemeron (string-append "key" "2")
-                             (string-append "value" "2"))))
-    (gc)
-    (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph))))
-
-(test "unpreserved key and preserved value" '(#f "value3" #t)
-  (let ((value (string-append "value" "3")))
-    (let ((eph (make-ephemeron (string-append "key" "3") value)))
-      (gc)
-      (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
-
-(test "unpreserved value references unpreserved key" '(#f #f #t)
-  (let ((key (string-append "key")))
-    (let ((eph (make-ephemeron key (cons (string-append "value") key))))
-      (gc)
-      (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph)))))
-
-;; disabled - we support weak keys, but not proper ephemerons
-
-'(test "preserved key and unpreserved value" '("key" "value" #f)
-  (let ((key (string-append "key")))
-    (let ((eph (make-ephemeron key (string-append "value"))))
-      (gc)
-      (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
-
-'(test "preserved value references unpreserved key" '(#f #f #t)
-  (let* ((key (string-append "key"))
-         (value (cons (string-append "value") key)))
-    (let ((eph (make-ephemeron key value)))
-      (gc)
-      (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
-
-(test-end)