;;; 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 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)
    (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) 'call/cc)
       (let ((save-from-top (car stack))
             (save-from-bottom (cadr stack))
             (procedure (caddr stack))
             (rest-of-stack (cdddr stack)))
         (interpret (cons (continuation-invoker save-from-top
                                                save-from-bottom
                                                rest-of-stack
                                                (RPScdr source))
                          rest-of-stack)
                    (RPScdr procedure))))
      ((eq? (RPScar source) 'alloc)
       (let ((size (car stack)))
         (interpret (cons (make-vector size #f) (cdr stack))
                    (RPScdr source))))
      ((eq? (RPScar source) 'ref)
       (let ((vector (cadr stack))
             (slot (car stack)))
         (interpret (cons (vector-ref vector slot) (cddr stack))
                    (RPScdr source))))
      ((eq? (RPScar source) 'set!)
       (let ((vector (caddr stack))
             (slot (car stack))
             (value (cadr stack)))
         (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)))
      ((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)
       (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)))