(define (refer-op var next) (vector 'refer var next))
(define (refer-op? o) (eq? (vector-ref o 0) 'refer))
(define (refer-var o) (vector-ref o 1))
(define (refer-next o) (vector-ref o 2))

(define (constant-op obj next) (vector 'constant obj next))
(define (constant-op? o) (eq? (vector-ref o 0) 'constant))
(define (constant-obj o) (vector-ref o 1))
(define (constant-next o) (vector-ref o 2))

(define (close-op body next) (vector 'close body next))
(define (close-op? o) (eq? (vector-ref o 0) 'close))
(define (close-body o) (vector-ref o 1))
(define (close-next o) (vector-ref o 2))

(define (test-op if-true if-false) (vector 'test if-true if-false))
(define (test-op? o) (eq? (vector-ref o 0) 'test))
(define (test-then o) (vector-ref o 1))
(define (test-else o) (vector-ref o 2))

(define (assign-op var next) (vector 'assign var next))
(define (assign-op? o) (eq? (vector-ref o 0) 'assign))
(define (assign-var o) (vector-ref o 1))
(define (assign-next o) (vector-ref o 2))

(define (conti-op next) (vector 'conti next))
(define (conti-op? o) (eq? (vector-ref o 0) 'conti))
(define (conti-next o) (vector-ref o 1))

(define (nuate-op s var) (vector 'nuate s var))
(define (nuate-op? o) (eq? (vector-ref o 0) 'nuate))
(define (nuate-s o) (vector-ref o 1))
(define (nuate-var o) (vector-ref o 2))

(define (frame-op ret next) (vector 'frame ret next))
(define (frame-op? o) (eq? (vector-ref o 0) 'frame))
(define (frame-ret o) (vector-ref o 1))
(define (frame-next o) (vector-ref o 2))

(define (argument-op next) (vector 'argument next))
(define (argument-op? o) (eq? (vector-ref o 0) 'argument))
(define (argument-next o) (vector-ref o 1))

(define (apply-op) (vector 'apply))
(define (apply-op? o) (eq? (vector-ref o 0) 'apply))

(define (return-op) (vector 'return))
(define (return-op? o) (eq? (vector-ref o 0) 'return))

(define (halt-op) (vector 'halt))
(define (halt-op? o) (eq? (vector-ref o 0) 'halt))

(define (extend e r) (cons r e))

(define (compile-lookup var e)
   (let nxtrib ((e e) (rib 0))
      (let nxtelt ((vars (car e)) (elt 0))
	 (cond ((null? vars) (nxtrib (cdr e) (+ rib 1)))
	       ((eq? (car vars) var) (cons rib elt))
	       (else
		(nxtelt (cdr vars) (+ elt 1)))
	       ))))

(define (tail? next) (return-op? next))

(define (compile x e next k-fail)
   (cond ((symbol? x) (refer-op (compile-lookup x e) next))
	 ((list? x)
	  (let ((x-length (length x))
		(v (list->vector x)))
	     (case (vector-ref v 0)
		((quote)
		 (if (= x-length 2)
		     (constant-op (vector-ref v 1) next)
		     (k-fail x)))
		((lambda)
		 (if (= x-length 3)
		     (close-op (compile (vector-ref v 2)
					(extend e (vector-ref v 1))
					(return-op)
					k-fail)
			       next)
		     (k-fail x)))
		((if)
		 (if (= x-length 4)
		     (let ((thenc (compile (vector-ref v 2) e next k-fail))
			   (elsec (compile (vector-ref v 3) e next k-fail)))
			(compile (vector-ref v 1) e (test-op thenc elsec) k-fail))
		     (k-fail x)))
		((set!)
		 (if (= x-length 3)
		     (let ((access (compile-lookup (vector-ref v 1) e)))
			(compile (vector-ref v 2) e (assign-op access next) k-fail))
		     (k-fail x)))
		((call/cc)
		 (if (= x-length 2)
		     (let ((c (conti-op
			       (argument-op
				(compile (vector-ref v 1) e (apply-op) k-fail)
				))))
			(if (tail? next)
			    c
			    (frame-op next c)))
		     (k-fail x)))
		(else
		 (let loop ((args (cdr x))
			    (c (compile (car x) e (apply-op) k-fail)))
		    (if (null? args)
			(if (tail? next)
			    c
			    (frame-op next c))
			(loop (cdr args)
			      (compile (car args) e (argument-op c) k-fail))
			))))))
	 (else
	  (constant-op x next))
	 ))

(define (closure body e) (vector 'closure body e))
(define (closure-body c) (vector-ref c 1))
(define (closure-e c) (vector-ref c 2))

(define (call-frame x e r s) (vector 'call-frame x e r s))
(define (call-frame-x f) (vector-ref f 1))
(define (call-frame-e f) (vector-ref f 2))
(define (call-frame-r f) (vector-ref f 3))
(define (call-frame-s f) (vector-ref f 4))

(define (continuation s) (closure (nuate-op s '(0 . 0)) '()))

(define (lookup access e)
   (let nxtrib ((e e) (rib (car access)))
      (if (= rib 0)
	  (let nxtelt ((r (car e)) (elt (cdr access)))
	     (if (= elt 0)
		 r
		 (nxtelt (cdr r) (- elt 1))))
	  (nxtrib (cdr e) (- rib 1)))))

(define (VM k-fail a x e r s)
   (cond ((halt-op? x) a)
	 ((refer-op? x)
	  (VM k-fail (car (lookup (refer-var x) e)) (refer-next x) e r s))
	 ((constant-op? x)
	  (VM k-fail (constant-obj x) (constant-next x) e r s))
	 ((close-op? x)
	  (VM k-fail (closure (close-body x) e) (close-next x) e r s))
	 ((test-op? x)
	  (VM k-fail a (if a (test-then x) (test-else x)) e r s))
	 ((assign-op? x)
	  (set-car! (lookup (assign-var x) e) a)
	  (VM k-fail a (assign-next x) e r s))
	 ((conti-op? x)
	  (VM k-fail (continuation (conti-next x)) (conti-next x) e r s))
	 ((nuate-op? x)
	  (VM k-fail (car (lookup (nuate-var x) e)) (return-op) e r s))
	 ((frame-op? x)
	  (VM k-fail a (frame-next x) e '() (call-frame (frame-ret x) e r s)))
	 ((argument-op? x)
	  (VM k-fail a (argument-next x) e (cons a r) s))
	 ((apply-op? x)
	  (if (procedure? a)
	      (VM k-fail (apply a r) (return-op) e '() s)
	      (VM k-fail a (closure-body a) (extend (closure-e a) r) '() s)))
	 ((return-op? x)
	  (VM k-fail a
	      (call-frame-x s)
	      (call-frame-e s)
	      (call-frame-r s)
	      (call-frame-s s)))
	 (else
	  (k-fail a x e r s))
	 ))

(define r5rs-names
   '((cons pair? car cdr
      number? + - * / < <= = >= >
      )))

(define r5rs-values
   `((,cons ,pair? ,car ,cdr
      ,number? ,+ ,- ,* ,/ ,< ,<= ,= ,>= ,>
      )))

(define (compile-error x)
   (for-each display
	     `("Compiler error at: " ,x #\newline)))

(define (VM-error a x e r s)
   (for-each display
	     `("VM Error! registers: " #\newline
               "a: " ,a #\newline
               "x: " ,x #\newline
               "e: " ,e #\newline
               "r: " ,r #\newline
               "s: " ,s #\newline)))

(define (heap-eval x)
   (VM VM-error
       '()
       (compile x r5rs-names (halt-op) compile-error)
       r5rs-values
       '()
       '()))

; test cases
; (heap-eval '((lambda (x) (if (number? x) (+ x 10) "nope")) 35))

;(heap-eval '(((lambda (fact) ((lambda (k) fact) (set! fact (lambda (n) (if (= n 0) 1 (* n (fact (- n 1)))))))) '()) 10))

; (heap-eval '(((lambda (fib) ((lambda (k) fib) (set! fib (lambda (n) (if (<= n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))))) '()) 10)))

(define (read-prompted)
   (display "dybvig-heap> ")
   (read))

(let repl ((expr (read-prompted)))
   (if (not (eof-object? expr))
       (let ((val (heap-eval expr)))
	  (write val)
	  (newline)
	  (repl (read-prompted))
	  )))