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