diff options
Diffstat (limited to 'tail-recursion.lisp')
| -rw-r--r-- | tail-recursion.lisp | 103 |
1 files changed, 49 insertions, 54 deletions
diff --git a/tail-recursion.lisp b/tail-recursion.lisp index b963d49..cca24a7 100644 --- a/tail-recursion.lisp +++ b/tail-recursion.lisp @@ -28,24 +28,23 @@ ;;; 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)))) -;;; +;;; (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 @@ -53,41 +52,38 @@ ;;; (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) + (let (labels all-vars forms thunks thunk-gensyms) (dolist (item labels-and-forms) (cond ((symbolp item) @@ -100,10 +96,13 @@ (every #'symbolp (rest (rest item)))) (error "ARGTAGS: bad label syntax ~a in block ~a" item block-name)) (destructuring-bind (op label &rest vars) item + (declare (ignore op)) (let ((gensyms (mapcar (lambda (var) (gensym (symbol-name var))) vars)) (thunk-label (gensym (symbol-name label)))) + (dolist (var vars) + (pushnew var all-vars)) (push `(,label ,vars ,gensyms ,thunk-label) labels) (push thunk-label thunks) (push @@ -129,22 +128,21 @@ (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)) + ,@(if args `((psetf ,@(mapcan (lambda (gensym arg) + `(,gensym ,arg)) gensyms args)))) (go ,thunk-label)))))) (block ,block-name - (let (,@thunk-gensyms) + (let (,@thunk-gensyms ,@all-vars) (tagbody ,@(nreverse forms) (return-from ,block-name) ,@(nreverse thunks))))))) - ;;; ;;; TLET ;;; ==== -;;; +;;; ;;; (Thanks to Klaus Harbo for some fixes. to the original version ;;; which was called TAILPROG). ;;; @@ -160,19 +158,16 @@ ;;;; (defmacro tlet (pseudo-funcs &rest forms) - (let (argtags-forms macrolet-elems var-list) + (let (argtags-forms macrolet-elems) (dolist (pfunc pseudo-funcs) (destructuring-bind (name vars &rest forms) pfunc (push `(label ,name ,@vars) argtags-forms) (push `(return (progn ,@forms)) argtags-forms) - (push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-elems) - (dolist (var vars) - (push var var-list)))) + (push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-elems))) `(macrolet ,(reverse macrolet-elems) - (let ,var-list - (argtags nil - (return (progn ,@forms)) - ,@(reverse argtags-forms)))))) + (argtags nil + (return (progn ,@forms)) + ,@(reverse argtags-forms))))) ;;; ;;; DEFTAIL @@ -187,12 +182,12 @@ ;;; ordinary code as an ordinary function call. It distinguishes whether it ;;; was called in this ordinary way, or whether it was called from another ;;; tail block through the tail dispatch loop. -;;; +;;; ;;; The tail call mechanism is hidden behind a function called TAIL-CALL, ;;; whose interface and semantics are similar to FUNCALL. The difference is ;;; that when TAIL-CALL is invoked from a tail block, it causes that tail ;;; block to terminate before the call takes place. -;;; +;;; ;;; The basic idea is that when a tail block (that is implemented as a ;;; function) calls another tail block, it is being permanently exited (goto ;;; semantics, the tail call does not return). Therefore the underlying @@ -208,7 +203,7 @@ ;;; calls the function. When functions mutually recurse, they do so by ;;; bailing out dynamically to a dispatching loop which calls the next ;;; function in the chain. -;;; +;;; ;;; It would be inconvenient to have to use TAIL-CALL everywhere in a tail ;;; block. We can hide the tail call mechanism behind lexical functions, so ;;; that a tail block can use ordinary function call syntax to call its @@ -219,19 +214,19 @@ ;;; arguments have to be specially treated with the use of TAIL-CALL ;;; insteadof FUNCALL. (FUNCALL will work too, of course, but it will ;;; not terminate the tail block and so the call won't be a tail call). -;;; +;;; ;;; A very simple test case illustrates the syntax: DEFTAIL instead of -;;; DEFUN, and an optional (:OTHER-TAILS ...) at the beginning (may +;;; DEFUN, and an optional (:OTHER-TAILS ...) at the beginning (may ;;; be mixed among declarations). -;;; +;;; ;;; (deftail even (num) ;;; (:other-tails odd) ;;; (if (zerop num) t (odd (1- num)))) -;;; +;;; ;;; (deftail odd (num) ;;; (:other-tails even) ;;; (if (zerop num) nil (even (1- num)))) -;;; +;;; ;;; This is still a GOTO-like abstraction, because tail calls are tail ;;; calls even if they are not in a tail position. They never return, ;;; just like in TLET. @@ -255,8 +250,8 @@ (defmacro deftail (name lambda-list &body body) (let ((escape (gensym "ESCAPE-")) (other-tails `(,name)) - (anon-block (gensym)) - (docstring) + (anon-block (gensym)) + (docstring) (decls)) (when (stringp (first body)) (setf docstring (list (first body))) @@ -272,13 +267,13 @@ ,@docstring ,@decls (block ,anon-block - (flet (,@(loop for other in other-tails - collecting `(,other (&rest args) - (return-from ,anon-block - (let ((*tail-escape* ,escape)) - (tail-call #',other args))))) - (tail-call (fun args) - (let ((*tail-escape* ,escape)) - (tail-call fun args)))) - (let ((*tail-escape* nil)) - ,@body)))))) + (flet (,@(loop for other in other-tails + collecting `(,other (&rest args) + (return-from ,anon-block + (let ((*tail-escape* ,escape)) + (tail-call #',other args))))) + (tail-call (fun args) + (let ((*tail-escape* ,escape)) + (tail-call fun args)))) + (let ((*tail-escape* nil)) + ,@body)))))) |