compile a looping function from a recursive definition

loop-rec.lisp

;;; loop-rec.lisp --- compile a looping function from a recursive definition

;; Copyright (C) 2013  Eric Schulte

;;; Commentary:

;; Use the `defwhile' macro to define a looping (using while) version
;; of any recursive function.
;;
;; It maintains a fifo stack of arguments (my-args), and a pointer to
;; the most recent results (my-res).  Then it goes through the
;; function body replacing every recursive call with code to update
;; the stack, and return the most recent result (my-replacer).  That
;; is wrapped in a whlie loop which terminates when the arguments
;; stack is exhausted.

;;; Code:
(defpackage :loop-rec
  (:use :common-lisp :alexandria :curry-compose-reader-macros))
(in-package :loop-rec)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (enable-curry-compose-reader-macros))

(defmacro push-to-end (item place)
  `(setf ,place (nconc ,place (list ,item))))

(defmacro defwhile (name args body)
  (labels ((rec-replace (from tmp tree)
             (if (listp tree)
                 (if (equal (car tree) from) ; replace recursive call
                     (let ((it (gensym)))
                       `(prog1 :get-res
                          (let ((,it (list ,@(mapcar {rec-replace from tmp}
                                                     (cdr tree)))))
                            (push-to-end ,it ,tmp))))
                     (mapcar {rec-replace from tmp} tree))
                 tree)))
    (let ((my-args     (gensym "args-"))
          (my-res      (gensym "return-"))
          (my-tmp      (gensym "temporary-"))
          (my-replacer (gensym "replacer-")))
      `(defun ,(intern (concatenate 'string (symbol-name name) "-WHILE")) ,args
         (let ((,my-args (list (list ,@args)))
               (,my-res nil))
           (flet ((,my-replacer (it) (if (equalp it :get-res) ,my-res it)))
             (loop :while ,my-args :do
                (destructuring-bind ,args (mapcar #',my-replacer (pop ,my-args))
                  (let ((,my-tmp nil))
                    (setf ,my-res
                          ,@(rec-replace name my-tmp (list body)))
                    (setf ,my-args (append ,my-tmp ,my-args))))))
           ,my-res)))))

(defun    f (x) (if (>= x 101) (- x 10) (f (f (+ x 11))))) ; <- define f
(defwhile f (x) (if (>= x 101) (- x 10) (f (f (+ x 11))))) ; <- non-recursive f

(f 8)                                   ; => 91
(f-while 8)                             ; => 91

(macroexpand-1 '(defwhile f (x) (if (>= x 101) (- x 10) (f (f (+ x 11)))))) ; =>
#+(or )
(DEFUN F-WHILE (X)
  (LET ((#:|args-7989| (LIST (LIST X)))
        (#:|return-7990| NIL))
    (FLET ((#:|replacer-7992| (IT) (IF (EQUALP IT :GET-RES) #:|return-7990| IT)))
      (LOOP :WHILE #:|args-7989| :DO
         (DESTRUCTURING-BIND (X) (MAPCAR #'#:|replacer-7992| (POP #:|args-7989|))
           (LET ((#:|temporary-7991| NIL))
             (SETF #:|return-7990|
                   (IF (>= X 101)
                       (- X 10)
                       (PROG1 :GET-RES
                         (LET ((IT
                                (LIST (PROG1 :GET-RES
                                        (LET ((IT (LIST (+ X 11))))
                                          (PUSH-TO-END IT #:|temporary-7991|))))))
                           (PUSH-TO-END IT #:|temporary-7991|)))))
             (SETF #:|args-7989| (APPEND #:|temporary-7991| #:|args-7989|))))))
    #:|return-7990|))