From ce5a6e8a740829fa7d84e11b76fd8584c753bf88 Mon Sep 17 00:00:00 2001
From: Andy Keep <akeep@robotman.org>
Date: Fri, 22 Nov 2013 00:11:58 -0700
Subject: [PATCH] added a small set of tests to provide a framework for testing
 the compiler (there is much more to do here, including a better testing
 framework and many, many more tests)

---
 test-lib.ss | 21 ++++++++++++
 tests.ss    | 98 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 119 insertions(+)
 create mode 100644 test-lib.ss
 create mode 100644 tests.ss

diff --git a/test-lib.ss b/test-lib.ss
new file mode 100644
index 0000000..4b956c6
--- /dev/null
+++ b/test-lib.ss
@@ -0,0 +1,21 @@
+(library (test-lib)
+  (export quote if or and not begin lambda let letrec set! cons make-vector box
+    car cdr vector-ref vector-length unbox + - * / pair? null? boolean? vector?
+    box? = < <= > >= eq? vector-set! set-box! canonicalize-result) 
+  (import (rename (except (rnrs) /) (div /)) (rnrs mutable-pairs))
+
+  ;; implement a box type since there is no box type in R6RS, even though it
+  ;; may be included in our host implementations.
+  (define-record-type (box-record box box?) (fields (mutable value unbox set-box!)))
+
+  (define canonicalize-result
+    (lambda (x)
+      (cond
+        [(box? x) (vector 'box (canonicalize-result (unbox x)))]
+        [(vector? x) (vector-map canonicalize-result x)]
+        [(pair? x) (cons (canonicalize-result (car x))
+                     (canonicalize-result (cdr x)))]
+        [(procedure? x) '#(procedure)]
+        [(eq? (if #f #f) x) '#(void)]
+        [else x]))))
+
diff --git a/tests.ss b/tests.ss
new file mode 100644
index 0000000..05c771d
--- /dev/null
+++ b/tests.ss
@@ -0,0 +1,98 @@
+(library (tests)
+  (export run-tests)
+  (import (c) (rnrs) (rnrs eval) (implementation-helpers))
+  
+  (define-syntax define-tests
+    (syntax-rules ()
+      [(_ name test ...)
+       (define name
+         (list
+           (cons 'test
+             (eval `(canonicalize-result ,'test)
+               (environment '(test-lib))))
+           ...))]))
+
+  ;; NB: need to add many more tests to make sure we're fully testing the compiler.
+  (define-tests tests
+    0
+    -5
+    5
+    #t
+    #f
+    '()
+    '(3 . 4)
+    '(1 2 3 4)
+    '(1 2 . 3)
+    '(((1 . 2) (3 . 4)) (5 . 6))
+    '((0 . #t) (1 . #f) (3 . #t))
+    '#(1 2 3)
+    '#((2 . 3) #f #t (#t . 4))
+    (car '(1 . 2))
+    (cdr '(1 . 2))
+    (cons 1 2)
+    (car (cons 1 2))
+    (cdr (cons 1 2))
+    (pair? '(1 . 2))
+    (pair? (cons 1 2))
+    (null? '())
+    (null? (cdr (cons 1 '())))
+    (vector-ref '#(1 2 3) 1)
+    (vector-length '#(1 2 3))
+    (vector-length (make-vector 10))
+    (box 4)
+    (box '(1 . 2))
+    (unbox (box 10))
+    (car (unbox (box (cons 1 2))))
+    (+ 2 3)
+    (+ (+ 4 5) (+ 6 7))
+    (- 2 3)
+    (- (- (- 1 2) 3) 4)
+    (* 2 5)
+    (* 3 (* 4 5))
+    (/ 10 2)
+    (/ 7 2)
+    (/ (/ 10 2) 2)
+    (+ (- 1 20) 30)
+    (- 4 4)
+    (box? (box 4))
+    (box? (box #f))
+    (box? (cons 1 2))
+    (letrec ([! (lambda (n)
+                  (if (zero? n)
+                      1
+                      (* n (! (- n 1)))))]
+              [zero? (lambda (n) (= n 1))])
+      (! 10))
+    (letrec ([f (lambda (g x) (g x))]
+             [a 5]
+             [b (+ 5 7)]
+             [g (lambda (h) (f h 5))]
+             [c (let ([x 10]) ((letrec ([zero? (lambda (n) (= n 0))]
+                                        [f (lambda (n) 
+                                             (if (zero? n)
+                                                 1
+                                                 (* n (f (- n 1)))))])
+                                 f)
+                                x))]
+             [m 10]
+             [z (lambda (x) x)])
+      (set! z (lambda (x) (+ x x)))
+      (set! m (+ m m))
+      (+ (+ (+ (f z a) (f z b)) (f z c)) (g z))))
+
+  (define run-tests
+    (lambda ()
+      (let loop ([tests tests] [i 0])
+        (unless (null? tests)
+          (let ([test (car tests)])
+            (let ([expr (car test)] [result (cdr test)])
+              (printf "running test ~d:~%" i)
+              (pretty-print expr)
+              ;; NB: when we hit an exception, report the result as part of the string.
+              (guard (c [else (printf "failed with exception (TBD)~%")])
+                (let ([actual (my-tiny-compile expr)])
+                  (if (equal? actual result)
+                      (printf "passed~%")
+                      (printf "expected ~s but got ~s~%" result actual))))
+              (loop (cdr tests) (fx+ i 1)))))))))
+