; by Alex Klinkhamer  (:handle grencez)
; Update: 2008.07.19
;
;  Legal info:
; You may exploit this code,
;    and it may exploit you.
; I am not responsible for either.


;;; The do* macro with tails.
(defmacro tails-do*
  (((&body tails-args) . do-args)
   (s-pred . s-cleanup) . s-proc)
  (let ((begin-loop-tag (gensym))
        (end-loop-tag (gensym))
        pre-inits post-inits
        do-setqs tail-setqs
        s-conditail-setqs
        s-declarations
        var-init-p)
    (loop
      :for (v a ta condit) :in tails-args
      ;V See if /v/ has an initial value.V
      :for init-v = (when (consp v)
                      (setq var-init-p t)
                      (prog1 (cadr v)
                        (setq v (car v))))
      ;V Find if the tail should be V
      ;V initialized as something.  V
      :for tadef =
      (if ta
        (if (consp ta)
          (cadr (shiftf ta (car ta)))
          (if a nil ta))
        ;V No tail mentioned by user, set /ta/ V
        ;V as a symbol name and return nil.    V
        (shiftf ta (gensym)))
      ;> /ta/ is now strictly the variable name referring to the
      ;> accum-list's tail. There is always a tail at this point. 
      ;V Find what the accum-list is initialized with     V
      ;V and what its part of the /post-inits/ looks like.V
      :for (adef a-init-part) =
      (if (listp a)
        (list (when a (cadr (shiftf a (car a))))
              ;^ If /a/ is a cons, set it to its symbol  ^
              ;^ name and return its initialization form.^
              (if tadef `(list ,v) 
                `(if ,a (setf (cdr (last ,a)) (cons ,v nil))
                   (setq ,a (list ,v)))))
        ;V The accum-list does not have an init value,  V
        ;V but will be initialized in the beginning let.V
        `(nil (setq ,a (cons ,v nil))))
      ;> /a/ is now strictly the variable name referring to the
      ;> accum-list or nil if the list exists before this macro.
      :for default-val-setq =
      (when condit
        (if (consp condit)
          (when (cdr condit)
            (cons v (cdr condit)))
          (list v nil)))
      ;V Collect variables and initializations V
      ;V to be used in the outer let form.     V
      :collect (if init-v (list v init-v) v) :into vlist
      :when a
      :collect (if adef (list a adef) a) :into vlist
      :collect (if tadef (list ta tadef) ta) :into vlist
      ;V The stuff for /post-inits/.V
      :nconc
      `(,ta ,(if tadef `(setf (cdr ,ta) ,a-init-part)
               a-init-part))
      :into ilist
      :if condit
      :nconc default-val-setq :into ilist
      :and :collect
      `(if ,(if (consp condit) (car condit) v)
         (setq ,ta (setf (cdr ,ta) (cons ,v nil))
               ,@default-val-setq))
      :into condlist
      :else :nconc
      `(,ta (setf (cdr ,ta) (cons ,v nil)))
      :into qlist
      :finally (setq pre-inits vlist
                     post-inits ilist
                     s-conditail-setqs condlist
                     tail-setqs qlist))
    ;V Handle regular do arguments.V
    (loop :for (v i a) :in do-args
          :collect (if i (list v i) v) :into vlist
          :when a :collect v :into alist
          :and :collect a :into alist
          :finally (nconc pre-inits vlist)
          (setq do-setqs alist))
    (loop :while (and (consp (car s-proc))
                      (eq 'declare (caar s-proc)))
          :collect (pop s-proc) :into decl
          :finally (setq s-declarations decl))
    `(let* (,@pre-inits);< All variable initializations.
       ,@s-declarations
       (unless ,s-pred
         ;V Run loop contents here only if the first V
         ;V value to accumulate is not specified.    V
         ,@(unless var-init-p s-proc)
         ;V Give all tails a value if they don't have one, V
         (setq ,@post-inits);< update some nil lists too.
         (tagbody
           ,begin-loop-tag
           (setq ,@do-setqs);< Normal do-loop updates.
           (if ,s-pred (go ,end-loop-tag))
           ,@s-proc;< Run inner loop.
           ,@s-conditail-setqs;< Conditional tail updates.
           (setq ,@tail-setqs);< Update all tails.
           (go ,begin-loop-tag)
           ,end-loop-tag))
       ;V Loop is over, run user's cleanup forms.V
       ,@s-cleanup)))