Tail recursion syntactic sugar faked with TAGBODY-based construct?
Kaz Kylheku
The idea is to extend TAGBODY in a simple way: give the tags named
parameters, and provide a GOTO that takes argument expressions. The
parameters are simply the names of variables that are in scope of the
body, and the GOTO simply assigns the argument value to the
variables. The syntactic sugar is considerable though. And there /is/
a subtlety: shadowing is handled. If a GOTO occurs in some inner scope
in which a a label parameter is shadowed, the GOTO will properly
initialize the outer variable. It won't blindly assign to the inner
variable.
With this, you can express tail recursion, including mutual tail
recursion, with nearly the same syntactic sugar. And it turns into
stackless iteration: jumping around within a TAGBODY.
E.g. in the thread ``better way to enumerate'', viper-2 posted this:
(defun enumerate-with-op (start end &optional elist)
(if (> start end)
(reverse elist)
(enumerate-with-op (1+ start) end
(cons start elist))))
With the ARGTAGS macro, we can write ENUMERATE like this, and not rely
on tail recursion optimization:
;; should be called IOTA or some variation thereof
(defun enumerate (start end)
(let (result-list)
(argtags nil
(label enumerate start end result-list)
(when (> start end)
(return (nreverse result-list)))
(goto enumerate (1+ start) end (cons start result-list)))))
Since tail recursion /is/ a freaking goto, damn it, just express it
that way! You don't need to write a compiler, and consequently you
don't need to duck out of mutual tail recursion because that part of
the compiler turns out to be too hard to write.
Anyone have any interesting mutual tail recursion examples? I'd like
to try rewriting them using ARGTAGS.
The implementation of ARGTAGS follows. There is clutter due to error
checking, and also due to the handling of the shadowing problem. The
strategy is to turn
(GOTO L A1 A2 ...)
into
(PROGN (PSETF #:G0100 A1 #:G0101 A2 ...) (GO #:G0001))
Where #:G0001 is a label within a thunk section that is inserted at
the end of the body. The entry in the thunk section looks like this:
#:G0001 (PSETF V1 #:G0100 V2 #:G0101 ...) (GO L)
Where V1 V2 ... are the real variables (parameters of label L). I.e.
we store the arguments into some secret local gensym variables, jump
to a thunk, thereby leaving the scope where the real variables might
be shadowed, then load the real variables from the secret gensyms and
bounce to the real target label.
(defmacro argtags (block-name &rest labels-and-forms)
(unless (symbolp block-name)
(error "ARGTAGS: block name must be a symbol, not ~a!" block-
name))
(let (labels forms thunks thunk-gensyms)
(dolist (item labels-and-forms)
(cond
((symbolp item)
(push `(,item () () ,item) labels)
(push item forms))
((and (consp item)
(eq (first item) 'label))
(unless (and (symbolp (second item))
(listp (rest (rest item)))
(every #'symbolp (rest (rest item))))
(error "ARGTAGS: bad label syntax ~a in block ~a" item block-
name))
(destructuring-bind (op label &rest vars) item
(let ((gensyms (mapcar (lambda (var)
(gensym (symbol-name var)))
vars))
(thunk-label (gensym (symbol-name label))))
(push `(,label ,vars ,gensyms ,thunk-label) labels)
(push thunk-label thunks)
(push
`(psetf ,@(mapcan (lambda (realvar gensym)
`(,realvar ,gensym))
vars gensyms))
thunks)
(push `(go ,label) thunks)
(setf thunk-gensyms (nconc gensyms thunk-gensyms))
(push label forms))))
(t
(push item forms))))
`(macrolet ((goto (label &rest args)
(let* ((labels ',labels)
(matching-label (find label labels :key
#'first)))
(unless matching-label
(error "ARGTAGS: goto undefined label ~a in
block ~a"
label ',block-name))
(destructuring-bind (name vars gensyms thunk-
label)
matching-label
(declare (ignore name))
(when (/= (length args) (length vars))
(error "ARGTAGS: label ~a caled with wrong
argument count in block ~a"
label ',block-name))
`(progn
,@(if args `((psetf ,@(mapcan (lambda
(gensym arg)
`(,gensym ,arg))
gensyms
args))))
(go ,thunk-label))))))
(block ,block-name
(let (,@thunk-gensyms)
(tagbody
,@(nreverse forms)
(return-from ,block-name)
,@(nreverse thunks)))))))
Pascal Costanza
> Anyone have any interesting mutual tail recursion examples? I'd like
> to try rewriting them using ARGTAGS.
The lower part of
http://classes.eclab.byu.edu/330/wiki/index.cgi?FunWithMacros
Pascal
--
1st European Lisp Symposium (ELS'08)
http://prog.vub.ac.be/~pcostanza/els08/
My website: http://p-cos.net
Common Lisp Document Repository: http://cdr.eurolisp.org
Closer to MOP & ContextL: http://common-lisp.net/project/closer/
Kaz Kylheku
> Anyone have any interesting mutual tail recursion examples? I'd like
> to try rewriting them using ARGTAGS.
Oh yeah, there is the silly even and odd thing.
TR version:
(defun even (n)
(if (> n 0) (odd (1- n) t))
(defun odd (n)
(if (> n 0) (even (1- n) nil))
With argtags we get just one entry point. Otherwise, straightforward
transliteration:
(defun even (n)
(argtags nil
(label even n)
(if (> n 0) (goto odd (1- n)) (return t))
(label odd n)
(if (> n 0) (goto even (1- n)) (return nil))))
Kaz Kylheku
> Kaz Kylheku wrote:
> > Anyone have any interesting mutual tail recursion examples? I'd like
> > to try rewriting them using ARGTAGS.
>
> The lower part of http://classes.eclab.byu.edu/330/wiki/index.cgi?FunWithMacros
Good one!
Scheme original.
(define my-a
(lambda (input)
(letrec
((init (lambda (stream)
(or (null? stream)
(case (car stream)
((c) (loop (cdr stream)))))))
(loop (lambda (stream)
(or (null? stream)
(case (car stream)
((a) (loop (cdr stream)))
((d) (loop (cdr stream)))
((r) (end (cdr stream)))
(else #f)))))
(end (lambda (stream)
(or (null? stream)
(case (car stream)
(else #f))))))
(init input))))
Into CL first. In doing so, we blow away a lot of Scheme braindamage
and cut it nearly in half:
(defun my-a (input)
(labels
((init (stream)
(case (first stream)
((c) (loop (rest stream)))))
(loop (stream)
(case (first stream)
((a d) (loop (rest stream)))
((r) (end (rest stream)))))
(end (stream)
(null stream)))
(init input)))
Now the ARGTAGS version:
(defun my-a (stream)
(argtags nil
(label init stream)
(case (first stream)
((c) (goto loop (rest stream))))
(return nil)
(label loop stream)
(case (first stream)
((a d) (goto loop (rest stream)))
((r) (goto end (rest stream))))
(return nil)
(label end stream)
(return (null stream))))
Works fine.
Kaz Kylheku
> Now the ARGTAGS version:
>
> (defun my-a (stream)
> (argtags nil
>
> (label init stream)
> (case (first stream)
> ((c) (goto loop (rest stream))))
> (return nil)
>
> (label loop stream)
> (case (first stream)
> ((a d) (goto loop (rest stream)))
> ((r) (goto end (rest stream))))
> (return nil)
>
> (label end stream)
> (return (null stream))))
I made a new macro called TAILPROG which wraps more syntactic sugar
around all this. Now the above can be written:
(defun my-a (input)
(tailprog (stream)
((init (stream)
(case (first stream)
((c) (goto loop (rest stream)))))
(loop (stream)
(case (first stream)
((a d) (goto loop (rest stream)))
((r) (goto end (rest stream)))))
(end (stream)
(return (null stream))))
(init input)))
The even-odd recursion like this:
(defun even (n)
(tailprog ()
((even (n) (if (> n 0) (odd (1- n)) t))
(odd (n) (if (> n 0) (even (1- n)) nil)))
(even n)))
and ENUMERATE looks like this:
(defun enumerate (start end)
(tailprog (result-list)
((enum (start end result-list)
(if (> start end)
(nreverse result-list)
(enum (1+ start) end (cons start result-list)))))
(enum start end nil)))
TAILPROG is merely:
(defmacro tailprog (let-bindings pseudo-funcs &rest forms)
(let (argtags-forms macrolet-elems)
(dolist (pfunc pseudo-funcs)
(destructuring-bind (name vars &rest forms) pfunc
(push `(label ,name ,@vars) argtags-forms)
(push `(return ,@forms) argtags-forms)
(push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-
elems)))
(nreverse argtags-forms)
(nreverse macrolet-elems)
`(macrolet (,@macrolet-elems)
(let ,let-bindings
(argtags nil
(return (progn ,@forms))
,@argtags-forms)))))
Gene
> Anyone have any interesting mutual tail recursion examples? I'd like
> to try rewriting them using ARGTAGS.
How about implementing a finite state machine e.g. for an input
scanner? There was a recent discussion in comp.programming about
using tail-recursive functions in C to this effect.
Klaus Harbo
...
> TAILPROG is merely:
>
> (defmacro tailprog (let-bindings pseudo-funcs &rest forms)
> (let (argtags-forms macrolet-elems)
> (dolist (pfunc pseudo-funcs)
> (destructuring-bind (name vars &rest forms) pfunc
> (push `(label ,name ,@vars) argtags-forms)
> (push `(return ,@forms) argtags-forms)
> (push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-
> elems)))
> (nreverse argtags-forms)
> (nreverse macrolet-elems)
> `(macrolet (,@macrolet-elems)
> (let ,let-bindings
> (argtags nil
> (return (progn ,@forms))
> ,@argtags-forms)))))
Cute macro. However, TAILPROG relies on NREVERSE not messing up ARGTAGS-FORMS and MACROLET-ELEMS (which it is permitted
to do according to the standard), in LW5.1-beta I get
CL-USER 12 > (let ((list '(1 2 3)))
(values (nreverse list)
list))
(3 2 1)
(1)
CL-USER 13 >
so I changed TAILPROG to
(defmacro tailprog (let-bindings pseudo-funcs &rest forms)
(let (argtags-forms macrolet-elems)
(dolist (pfunc pseudo-funcs)
(destructuring-bind (name vars &rest forms) pfunc
(push `(label ,name ,@vars) argtags-forms)
(push `(return ,@forms) argtags-forms)
(push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-elems)))
`(macrolet ,(reverse macrolet-elems)
(let ,let-bindings
(argtags nil
(return (progn ,@forms))
,@(reverse argtags-forms))))))
instead -- that seems to work.
-Klaus.
Marco Antoniotti
Standard practice here and elsewhere. You just use LABELS and let the
compiler do the optimizing (if it implements it).
Cheers
--
Marco
Kaz Kylheku
> Cute macro. However, TAILPROG relies on NREVERSE not messing up ARGTAGS-FORMS and MACROLET-ELEMS (which it is permitted
> to do according to the standard), in LW5.1-beta I get
>
> CL-USER 12 > (let ((list '(1 2 3)))
> (values (nreverse list)
> list))
Yes of course. NREVERSE can rearrange the CONS structure without
moving around the CAR fields.
Of course, I intended this:
(setf argtags-forms (nreverse argtags-forms))
my Lisp just let me get away without the SETF, because it implements
reversal by reshuffling CAR's.
> `(macrolet ,(reverse macrolet-elems)
> (let ,let-bindings
> (argtags nil
> (return (progn ,@forms))
> ,@(reverse argtags-forms))))))
>
> instead -- that seems to work.
NREVERSE should also work here. But then if I'm going to obsess over
consing in REVERSE, then to be consistent I should also be using ,.
rather than ,@ for instances of splicing not in a tail position.
Gene
Right! That was the point of the discussion in comp.programming.
There was some acrimonious insistance that tail-recursive
implementation of a DFA is "not practical." But even in (gasp) C
(compiled with gcc) it turned out to be a fine idea, notwithstanding
that it's obvious in lisp.