tail-recursion to loop

tco.lisp

;;; ref: https://gist.github.com/784338
;;;      http://d.hatena.ne.jp/athos/20110119/p1

(defmacro w/uniq (names &body body)
  (let ((binds (mapcar #'(lambda (s) `(,s (make-symbol ,(symbol-name s))))
		       (if (consp names) names (list names)))))
    `(let ,binds ,@body)))

(defmacro defun-tc (name arglist . body)
  (when (find-if (lambda (s) (find s '(&key &allow-other-keys &aux))) arglist)
    (error "unsupported arglist form: ~S" arglist))
  (w/uniq (main 1st cont args passed result)
    `(defun ,name ,arglist
       (let ((,1st t) (,cont (make-symbol "continue")))
	 (labels ((,main ,arglist ,@body)
		  (,name (&rest ,args)
		    (if ,1st
			(progn
			  (setq ,1st nil)
			  (loop
			    (multiple-value-bind (,result ,passed) (apply #',main ,args)
			      (if (eq ,result ,cont)
				  (setq ,args ,passed)
				(progn
				  (setq ,1st t)
				  (return ,result))))))
		      (values ,cont ,args))))
	   ,(if (find '&rest arglist)
		`(apply #',name ,@(remove '&rest arglist))
	      `(,name ,@(mapcar #'(lambda (a) (if (consp a) (car a) a))
				(remove '&optional arglist)))))))))

#|
(compile
 (defun-tc sum-tc (n &optional (acc 0))
   (if (= n 0) acc
     (sum-tc (1- n) (+ n acc)))))

(sum-tc 1000000)
; -> 500000500000
|#

on xyzzy
> (time (sum-tc 1000000))
3688 msec
500000500000