testing macros in r4rsHEADmaster

1 files changed, 104 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))))))
+