RPS interpreter

2 files changed, 194 insertions, 0 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..1f085b1
--- /dev/null
+++ b/README.md
@@ -0,0 +1,41 @@
+# Reverse Polish Scheme
+
+A continuation-passing-style stack-based programming language vaguely
+based off of FORTH but really just Scheme in disguise. With the exception
+of quotation (which is syntax), everything is RPN.
+
+## Core
+
+Writing a number, a string, `#t`, `#f`, or `#nil` will push that literal
+value onto the stack. Strings are equivalent to Scheme symbols. `#nil`
+is the name of a value, NOT the symbol `"nil"`!
+
+A linked list is a 2-vector whose second pair is either `#nil` or
+another linked list.
+
+A subroutine is a linked list whose first slot is unused and whose code
+starts in the second slot.
+
+* `n alloc`: Allocate a memory region of `n` pointers.
+* `{ ... }`: Reads all data up to the matching `{` as data. The data
+  is stored as a linked list.
+* `n v ref`: Get the nth element of `v`.
+* `value n v set!`: Set the nth element of `v`.
+* `sr jump`: Jump to a subroutine.
+* `conditional on-false on-true if`: If `conditional` is truthy, jump
+  to `on-true`. Otherwise jump to `on-false`.
+* `keep-bot keep-top push-cc`: Push the *continuation* of the call to
+  `push-cc`. The continuation object saves the last `keep-top` objects
+  on the stack along with the bottom `keep-bot` values on the stack. If
+  either is `#f`, then the entire stack is saved.
+
+  When `m cc jump` is called (where `cc` is the object returned by
+  `push-cc`), the `m` values currently on the stack are pushed to the top
+  of `n` values saved by `cc`, and control returns to the next location.
+* `dir? n dig`: When `dir?` is false, move the `n`th value relative to the
+  top of the stack to the top of the stack. When `dir?` is true, move the
+  `n`th value relative to the bottom of the stack to the top of the stack.
+* `dir? n bury`: When `dir?` is false, move the top value on the stack to
+  the `n`th value relative to the top of the stack. When `dir?` is true,
+  move the top of the stack to `n`th value relative to the bottom of
+  the stack.
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)))