testing macros in r4rsHEADmaster

2 files changed, 157 insertions, 0 deletions

diff --git a/tests/body.scm b/tests/body.scm
new file mode 100644
index 0000000..99bfa70
--- /dev/null
+++ b/tests/body.scm
@@ -0,0 +1,104 @@
+(test-group "dup"
+  (test-equal "'x dup"
+              '(x x)
+              (RPSlist->list (interpret '(x)
+                                        (list->RPSlist inline-dup))))
+  (test-equal "'y 'x dup"
+              '(y y x)
+              (RPSlist->list (interpret '(y x)
+                                        (list->RPSlist inline-dup)))))
+(test-group "drop"
+  (test-equal "'x drop"
+              '()
+              (RPSlist->list (interpret '(x) (list->RPSlist inline-drop))))
+  (test-equal "'x 'y drop"
+              '(y)
+              (RPSlist->list
+               (interpret '(x y)
+                          (list->RPSlist inline-drop)))))
+
+(test-group "dropn"
+  (test-equal "'x {dropn 0}"
+              '()
+              (RPSlist->list (interpret '(x) (list->RPSlist
+                                              (inline-dropn 0)))))
+  (test-equal "'y 'x {dropn 0}"
+              '(y)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-dropn 0)))))
+  (test-equal "'y 'x {dropn 1}"
+              '(x)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-dropn 1)))))
+  (test-equal "'z 'y 'x {dropn 1}"
+              '(x z)
+              (RPSlist->list (interpret '(x y z)
+                                        (list->RPSlist
+                                         (inline-dropn 1)))))
+  (test-equal "'z 'y 'x {dropn 2}"
+              '(x y)
+              (RPSlist->list (interpret '(x y z)
+                                        (list->RPSlist
+                                         (inline-dropn 2))))))
+
+(test-group "pick"
+  (test-equal "'x {pick 0}"
+              '(x x)
+              (RPSlist->list (interpret '(x) (list->RPSlist
+                                              (inline-pick 0)))))
+  (test-equal "'y 'x {pick 0}"
+              '(x x y)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-pick 0)))))
+  (test-equal "'y 'x {pick 1}"
+              '(y x y)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-pick 1)))))
+  (test-equal "'z 'y 'x {pick 1}"
+              '(y x y z)
+              (RPSlist->list (interpret '(x y z) (list->RPSlist
+                                                  (inline-pick 1)))))
+  (test-equal "'z 'y 'x {pick 2}"
+              '(z x y z)
+              (RPSlist->list (interpret '(x y z) (list->RPSlist
+                                                  (inline-pick 2))))))
+
+(test-group "roll"
+  (test-equal "'x {roll 0}"
+              '(x)
+              (RPSlist->list (interpret '(x) (list->RPSlist
+                                              (inline-roll 0)))))
+  (test-equal "'y 'x {roll 0}"
+              '(x y)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-roll 0)))))
+  (test-equal "'y 'x {roll 1}"
+              '(y x)
+              (RPSlist->list (interpret '(x y) (list->RPSlist
+                                                (inline-roll 1)))))
+  (test-equal "'z 'y 'x {roll 1}"
+              '(y x z)
+              (RPSlist->list (interpret '(x y z) (list->RPSlist
+                                                  (inline-roll 1)))))
+  (test-equal "'z 'y 'x {roll 2}"
+              '(z x y)
+              (RPSlist->list (interpret '(x y z) (list->RPSlist
+                                                  (inline-roll 2))))))
+
+(test-group "stack-closure"
+  (let* ((push-values
+          `(#f                          ; [returnK N self values ...]
+            ,@(inline-dropn 1) ,@(inline-dropn 1)
+            #f ,@(inline-roll 1) jump))
+         (program
+          `(0 ,@(stack-closure push-values 0 #f) ; [proc 0]
+              (#f                      ; [K proc 0]
+               0 ,@(inline-roll 1)     ; [K 0 proc 0]
+               ,@(inline-pick 2)       ; [proc K 0 proc 0]
+               jump)
+              #f 1 call/cc)))
+    (test-equal "0 {stack-closure 0 #f} jump"
+                '(0 0)
+                (RPSlist->list
+                 (interpret '() (list->RPSlist program))))))
+
diff --git a/tests/s9fes.scm b/tests/s9fes.scm
new file mode 100644
index 0000000..5b02963
--- /dev/null
+++ b/tests/s9fes.scm
@@ -0,0 +1,53 @@
+;;; Shim for SRFI-64 for unhygenic, single threaded systems.
+
+(define tests-passed 0)
+(define tests-failed 0)
+(define current-test-name '())
+
+(define-syntax test-equal
+  (lambda (name-e expected-e got-e)
+    (let ((name* (gensym 'name))
+          (expected* (gensym 'expected))
+          (got* (gensym 'got))
+          (passed?* (gensym 'passed?)))
+      `(let* ((,name* ,name-e)
+              (,expected* ,expected-e)
+              (,got* ,got-e)
+              (,passed?* (equal? ,expected* ,got*)))
+         (if ,passed?*
+             (begin
+               (set! tests-passed (+ 1 tests-passed))
+               (pretty-print
+                (list 'name (cons ,name* current-test-name)
+                      'passed)))
+             (begin
+               (set! tests-failed (+ 1 tests-failed))
+               (pretty-print
+                (list 'name (cons ,name* current-test-name)
+                      'failed
+                      (list (list 'expected ,expected*)
+                            (list 'got ,got*)))
+                'data)))
+         (newline)))))
+
+(define-syntax test-group
+  (lambda (name-e . body)
+    (let ((old-test-name* (gensym 'old-test-name))
+          (name* (gensym 'name)))
+      `(let ((,old-test-name* current-test-name)
+             (,name* ,name-e))
+         (pretty-print (list 'entering ,name*) 'data)
+         (set! current-test-name (cons ,name* ,old-test-name*))
+         ,@body
+         (set! current-test-name ,old-test-name*)
+         (pretty-print
+          (list 'leaving ,name*
+                (list 'accumulated
+                      (list 'passed tests-passed)
+                      (list 'failed tests-failed)))
+          'data)
+         (newline)))))
+
+(load "../RPS.scm")
+(load "../macros.scm")
+(load "body.scm")