;;; Reverse Polish Scheme interpeter in Polish Scheme.

(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 (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 (not (eq? values #f))
                                 (take (cdr stack) values)
                                 (cdr stack))
                             old-stack)
                     continuation))))))

(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 vector-map
  (lambda (proc vector)
    (list->vector (map proc (vector->list vector)))))

(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 (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))
           (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 ((procedure (caddr stack))
             (drop-number (car stack))
             (save-number (cadr stack))
             (rest-of-stack (cdddr stack)))
         (interpret (cons (continuation-invoker
                           drop-number
                           save-number
                           rest-of-stack
                           (RPScdr source))
                          rest-of-stack)
                    (RPScdr procedure))))
      ((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)))
         (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 (not (eq? conditional #f))
                        (RPScdr on-true)
                        (RPScdr on-false)))))
      ((eq? (RPScar source) 'eqv?)
       (let ((x (car stack))
             (y (cadr stack)))
         (interpret (cons (eqv? x y) (cddr stack)) (RPScdr source))))
      ((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"
                   (list stack source))))))