RPS interpreter

1 files changed, 153 insertions, 0 deletions

diff --git a/RPS.scm b/RPS.scm
new file mode 100644
index 0000000..05568ca
--- /dev/null
+++ b/RPS.scm
@@ -0,0 +1,153 @@
+;;; 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)
+    (do ((stack stack (cdr stack))
+         (number number (- number 1))
+         (return '() (cons (car stack) return)))
+        ((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 (stack)
+        (let ((values (car stack)))
+          (interpret (append (if values
+                                 (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
+      ((pair? source)
+       (letrec ((loop
+                 (lambda (source)
+                   (if (pair? source)
+                       (vector (list->RPSlist (car source))
+                               (loop (cdr source)))
+                       '()))))
+         (loop source)))
+      (else source))))
+
+(define (RPScar v) (vector-ref v 0))
+(define (RPScdr v) (vector-ref v 1))
+
+(define interpret
+  (lambda (stack source)
+    (pp `((stack ,stack)
+          (source ,source)))
+    (newline)
+    (cond
+      ((null? source) stack)
+      ((or (number? (RPScar source))
+           (string? (RPScar source))
+           (null? (RPScar source))
+           (boolean? (RPScar source))
+           (vector? (RPScar source)))
+       (interpret (cons (RPScar source) stack)
+                  (RPScdr source)))
+      ((eq? (RPScar source) 'push-cc)
+       (let ((save-from-top (car stack))
+             (save-from-bottom (cadr stack))
+             (rest-of-stack (cddr stack)))
+         (interpret (cons (continuation-invoker save-from-top
+                                                save-from-bottom
+                                                rest-of-stack
+                                                (RPScdr source))
+                          rest-of-stack)
+                    (RPScdr source))))
+      ((eq? (RPScar source) 'alloc)
+       (let ((size (car stack)))
+         (interpret (cons (make-vector size #f) (cdr stack))
+                    (RPScdr source))))
+      ((eq? (RPScar source) 'ref)
+       (let ((vector (RPScar source))
+             (slot (cadr source)))
+         (interpret (cons (vector-ref vector slot) (cdr stack))
+                    (RPScdr source))))
+      ((eq? (RPScar source) 'set!)
+       (let ((vector (RPScar source))
+             (slot (cadr source))
+             (value (caddr source)))
+         (vector-set! vector slot value)
+         (interpret (cdddr stack)
+                    (RPScdr source))))
+      ((eq? (RPScar source) 'jump)
+       (let ((subroutine (car stack)))
+         (if (procedure? subroutine)
+             (subroutine (cdr stack))
+             (interpret (cdr stack)
+                        (RPScdr subroutine)))))
+      ((eq? (RPScar source) 'if)
+       (let ((on-true (car stack))
+             (on-false (cadr stack))
+             (conditional (caddr stack)))
+         (interpret (cdddr stack)
+                    (if conditional
+                        (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)))
+      (else (error "invalid source"
+                   stack
+                   source)))))
+
+(define interpret-datum
+  (lambda (source)
+    (let ((source (list->RPSlist source)))
+      (pp source) (newline)
+      (interpret '() source))))
+
+(pp (interpret-datum
+     '(#f 0 0 push-cc #f 1 dig (() #t #t #f #f 3 dig jump) (() drop "call cc in FORTH!") if)))