assv in RPS

2 files changed, 98 insertions, 17 deletions

diff --git a/README.md b/README.md
index 7db8e1a..c454078 100644
--- a/README.md
+++ b/README.md
@@ -1,9 +1,11 @@
 # Reverse Polish Scheme
 
-A 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. There are only jumps in this language:
-in order to return from a procedure, you need to capture the current
+Reverse Polish Scheme (RPS) is a programming language for people who
+think continuations are too easy to understand.
+
+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.
 
 ## Core
@@ -21,7 +23,7 @@ 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`.
+* `v n ref`: Get the nth element of `v`.
 * `value n v set!`: Set the nth element of `v`.
 * `sr jump`: Jump to a procedure.
 * `conditional on-false on-true if`: If `conditional` is truthy, jump
@@ -45,3 +47,30 @@ starts in the second slot.
 * `dup`: Duplicate the top of the stack. This is a shallow copy.
 * `drop`: Drop the top of the stack.
 * `x y eqv?`: Compare two values on the top of the stack, returns a boolean.
+
+## License
+
+               DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+                       Version 2, December 2004
+     
+    Copyright (C) 2025 Peter McGoron <code@mcgoron.com>
+    
+    Everyone is permitted to copy and distribute verbatim or modified
+    copies of this license document, and changing it is allowed as long
+    as the name is changed.
+     
+               DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+      TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+    
+     0. You just DO WHAT THE FUCK YOU WANT TO.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+If you are concerned about the legalities of this license, then this
+software is not for you. Go back to Java.
diff --git a/RPS.scm b/RPS.scm
index 14ffca5..52f2eb4 100644
--- a/RPS.scm
+++ b/RPS.scm
@@ -60,14 +60,27 @@
          (loop source)))
       (else source))))
 
+(define RPSlist->list
+  (lambda (source)
+    (cond
+      ((pair? source)
+       (cons (RPSlist->list (car source))
+             (RPSlist->list (cdr source))))
+      ((and (vector? source)
+            (= (vector-length source) 2)
+            (or (vector? (vector-ref source 1))
+                (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))
+      (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))
@@ -93,14 +106,14 @@
          (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))
+       (let ((vector (cadr stack))
+             (slot (car stack)))
+         (interpret (cons (vector-ref vector slot) (cddr stack))
                     (RPScdr source))))
       ((eq? (RPScar source) 'set!)
-       (let ((vector (RPScar source))
-             (slot (cadr source))
-             (value (caddr source)))
+       (let ((vector (caddr stack))
+             (slot (car stack))
+             (value (cadr stack)))
          (vector-set! vector slot value)
          (interpret (cdddr stack)
                     (RPScdr source))))
@@ -143,7 +156,13 @@
       ((eq? (RPScar source) 'eqv?)
        (let ((x (car stack))
              (y (cadr stack)))
-         (interpret (cons (eqv? x y) stack) (RPScdr source))))
+         (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)
+       (interpret stack (RPScdr source)))
       (else (error "invalid source"
                    stack
                    source)))))
@@ -151,8 +170,41 @@
 (define interpret-datum
   (lambda (source)
     (let ((source (list->RPSlist source)))
-      (pp source) (newline)
       (interpret '() source))))
 
-(pp (interpret-datum
+#;(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)))
+