diff --git a/Makefile b/Makefile index 8fc780e8..df563b77 100644 --- a/Makefile +++ b/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 diff --git a/lib/chibi/base64-test.sld b/lib/chibi/base64-test.sld new file mode 100644 index 00000000..62dac89c --- /dev/null +++ b/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)))) diff --git a/lib/chibi/crypto/md5-test.sld b/lib/chibi/crypto/md5-test.sld new file mode 100644 index 00000000..e6c0d0b1 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/crypto/rsa-test.sld b/lib/chibi/crypto/rsa-test.sld new file mode 100644 index 00000000..ed7878d9 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/crypto/sha2-test.sld b/lib/chibi/crypto/sha2-test.sld new file mode 100644 index 00000000..3fc853ac --- /dev/null +++ b/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)))) diff --git a/lib/chibi/filesystem-test.sld b/lib/chibi/filesystem-test.sld new file mode 100644 index 00000000..4a762fb8 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/generic-test.sld b/lib/chibi/generic-test.sld new file mode 100644 index 00000000..62543bf6 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/io-test.sld b/lib/chibi/io-test.sld new file mode 100644 index 00000000..f2928e49 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/iset-test.sld b/lib/chibi/iset-test.sld new file mode 100644 index 00000000..03262360 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/loop-test.sld b/lib/chibi/loop-test.sld new file mode 100644 index 00000000..b69b35e5 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/match-test.sld b/lib/chibi/match-test.sld new file mode 100644 index 00000000..bf8532d3 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/math/prime-test.sld b/lib/chibi/math/prime-test.sld new file mode 100644 index 00000000..ad3e21c3 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/memoize-test.sld b/lib/chibi/memoize-test.sld new file mode 100644 index 00000000..b151db68 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/mime-test.sld b/lib/chibi/mime-test.sld new file mode 100644 index 00000000..95fcf379 --- /dev/null +++ b/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 \"") + (to . "\"Sherlock Homes \"") + (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 \" +To: \"Sherlock Homes \" +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)))) diff --git a/lib/chibi/parse-test.sld b/lib/chibi/parse-test.sld new file mode 100644 index 00000000..44d4b377 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/pathname-test.sld b/lib/chibi/pathname-test.sld new file mode 100644 index 00000000..8c3bec1d --- /dev/null +++ b/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)))) diff --git a/lib/chibi/process-test.sld b/lib/chibi/process-test.sld new file mode 100644 index 00000000..34b8896a --- /dev/null +++ b/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)))) diff --git a/lib/chibi/regexp-test.sld b/lib/chibi/regexp-test.sld new file mode 100644 index 00000000..353f77a5 --- /dev/null +++ b/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 '("12345") '(* digit) "12345") + (test-re #f '(w/ascii (* digit)) "12345") + + (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)))) diff --git a/lib/chibi/scribble-test.sld b/lib/chibi/scribble-test.sld new file mode 100644 index 00000000..ad57d402 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/show-test.sld b/lib/chibi/show-test.sld new file mode 100644 index 00000000..6c9eb620 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/string-test.sld b/lib/chibi/string-test.sld new file mode 100644 index 00000000..76704f7b --- /dev/null +++ b/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)))) diff --git a/lib/chibi/system-test.sld b/lib/chibi/system-test.sld new file mode 100644 index 00000000..f5281c24 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/tar-test.sld b/lib/chibi/tar-test.sld new file mode 100644 index 00000000..42639203 --- /dev/null +++ b/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. ( . ) 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)))) diff --git a/lib/chibi/term/ansi-test.sld b/lib/chibi/term/ansi-test.sld new file mode 100644 index 00000000..b2226dca --- /dev/null +++ b/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)))) diff --git a/lib/chibi/uri-test.sld b/lib/chibi/uri-test.sld new file mode 100644 index 00000000..1881c4c3 --- /dev/null +++ b/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)))) diff --git a/lib/chibi/weak-test.sld b/lib/chibi/weak-test.sld new file mode 100644 index 00000000..b040b9e6 --- /dev/null +++ b/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)))) diff --git a/lib/srfi/1/test.sld b/lib/srfi/1/test.sld new file mode 100644 index 00000000..a10cb174 --- /dev/null +++ b/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)))) diff --git a/lib/srfi/16/test.sld b/lib/srfi/16/test.sld new file mode 100644 index 00000000..ff46172b --- /dev/null +++ b/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)))) diff --git a/lib/srfi/18/test.sld b/lib/srfi/18/test.sld new file mode 100644 index 00000000..e7aa0cbe --- /dev/null +++ b/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)))) diff --git a/lib/srfi/2/test.sld b/lib/srfi/2/test.sld new file mode 100644 index 00000000..e61cb199 --- /dev/null +++ b/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)))) diff --git a/lib/srfi/26/test.sld b/lib/srfi/26/test.sld new file mode 100644 index 00000000..1c941d3e --- /dev/null +++ b/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)))) diff --git a/lib/srfi/27/test.sld b/lib/srfi/27/test.sld new file mode 100644 index 00000000..0955ca5c --- /dev/null +++ b/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)))) diff --git a/lib/srfi/33/test.sld b/lib/srfi/33/test.sld new file mode 100644 index 00000000..659b1bde --- /dev/null +++ b/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)))) diff --git a/lib/srfi/38/test.sld b/lib/srfi/38/test.sld new file mode 100644 index 00000000..1de30b5e --- /dev/null +++ b/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)))) diff --git a/lib/srfi/69/test.sld b/lib/srfi/69/test.sld new file mode 100644 index 00000000..dfaf94ae --- /dev/null +++ b/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)))) diff --git a/lib/srfi/95/test.sld b/lib/srfi/95/test.sld new file mode 100644 index 00000000..30e1fa23 --- /dev/null +++ b/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-cistring)) - -;; 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) diff --git a/tests/generic-tests.scm b/tests/generic-tests.scm deleted file mode 100644 index 8c6fc72d..00000000 --- a/tests/generic-tests.scm +++ /dev/null @@ -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) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm deleted file mode 100644 index bcdb4899..00000000 --- a/tests/hash-tests.scm +++ /dev/null @@ -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) - diff --git a/tests/io-tests.scm b/tests/io-tests.scm deleted file mode 100644 index 563590e0..00000000 --- a/tests/io-tests.scm +++ /dev/null @@ -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) diff --git a/tests/iset-tests.scm b/tests/iset-tests.scm deleted file mode 100644 index 5e8f18bd..00000000 --- a/tests/iset-tests.scm +++ /dev/null @@ -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) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 29ce96fb..1b685870 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -1,51 +1,65 @@ -(cond-expand - (modules (import (only (chibi) load) - (only (chibi test) test-begin test-end))) - (else (load "tests/r5rs-tests.scm"))) +(import (scheme base) + (chibi test) + (rename (srfi 1 test) (run-tests run-srfi-1-tests)) + (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") -(load "tests/srfi-2-tests.scm") -(load "tests/srfi-16-tests.scm") -(load "tests/srfi-26-tests.scm") -(load "tests/srfi-27-tests.scm") -(load "tests/srfi-38-tests.scm") -(load "tests/flonum-tests.scm") -(load "tests/numeric-tests.scm") -(load "tests/loop-tests.scm") -(load "tests/match-tests.scm") -(load "tests/scribble-tests.scm") -(load "tests/string-tests.scm") -(load "tests/iset-tests.scm") -(load "tests/uri-tests.scm") -(load "tests/mime-tests.scm") -(load "tests/regexp-tests.scm") -(load "tests/prime-tests.scm") -(load "tests/md5-tests.scm") -(load "tests/sha-tests.scm") -;; (load "tests/rsa-tests.scm") -(load "tests/tar-tests.scm") -(load "tests/term-ansi-tests.scm") -(cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f)) - -(cond-expand - (modules - (load "tests/record-tests.scm") - (load "tests/hash-tests.scm") - (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)) +(run-srfi-1-tests) +(run-srfi-2-tests) +(run-srfi-16-tests) +(run-srfi-18-tests) +(run-srfi-26-tests) +(run-srfi-27-tests) +(run-srfi-38-tests) +(run-srfi-69-tests) +(run-srfi-95-tests) +(run-srfi-99-tests) +(run-base64-tests) +(run-io-tests) +(run-iset-tests) +(run-loop-tests) +(run-match-tests) +(run-md5-tests) +(run-mime-tests) +(run-parse-tests) +(run-prime-tests) +(run-process-tests) +(run-regexp-tests) +(run-rsa-tests) +(run-scribble-tests) +(run-sha2-tests) +(run-system-tests) +(run-tar-tests) +(run-term-ansi-tests) +(run-uri-tests) (test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm deleted file mode 100644 index b3f914f1..00000000 --- a/tests/loop-tests.scm +++ /dev/null @@ -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) diff --git a/tests/match-tests.scm b/tests/match-tests.scm deleted file mode 100644 index e6a48513..00000000 --- a/tests/match-tests.scm +++ /dev/null @@ -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) diff --git a/tests/md5-tests.scm b/tests/md5-tests.scm deleted file mode 100644 index 14ef9ab3..00000000 --- a/tests/md5-tests.scm +++ /dev/null @@ -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) diff --git a/tests/memoize-tests.scm b/tests/memoize-tests.scm deleted file mode 100644 index 21504139..00000000 --- a/tests/memoize-tests.scm +++ /dev/null @@ -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) diff --git a/tests/mime-tests.scm b/tests/mime-tests.scm deleted file mode 100644 index c23c0064..00000000 --- a/tests/mime-tests.scm +++ /dev/null @@ -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 \"") - (to . "\"Sherlock Homes \"") - (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 \" -To: \"Sherlock Homes \" -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) diff --git a/tests/parse-tests.scm b/tests/parse-tests.scm deleted file mode 100644 index 245eac6e..00000000 --- a/tests/parse-tests.scm +++ /dev/null @@ -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) diff --git a/tests/path-tests.scm b/tests/path-tests.scm deleted file mode 100644 index 8d6aa422..00000000 --- a/tests/path-tests.scm +++ /dev/null @@ -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) diff --git a/tests/prime-tests.scm b/tests/prime-tests.scm deleted file mode 100644 index a060f82c..00000000 --- a/tests/prime-tests.scm +++ /dev/null @@ -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) diff --git a/tests/process-tests.scm b/tests/process-tests.scm deleted file mode 100644 index 3f79a568..00000000 --- a/tests/process-tests.scm +++ /dev/null @@ -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) diff --git a/tests/record-tests.scm b/tests/record-tests.scm deleted file mode 100644 index c1159fe1..00000000 --- a/tests/record-tests.scm +++ /dev/null @@ -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) diff --git a/tests/regexp-tests.scm b/tests/regexp-tests.scm deleted file mode 100644 index 0d065518..00000000 --- a/tests/regexp-tests.scm +++ /dev/null @@ -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 '("12345") '(* digit) "12345") -(test-re #f '(w/ascii (* digit)) "12345") - -(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) diff --git a/tests/rsa-tests.scm b/tests/rsa-tests.scm deleted file mode 100644 index 7d98cf81..00000000 --- a/tests/rsa-tests.scm +++ /dev/null @@ -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) diff --git a/tests/scribble-tests.scm b/tests/scribble-tests.scm deleted file mode 100644 index ad6f97cc..00000000 --- a/tests/scribble-tests.scm +++ /dev/null @@ -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) diff --git a/tests/sha-tests.scm b/tests/sha-tests.scm deleted file mode 100644 index 573b31b3..00000000 --- a/tests/sha-tests.scm +++ /dev/null @@ -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) diff --git a/tests/show-tests.scm b/tests/show-tests.scm deleted file mode 100644 index 2c56f021..00000000 --- a/tests/show-tests.scm +++ /dev/null @@ -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) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm deleted file mode 100644 index 6305539b..00000000 --- a/tests/sort-tests.scm +++ /dev/null @@ -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-ciexact (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) diff --git a/tests/srfi-16-tests.scm b/tests/srfi-16-tests.scm deleted file mode 100644 index edb00495..00000000 --- a/tests/srfi-16-tests.scm +++ /dev/null @@ -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) diff --git a/tests/srfi-2-tests.scm b/tests/srfi-2-tests.scm deleted file mode 100644 index c083c238..00000000 --- a/tests/srfi-2-tests.scm +++ /dev/null @@ -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) diff --git a/tests/srfi-26-tests.scm b/tests/srfi-26-tests.scm deleted file mode 100644 index 0051aa2f..00000000 --- a/tests/srfi-26-tests.scm +++ /dev/null @@ -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) diff --git a/tests/srfi-27-tests.scm b/tests/srfi-27-tests.scm deleted file mode 100644 index ebdb4d65..00000000 --- a/tests/srfi-27-tests.scm +++ /dev/null @@ -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) diff --git a/tests/srfi-33-tests.scm b/tests/srfi-33-tests.scm deleted file mode 100644 index 5ae7b494..00000000 --- a/tests/srfi-33-tests.scm +++ /dev/null @@ -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) diff --git a/tests/srfi-38-tests.scm b/tests/srfi-38-tests.scm deleted file mode 100644 index da0fe7b5..00000000 --- a/tests/srfi-38-tests.scm +++ /dev/null @@ -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) diff --git a/tests/string-tests.scm b/tests/string-tests.scm deleted file mode 100644 index 2cf481b3..00000000 --- a/tests/string-tests.scm +++ /dev/null @@ -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) diff --git a/tests/system-tests.scm b/tests/system-tests.scm deleted file mode 100644 index a7585896..00000000 --- a/tests/system-tests.scm +++ /dev/null @@ -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) diff --git a/tests/tar-tests.scm b/tests/tar-tests.scm deleted file mode 100644 index d57c048f..00000000 --- a/tests/tar-tests.scm +++ /dev/null @@ -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. ( . ) 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) diff --git a/tests/term-ansi-tests.scm b/tests/term-ansi-tests.scm deleted file mode 100644 index aba89e2c..00000000 --- a/tests/term-ansi-tests.scm +++ /dev/null @@ -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) diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm deleted file mode 100644 index e99a7147..00000000 --- a/tests/thread-tests.scm +++ /dev/null @@ -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) diff --git a/tests/uri-tests.scm b/tests/uri-tests.scm deleted file mode 100644 index c8e3d13a..00000000 --- a/tests/uri-tests.scm +++ /dev/null @@ -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) diff --git a/tests/weak-tests.scm b/tests/weak-tests.scm deleted file mode 100644 index f34f35cf..00000000 --- a/tests/weak-tests.scm +++ /dev/null @@ -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)