Re: Continuation examples (was Re: So, what the heck is a continuation anyway?)

[Guy Steele - Sun Microsystems Labs <address@hidden>]

   Date: Mon, 10 Dec 2001 19:23:01 -0500
   From: Philippe Meunier <meunier@ccs.neu.edu>
   
   Eric Kidd wrote:
   >Kent Pitman once showed me a profoundly evil bit of Scheme code. ...

Okay, just for fun, I upgraded the toy "FOO interpreter" of my
previous messages:

	* a string evaluates to itself
	* a lambda expression may now have several forms in the body
	  (therefore a CLOSURE now contains a list of forms;
	  @apply now uses @evlis and then extracts the last value)
	* LETREC is supported
	* a primitive function named PRINT is supported

and now it can execute the following version of the "evil code":

((call/cc
  (lambda (goto)
    (letrec ((start
              (lambda ()
                (print "start")
                (goto next)))
             (froz
              (lambda ()
                (print "froz")
                (goto last)))
             (next
              (lambda ()
                (print "next")
                (goto froz)))
             (last
              (lambda ()
                (print "last")
                (+ 3 4))))
      start))))

and the resulting output is:

start
next
froz
last
7

as you would expect.  The new code for the interpreter is:


(defun @eval (exp env cont)
  (cond ((numberp exp) (funcall cont exp))
	((stringp exp) (funcall cont exp))
	((symbolp exp) (@lookup exp env cont))
	((eq (first exp) 'LAMBDA)
	 (funcall cont (list 'CLOSURE (second exp) (rest (rest exp)) env)))
	((eq (first exp) 'IF)
	 (@eval (second exp) env
		#'(lambda (test)
		    (@eval (cond (test (second exp)) (t (third exp))) env cont))))
	((eq (first exp) 'LETREC)
	 (let ((newenv (pairlis (mapcar #'first (second exp))
				(make-list (length (second exp)))
				env)))
	   (@evletrec (second exp) newenv (third exp) newenv cont)))
	(t (@eval (first exp) env
		  #'(lambda (fn)
		      (@evlis (rest exp) env
			      #'(lambda (args) (@apply fn args cont))))))))

(defun @lookup (name env cont)
  (cond ((null env) (funcall cont name))
	((eq (car (first env)) name) (funcall cont (cdr (first env))))
	(t (@lookup name (rest env) cont))))

(defun @evlis (exps env cont)
  (cond ((null exps) (funcall cont '()))
	(t (@eval (first exps) env
		  #'(lambda (arg)
		      (@evlis (rest exps) env
			      #'(lambda (args) (funcall cont (cons arg args)))))))))

(defun @evletrec (bindings slots body env cont)
  (cond ((null bindings) (@eval body env cont))
	(t (@eval (second (first bindings)) env
		  #'(lambda (fn)
		      (rplacd (first slots) fn)  ;the side effect that "ties the knot"
		      (@evletrec (rest bindings) (rest slots) body env cont))))))

(defun @apply (fn args cont)
  (cond ((eq fn '+) (funcall cont (+ (first args) (second args))))
	((eq fn '*) (funcall cont (* (first args) (second args))))
	((eq fn 'print)
	 (princ (first args))
	 (fresh-line)
	 (funcall cont (first args)))
	((eq fn 'call/cc)
	 (@apply (first args) (list (list 'CONTINUATION cont)) cont))
	((atom fn) (funcall cont 'UNDEFINED-FUNCTION))
	((eq (first fn) 'CLOSURE)
	 (@evlis (third fn) (pairlis (second fn) args (fourth fn))
		 #'(lambda (vals) (funcall cont (first (last vals))))))
	((eq (first fn) 'CONTINUATION)
	 (funcall (second fn) (first args)))
	(t (funcall cont 'UNDEFINED-FUNCTION))))


The lessons here are:
(1) LETREC is not that difficult to add.
(2) Even toy, throwaway interpreters are vulnerable to feature creep.

--Guy