assv in RPS

1 files changed, 64 insertions, 12 deletions

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)))
+