From 32de527a7726cbec768e6cc8e17a85053bebdd82 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 1 Mar 2010 15:53:55 +0900
Subject: [PATCH] adding tests

---
 Makefile             |  3 ++
 tests/hash-tests.scm | 74 ++++++++++++++++++++++++++++++++++++++++++++
 tests/sort-tests.scm | 51 ++++++++++++++++++++++++++++++
 3 files changed, 128 insertions(+)
 create mode 100644 tests/hash-tests.scm
 create mode 100644 tests/sort-tests.scm

diff --git a/Makefile b/Makefile
index cb7633f2..fcc10ae6 100644
--- a/Makefile
+++ b/Makefile
@@ -168,6 +168,9 @@ test-match: chibi-scheme$(EXE)
 test-loop: chibi-scheme$(EXE)
 	LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm
 
+test-sort: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/sort-tests.scm
+
 test: chibi-scheme$(EXE)
 	LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm
 
diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm
new file mode 100644
index 00000000..6dec5734
--- /dev/null
+++ b/tests/hash-tests.scm
@@ -0,0 +1,74 @@
+
+(import (srfi 69))
+
+(define *tests-run* 0)
+(define *tests-passed* 0)
+
+(define-syntax test
+  (syntax-rules ()
+    ((test expect expr)
+     (begin
+       (set! *tests-run* (+ *tests-run* 1))
+       (let ((str (call-with-output-string
+                    (lambda (out)
+                      (write *tests-run*)
+                      (display ". ")
+                      (display 'expr out))))
+             (res expr))
+         (display str)
+         (write-char #\space)
+         (display (make-string (max 0 (- 72 (string-length str))) #\.))
+         (flush-output)
+         (cond
+          ((equal? res expect)
+           (set! *tests-passed* (+ *tests-passed* 1))
+           (display " [PASS]\n"))
+          (else
+           (display " [FAIL]\n")
+           (display "    expected ") (write expect)
+           (display " but got ") (write res) (newline))))))))
+
+(define (test-report)
+  (write *tests-passed*)
+  (display " out of ")
+  (write *tests-run*)
+  (display " passed (")
+  (write (* (/ *tests-passed* *tests-run*) 100))
+  (display "%)")
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; run tests
+
+(test
+ 'white
+ (let ((ht (make-hash-table eq?)))
+   (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
+ (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
+ (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 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-report)
+
diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm
new file mode 100644
index 00000000..a0cc92f4
--- /dev/null
+++ b/tests/sort-tests.scm
@@ -0,0 +1,51 @@
+
+(import (srfi 95))
+
+(define *tests-run* 0)
+(define *tests-passed* 0)
+
+(define-syntax test
+  (syntax-rules ()
+    ((test name expr expect)
+     (begin
+       (set! *tests-run* (+ *tests-run* 1))
+       (let ((str (call-with-output-string (lambda (out) (display name out))))
+             (res expr))
+         (display str)
+         (write-char #\space)
+         (display (make-string (max 0 (- 72 (string-length str))) #\.))
+         (flush-output)
+         (cond
+          ((equal? res expect)
+           (set! *tests-passed* (+ *tests-passed* 1))
+           (display " [PASS]\n"))
+          (else
+           (display " [FAIL]\n")
+           (display "    expected ") (write expect)
+           (display " but got ") (write res) (newline))))))))
+
+(define (test-report)
+  (write *tests-passed*)
+  (display " out of ")
+  (write *tests-run*)
+  (display " passed (")
+  (write (* (/ *tests-passed* *tests-run*) 100))
+  (display "%)")
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; run tests
+
+(test "sort null" (sort '()) '())
+(test "sort null <" (sort '() <) '())
+(test "sort null < car" (sort '() < car) '())
+(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9))
+(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9))
+(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)
+  '((1) (2) (3) (4) (5) (6) (7) (8) (9)))
+(test "sort list (lambda (a b) (< (car a) (car b)))"
+    (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3))
+          (lambda (a b) (< (car a) (car b))))
+  '((1) (2) (3) (4) (5) (6) (7) (8) (9)))
+
+(test-report)