tree->generator in Common Lisp with cl-cont

I’ve decided to try Slava Akhmechet’s cl-cont, a continuations library for Common Lisp. My little example for this purpose was to port the tree->generator function from Teach Yourself Scheme in Fixnum Days to Common Lisp. This function takes a tree and returns a function that will successively yield the leaves of the tree.

Here’s the code:

(defun/cc tree->generator (tree)
  (let (generate-leaves)
    (setf generate-leaves
	  (lambda (caller)
	    (labels ((recur (tree)
		       (cond ((null tree))  ; empty leaf: continue
			     ((consp tree)  ; recurse into branches
			      (recur (car tree))
			      (recur (cdr tree)))
			     ('otherwise ; leaf with a value:
			      (call/cc
			       (lambda (rest-of-tree)
				 ;; update generator
				 (setf generate-leaves
				       (lambda (new-caller)
					 (setf caller new-caller)
					 (funcall rest-of-tree)))
				 ;; return the value
				 (funcall caller tree)))))))
	      (recur tree))
	    (funcall caller nil)))     ; return value after exhaustion
    (lambda ()
      (call/cc generate-leaves))))

The comments are my own, so I could understand how this function works. I did also add the explicit caller argument to generate-leaves, keeping variables as local as possible is generally a good thing (and I didn’t like those dummy values). These changes aren’t specific to CL, I did a Scheme version with those too.

There was one problem that took me quite some time to solve: (SETF SYMBOL-FUNCTION) will always operate on the global binding, so I couldn’t use LABELS to define generate-leaves. Therefore, I had to use this trick of splitting the definition into a LET and a SETF to get a local function definition that could modify its own binding. In contrast, porting the continuations stuff was easy: that worked just like in Scheme.

Here’s a little usage example:

CL-USER> (defparameter *g* (tree->generator '((1 2) (3 (4 5)))))
*G*
CL-USER> (funcall *g*)
1
CL-USER> (funcall *g*)
2
CL-USER> (funcall *g*)
3
CL-USER> (funcall *g*)
4
CL-USER> (funcall *g*)
5
CL-USER> (funcall *g*)
NIL