diff options
| -rw-r--r-- | README.md | 103 | ||||
| -rw-r--r-- | RPS.scm | 177 | ||||
| -rw-r--r-- | macros.scm | 65 | ||||
| -rw-r--r-- | tests/body.scm | 104 | ||||
| -rw-r--r-- | tests/s9fes.scm | 53 |
5 files changed, 351 insertions, 151 deletions
@@ -1,52 +1,85 @@ -# Reverse Polish Scheme +# Reverse Polish Scheme: Or, `call/cc`, The Ultimate Opcode -Reverse Polish Scheme (RPS) is a programming language for people who -think continuations are too easy to understand. +Programming languages should not be designed by piling feature on top of +feature, but by taking away as many features as possible until what is +left is completely unusable. Reverse Polish Scheme demonstrates that +having one way of forming expressions, with no restrictions on how it +is used, suffices to create a pile of slow, uncomposable and difficult +to understand programs. -RPS is stack-based programming language vaguely based off of FORTH but -really just Scheme in disguise. RPS only has jumps: in order to return -from a procedure, you need to use `call/cc` to capture the current -continuation and pass it to the procedure. +Reverse Polish Scheme (RPS) is a homoiconic stack-based programming +language vaguely based off of Forth but really just Scheme in +disguise. RPS has a single stack that can be saved and restored using +`call/cc` to capture a part of the continuation of the program. The +`call/cc` primitive is powerful enough to do express stack manipulations +like `swap`, `pick`, and `roll`, function calls that return using the +continuation passing style, non-local exits, closures, and delimited +continuations. + +Another name for RPS is FIFTH, because that's what you'll want to drink +after writing in this language! ## 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"`! +RPS is written in a subset of Scheme's syntax. + +Line comments start with `;`. Nested block comments start with `#|` +and end with `|#`. Writing a number, string, `#t`, or `#f` will push +that literal value onto the stack. Writing an identifier will execute +that identifier. + +A literal vector is introduced with `#(` and ends with `)`. A literal +list (a linked list where each list cell is a vector of two elements) +starts with `(` and ends with `)`. The empty list (nil) is represented by +`()`. A literal identifier is introduced with `'`. (Note that lists and +vectors are not quoted.) + +A procedure is a linked list whose first element can be used for data +storage, and whose tail is a linked list of instructions to execute. -A linked list is a 2-vector whose second pair is either `#nil` or -another linked list. +If the interpreter hits the end of a procedure, it will halt. -A procedure is a linked list whose first slot is unused and whose code -starts in the second slot. +The primitive procedures are: -* `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. +### Vectors + +* `n vector`: Allocate a vector of `n` values. +* `vec vector-length`: Get the length of a vector. Returns `#f` if the + input is not a vector. * `v n ref`: Get the nth element of `v`. * `value n v set!`: Set the nth element of `v`. + +### Control Flow + * `sr jump`: Jump to a procedure. * `conditional on-false on-true if`: If `conditional` is truthy, jump to `on-true`. Otherwise jump to `on-false`. -* `proc keep-bot keep-top call/cc`: Jump to `proc` with the continuation - pushed to the stack. 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 - `call/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 - after `call/cc`. -* `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. -* `dup`: Duplicate the top of the stack. This is a shallow copy. -* `drop`: Drop the top of the stack. +* `proc to from call/cc`: Jump to `proc` with the continuation `cc` pushed + to the stack. When `m cc jump` is called (where `cc` is the object + returned by `call/cc`), control returns to the instruction after + `call/cc`, except that the stack is the `m` values on the stack before + the jump appended to the values on the stack from `from` inclusive to + `to` exclusive at the site of `call/cc`'s invocation. + +### Operations on Values + * `x y eqv?`: Compare two values on the top of the stack, returns a boolean. +* `x symbol?`: Predicate for symbols. +* `x integer?`: Predicate for fixnums. +* `x real?`: Predicate for flonums. +* `x y +`: Addition. +* `x y *`: Multiplication. + +## Implementation + +A simple and very portable R4RS Scheme implementation of the Core is +located in `RPS.scm`. One can use `quasiquote` as a macro system (there +is no lexical environment and hence no need for hygenic macros). Some +macros that implement stack operations can be found in `macros.scm`. + +RPS has been tested using [Scheme 9 From Empty Space][s9]. + +[s9]: https://t3x.org/s9book/index.html ## License @@ -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)))))) 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 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)))))) + diff --git a/tests/s9fes.scm b/tests/s9fes.scm new file mode 100644 index 0000000..5b02963 --- /dev/null +++ b/tests/s9fes.scm @@ -0,0 +1,53 @@ +;;; Shim for SRFI-64 for unhygenic, single threaded systems. + +(define tests-passed 0) +(define tests-failed 0) +(define current-test-name '()) + +(define-syntax test-equal + (lambda (name-e expected-e got-e) + (let ((name* (gensym 'name)) + (expected* (gensym 'expected)) + (got* (gensym 'got)) + (passed?* (gensym 'passed?))) + `(let* ((,name* ,name-e) + (,expected* ,expected-e) + (,got* ,got-e) + (,passed?* (equal? ,expected* ,got*))) + (if ,passed?* + (begin + (set! tests-passed (+ 1 tests-passed)) + (pretty-print + (list 'name (cons ,name* current-test-name) + 'passed))) + (begin + (set! tests-failed (+ 1 tests-failed)) + (pretty-print + (list 'name (cons ,name* current-test-name) + 'failed + (list (list 'expected ,expected*) + (list 'got ,got*))) + 'data))) + (newline))))) + +(define-syntax test-group + (lambda (name-e . body) + (let ((old-test-name* (gensym 'old-test-name)) + (name* (gensym 'name))) + `(let ((,old-test-name* current-test-name) + (,name* ,name-e)) + (pretty-print (list 'entering ,name*) 'data) + (set! current-test-name (cons ,name* ,old-test-name*)) + ,@body + (set! current-test-name ,old-test-name*) + (pretty-print + (list 'leaving ,name* + (list 'accumulated + (list 'passed tests-passed) + (list 'failed tests-failed))) + 'data) + (newline))))) + +(load "../RPS.scm") +(load "../macros.scm") +(load "body.scm") |