testing macros in r4rsHEADmaster

1 files changed, 65 insertions, 0 deletions

diff --git a/macros.scm b/macros.scm
new file mode 100644
index 0000000..1696028
--- /dev/null
+++ b/macros.scm
@@ -0,0 +1,65 @@
+(define inline-dup
+  ;; [x] -> [x x]
+  '(1 (#f jump) #f 1 call/cc))
+
+(define inline-drop
+  ;; [x] -> []
+  '(0 (#f jump) #f 2 call/cc))
+
+(define inline-dropn
+  ;; [x1 ... xn xn+1 ...] -> [x1 ... xn+1 ...]
+  (lambda (n)
+    `(,n
+      (#f                              ; [K n x1 ... xn xn+1 ...]
+       jump)
+      #f ,(+ n 2) call/cc)))
+
+(define inline-pick
+  ;; [x1 ... xn] -> [xn x1 ... xn]
+  (lambda (n)
+    `(1                                ; [1 x1 ... xn]
+      (#f 2                            ; [2 K 1 x1 ... xn]
+          (#f jump)                    ; [K' 2 K 1 x1 ... xn]
+          #f ,(+ 3 n) call/cc          ; [K 1 xn ...]
+          jump)
+      #f 1 call/cc)))
+
+(define inline-roll
+  (lambda (n)
+    `(,@(inline-pick n) ,@(inline-dropn (+ n 1)))))
+
+(define stack-closure
+  ;; Push a procedure to the stack that, when executed, will have the
+  ;; current stack (plus whatever is pushed to it).
+  ;; 
+  ;; The arguments to the stack closure are [N returnK self values ...],
+  ;; where `N` is the total number of values to pass to the procedure
+  ;; (`returnK` and `self` excluded).
+  (lambda (procedure n m)
+    `((#f                              ; [next v ...]
+       (#f                             ; [K next v ...]
+        #f 3 ,@(inline-pick 2)         ; [K 3 #f K next v ...]
+        jump)
+       ,m ,(+ n 1) call/cc
+       ;; This is the entry-point into the continuation.
+       ;; 
+       ;; [regular? K arg1 values ...]
+       ;; When `regular?` is false, then `K` is the captured continuation,
+       ;; and `arg1` is the continuation of this macro.
+       ;; When `regular?` is true, then `K` is the return continuation, and
+       ;; `arg1` is the number of arguments to the procedure body.
+       #t eqv?
+       (#f                             ; false: [K next]
+        ;; The following is the returned procedure.
+        (#f                            ; [returnK N self values ...]
+         ,@(inline-pick 2) 0 ref       ; [K-here returnK N self values ...]
+         #t ,@(inline-pick 3) 4 +      ; [(+ N 4) #t K-here returnK N self values ...]
+         ,@(inline-roll 2)             ; [K-here (+ N 4) #t returnK N self values ...]
+         jump)                         ; [proc K next]
+        ,@inline-dup                   ; [proc proc K next]
+        ,@(inline-roll 2)              ; [K proc proc next]
+        0 set!                         ; [proc next]
+        1 ,@(inline-roll 2)            ; [next 1 proc]
+        jump)
+       ,procedure if)
+      #f 0 call/cc)))
\ No newline at end of file