;; The following routine is based on the model of heap-based Scheme
compilation described in Chapter 3 of Kent Dybvig's Ph.D. thesis, <a
href="cs491/three-imp.pdf"> <cite>Three Implementation Models for
Scheme.</cite></a>
<xmp>
(define-macro name-parts-of
  (lambda (ls names . body)
    `(apply (lambda ,names ,@body) ,ls)))

(define kompile
  (lambda (x next)
    (letrec
      ((loop
	(lambda (args c)
	  (if (null? args)
	      (if (tail? next)
		  c
		  `(frame ,next ,c))
	      (loop (cdr args)
		    (kompile (car args) `(argument ,c)))))))
    (cond ((symbol? x)
	   `(refer ,x ,next))
	  ((pair? x)
	   (let ((y (car x)))
	     (cond ((eq? y 'quote)
		    (name-parts-of (cdr x) (obj)
		      `(constant ,obj ,next)))
		   ((eq? y 'lambda)
		    (name-parts-of (cdr x) (vars body)
		      `(close ,vars ,(kompile body '(return)) ,next)))
		   ((eq? y 'if)
		    (name-parts-of (cdr x) (test then alt)
		      (kompile test `(test ,(kompile then next)
					   ,(kompile alt next)))))
		   ((eq? y 'set!)
		    (name-parts-of (cdr x) (var x)
		      (kompile x `(assign ,var ,next))))
		   (else
		    (loop (cdr x) (kompile (car x) '(apply)))))))
	  (else
	   `(constant ,x ,next))))))

(define tail?
  (lambda (next)
    (eq? (car next) 'return)))

(define vm
  (lambda (a x e r s)
    (let ((y (car x)))
      (display y)
      (newline)
      (display " a=")
      (display a)
      (newline)
      (display " r=")
      (display r)
      (newline)      
      (cond ((eq? y 'halt) a)
	    ((eq? y 'refer)
	     (name-parts-of (cdr x) (var x)
	       (vm (car (lookup var e)) x e r s)))
	    ((eq? y 'constant)
	     (name-parts-of (cdr x) (obj x)
	       (vm obj x e r s)))
	    ((eq? y 'close)
	     (name-parts-of (cdr x) (vars body x)
	       (vm (closure body e vars) x e r s)))
	    ((eq? y 'test)
	     (name-parts-of (cdr x) (then alt)
	       (vm a (if a then alt) e r s)))
	    ((eq? y 'assign)
	     (name-parts-of (cdr x) (var x)
	       (set-car! (lookup var e) a)
	       (vm a x e r s)))
	    ((eq? y 'frame)
	     (name-parts-of (cdr x) (ret x)
	       (vm a x e () (list ret e r s))))
	    ((eq? y 'argument)
	     (name-parts-of (cdr x) (x)
	       (vm a x e (cons a r) s)))
	    ((eq? y 'apply)
	     (if (procedure? a)
		 (let ((a (apply a r)))
		   (name-parts-of s (x e r s)
		     (vm a x e r s)))
		 (name-parts-of a (body e vars)
		   (vm a body (extend e vars r) () s))))
	    ((eq? y 'return)
	     (name-parts-of s (x e r s)
	       (vm a x e r s)))))))

(define lookup
  (lambda (var e)
    (letrec
      ((nxtrib
	(lambda (e)
	  (nxtelt (caar e) (cdar e))))
       (nxtelt
	(lambda (vars vals)
	  (cond ((null? vars) (nxtrib (cdr e)))
		((eq? (car vars) var) vals)
		(else
		 (nxtelt (cdr vars) (cdr vals)))))))
      (nxtrib e))))

(define closure
  (lambda (body e vars)
    (list body e vars)))

(define extend
  (lambda (e vars vals)
    (cons (cons vars vals) e)))

(define global-env `(((x y + * - / = cons car cdr) 3 4 ,+ ,* ,- ,/ ,= ,cons ,car ,cdr)))

(define evaluate
  (lambda (x)
    (vm () (kompile x '(halt)) global-env () ())))
</xmp>