testing macros in r4rsHEADmaster

1 files changed, 61 insertions, 116 deletions

diff --git a/RPS.scm b/RPS.scm
index 52f2eb4..16e569e 100644
--- a/RPS.scm
+++ b/RPS.scm
@@ -1,12 +1,4 @@
 ;;; Reverse Polish Scheme interpeter in Polish Scheme.
-;;; 
-;;; Pairs in RPS are just vectors of two elements.
-
-(define reverse-append
-  (lambda (list new)
-    (do ((list list (cdr list))
-         (new new (cons (car list) new)))
-        ((null? list) new))))
 
 (define take
   (lambda (stack number)
@@ -16,37 +8,19 @@
         ((zero? number) (reverse return)))))
 
 (define continuation-invoker
-  (lambda (save-from-top save-from-bottom old-stack continuation)
-    (let ((old-stack (if (and save-from-top save-from-bottom)
-                         (append (take old-stack save-from-top)
-                                 (take-right old-stack save-from-bottom))
-                         old-stack)))
+  (lambda (drop-number save-number old-stack continuation)
+    (let* ((dropped (list-tail old-stack drop-number))
+           (old-stack (if (not (eq? save-number #f))
+                          (take dropped save-number)
+                          dropped)))
       (lambda (stack)
         (let ((values (car stack)))
-          (interpret (append (if values
+          (interpret (append (if (not (eq? values #f))
                                  (take (cdr stack) values)
                                  (cdr stack))
                              old-stack)
                      continuation))))))
 
-(define dig
-  (lambda (stack offset)
-    (do ((stack stack (cdr stack))
-         (offset offset (- offset 1))
-         (searched '() (cons (car stack) searched)))
-        ((zero? offset)
-         (cons (car stack)
-               (reverse-append searched (cdr stack)))))))
-
-(define bury
-  (lambda (stack offset)
-    (do ((culprit (car stack))
-         (stack (cdr stack) (cdr stack))
-         (offset (- offset 1) (- offset 1))
-         (searched '() (cons (car stack) searched)))
-        ((zero? offset)
-         (reverse-append searched (cons culprit stack))))))
-
 (define list->RPSlist
   (lambda (source)
     (cond
@@ -60,6 +34,10 @@
          (loop source)))
       (else source))))
 
+(define vector-map
+  (lambda (proc vector)
+    (list->vector (map proc (vector->list vector)))))
+
 (define RPSlist->list
   (lambda (source)
     (cond
@@ -72,15 +50,15 @@
                 (null? (vector-ref source 1))))
        (cons (RPSlist->list (vector-ref source 0))
              (RPSlist->list (vector-ref source 1))))
-      ((vector? source)
-       (vector-map RPSlist->list source))
+      ((vector? source) (vector-map RPSlist->list source))
       (else source))))
 
-(define (RPScar v) (vector-ref v 0))
-(define (RPScdr v) (vector-ref v 1))
+(define RPScar (lambda (v) (vector-ref v 0)))
+(define RPScdr (lambda (v) (vector-ref v 1)))
 
 (define interpret
   (lambda (stack source)
+    ;; (pretty-print (list (list 'stack stack) (list 'source (RPSlist->list source))) 'data)
     (cond
       ((null? source) stack)
       ((or (number? (RPScar source))
@@ -91,20 +69,28 @@
        (interpret (cons (RPScar source) stack)
                   (RPScdr source)))
       ((eq? (RPScar source) 'call/cc)
-       (let ((save-from-top (car stack))
-             (save-from-bottom (cadr stack))
-             (procedure (caddr stack))
+       (let ((procedure (caddr stack))
+             (drop-number (car stack))
+             (save-number (cadr stack))
              (rest-of-stack (cdddr stack)))
-         (interpret (cons (continuation-invoker save-from-top
-                                                save-from-bottom
-                                                rest-of-stack
-                                                (RPScdr source))
+         (interpret (cons (continuation-invoker
+                           drop-number
+                           save-number
+                           rest-of-stack
+                           (RPScdr source))
                           rest-of-stack)
                     (RPScdr procedure))))
-      ((eq? (RPScar source) 'alloc)
+      ((eq? (RPScar source) 'vector)
        (let ((size (car stack)))
          (interpret (cons (make-vector size #f) (cdr stack))
                     (RPScdr source))))
+      ((eq? (RPScar source) 'vector-length)
+       (let ((vector (car stack)))
+         (interpret (cons (if (vector? vector)
+                              (vector-length vector)
+                              #f)
+                          (cdr stack))
+                    (RPScdr source))))
       ((eq? (RPScar source) 'ref)
        (let ((vector (cadr stack))
              (slot (car stack)))
@@ -128,83 +114,42 @@
              (on-false (cadr stack))
              (conditional (caddr stack)))
          (interpret (cdddr stack)
-                    (if conditional
+                    (if (not (eq? conditional #f))
                         (RPScdr on-true)
                         (RPScdr on-false)))))
-      ((eq? (RPScar source) 'dig)
-       (let ((offset (car stack))
-             (dir? (cadr stack))
-             (new-stack (cddr stack)))
-         (interpret (dig new-stack
-                         (if dir?
-                             (- (length new-stack) offset)
-                             offset))
-                    (RPScdr source))))
-      ((eq? (RPScar source) 'bury)
-       (let ((offset (car stack))
-             (dir? (cadr stack))
-             (new-stack (cddr stack)))
-         (interpret (bury new-stack
-                          (if dir?
-                              (- (length new-stack) offset)
-                              offset))
-                    (RPScdr source))))
-      ((eq? (RPScar source) 'drop)
-       (interpret (cdr stack) (RPScdr source)))
-      ((eq? (RPScar source) 'dup)
-       (interpret (cons (car stack) stack) (RPScdr source)))
       ((eq? (RPScar source) 'eqv?)
        (let ((x (car stack))
              (y (cadr stack)))
          (interpret (cons (eqv? x y) (cddr stack)) (RPScdr source))))
-      ((eq? (RPScar source) 'bkpt)
-       (pp `((stack ,(RPSlist->list stack))
-             (source ,(RPSlist->list source))))
-       (newline)
-       (bkpt #f)
+      ((eq? (RPScar source) 'symbol?)
+       (interpret (cons (symbol? (car stack)) (cdr stack))
+                  (RPScdr source)))
+      ((eq? (RPScar source) 'integer?)
+       (let ((x (car stack)))
+         (interpret (cons (and (integer? x)
+                               (exact? x))
+                          (cdr stack))
+                    (RPScdr source))))
+      ((eq? (RPScar source) 'real?)
+       (let ((x (car stack)))
+         (interpret (cons (and (real? x)
+                               (inexact? x))
+                          (cdr stack))
+                    (RPScdr source))))
+      ((eq? (RPScar source) '+)
+       (let ((x (car stack))
+             (y (cadr stack))
+             (rest (cddr stack)))
+         (interpret (cons (+ x y) rest) (RPScdr source))))
+      ((eq? (RPScar source) '*)
+       (let ((x (car stack))
+             (y (cadr stack))
+             (rest (cddr stack)))
+         (interpret (cons (* x y) rest) (RPScdr source))))
+      ((eq? (RPScar source) 'debug-print)
+       (pretty-print `((stack ,(map RPSlist->list stack))
+                       (source ,(cdr (RPSlist->list source))))
+                     'data)
        (interpret stack (RPScdr source)))
       (else (error "invalid source"
-                   stack
-                   source)))))
-
-(define interpret-datum
-  (lambda (source)
-    (let ((source (list->RPSlist source)))
-      (interpret '() source))))
-
-#;(pp (interpret-datum
-     '((() dup #f #f 1 dig 2 #f 1 dig jump) 0 0 call/cc (() #t 1 #f 2 dig jump) (() "call/cc in FORTH!") if)))
-
-(define (interpret1 stack cmd)
-  (interpret stack (if (pair? cmd)
-                       (vector (list->RPSlist source) '())
-                       cmd)))
-
-(define RPS:global-assv
-  (list->RPSlist
-   `(,(vector (vector (vector 'name (lambda (stack)
-                                      (pp (list 'success stack))))
-                      '()))
-     0 ref 0 ref
-     ;; Start: [init-cell name k]
-     (()
-      ;; Start: [cc init-cell name k]
-      dup 2 #f 2 dig jump)
-     2 0 call/cc
-     ;; [cc init-cell name k]
-     #f 1 dig dup () eqv?
-     ;; Inside of each if: [list cc name k]
-     (() dup 0 ref dup 0 ref           ; [the-car the-pair list cc name k]
-         #f 4 dig eqv?                 ; [boolean the-pair list cc k]
-         (() drop 1 ref                    ; [1 return-proc list cc k]
-             #f 1 dig dup 2 #f 1 dig jump)
-         (() 1 ref 1 #f 4 dig bkpt jump)
-         if)
-     (() drop drop drop #f #f 1 dig jump)
-     if)))
-
-(define stack (list RPS:global-assv
-                    'name*
-                    (lambda (stack) (pp (list 'just-returned stack)))))
-(interpret stack (list->RPSlist '(dup jump)))
-
+                   (list stack source))))))