src/util/tails-do.lisp

   1
   2 ; by Alex Klinkhamer  (:handle grencez)
   3 ; Update: 2008.07.19
   4 ;
   5 ;  Legal info:
   6 ; You may exploit this code,
   7 ;    and it may exploit you.
   8 ; I am not responsible for either.
   9
  10 ;;; The do* macro with tails.
  11 (defmacro tails-do*
  12   (((&body tails-args) . do-args)
  13    (s-pred . s-cleanup) . s-proc)
  14   (let ((begin-loop-tag (gensym))
  15         (end-loop-tag (gensym))
  16         pre-inits post-inits
  17         do-setqs tail-setqs
  18         s-conditail-setqs
  19         s-declarations
  20         var-init-p)
  21     (loop
  22       :for (v a ta condit) :in tails-args
  23       ;V See if /v/ has an initial value.V
  24       :for init-v = (when (consp v)
  25                       (setq var-init-p t)
  26                       (prog1 (cadr v)
  27                         (setq v (car v))))
  28       ;V Find if the tail should be V
  29       ;V initialized as something.  V
  30       :for tadef =
  31       (if ta
  32         (if (consp ta)
  33           (cadr (shiftf ta (car ta)))
  34           (if a nil ta))
  35         ;V No tail mentioned by user, set /ta/ V
  36         ;V as a symbol name and return nil.    V
  37         (shiftf ta (gensym)))
  38       ;> /ta/ is now strictly the variable name referring to the
  39       ;> accum-list's tail. There is always a tail at this point.
  40       ;V Find what the accum-list is initialized with     V
  41       ;V and what its part of the /post-inits/ looks like.V
  42       :for (adef a-init-part) =
  43       (if (listp a)
  44         (list (when a (cadr (shiftf a (car a))))
  45               ;^ If /a/ is a cons, set it to its symbol  ^
  46               ;^ name and return its initialization form.^
  47               (if tadef `(list ,v)
  48                 `(if ,a (setf (cdr (last ,a)) (cons ,v nil))
  49                    (setq ,a (list ,v)))))
  50         ;V The accum-list does not have an init value,  V
  51         ;V but will be initialized in the beginning let.V
  52         `(nil (setq ,a (cons ,v nil))))
  53       ;> /a/ is now strictly the variable name referring to the
  54       ;> accum-list or nil if the list exists before this macro.
  55       :for default-val-setq =
  56       (when condit
  57         (if (consp condit)
  58           (when (cdr condit)
  59             (cons v (cdr condit)))
  60           (list v nil)))
  61       ;V Collect variables and initializations V
  62       ;V to be used in the outer let form.     V
  63       :collect (if init-v (list v init-v) v) :into vlist
  64       :when a
  65       :collect (if adef (list a adef) a) :into vlist
  66       :collect (if tadef (list ta tadef) ta) :into vlist
  67       ;V The stuff for /post-inits/.V
  68       :nconc
  69       `(,ta ,(if tadef `(setf (cdr ,ta) ,a-init-part)
  70                a-init-part))
  71       :into ilist
  72       :if condit
  73       :nconc default-val-setq :into ilist
  74       :and :collect
  75       `(if ,(if (consp condit) (car condit) v)
  76          (setq ,ta (setf (cdr ,ta) (cons ,v nil))
  77                ,@default-val-setq))
  78       :into condlist
  79       :else :nconc
  80       `(,ta (setf (cdr ,ta) (cons ,v nil)))
  81       :into qlist
  82       :finally (setq pre-inits vlist
  83                      post-inits ilist
  84                      s-conditail-setqs condlist
  85                      tail-setqs qlist))
  86     ;V Handle regular do arguments.V
  87     (loop :for (v i a) :in do-args
  88           :collect (if i (list v i) v) :into vlist
  89           :when a :collect v :into alist
  90           :and :collect a :into alist
  91           :finally (nconc pre-inits vlist)
  92           (setq do-setqs alist))
  93     (loop :while (and (consp (car s-proc))
  94                       (eq 'declare (caar s-proc)))
  95           :collect (pop s-proc) :into decl
  96           :finally (setq s-declarations decl))
  97     `(let* (,@pre-inits);< All variable initializations.
  98        ,@s-declarations
  99        (unless ,s-pred
 100          ;V Run loop contents here only if the first V
 101          ;V value to accumulate is not specified.    V
 102          ,@(unless var-init-p s-proc)
 103          ;V Give all tails a value if they don't have one, V
 104          (setq ,@post-inits);< update some nil lists too.
 105          (tagbody
 106            ,begin-loop-tag
 107            (setq ,@do-setqs);< Normal do-loop updates.
 108            (if ,s-pred (go ,end-loop-tag))
 109            ,@s-proc;< Run inner loop.
 110            ,@s-conditail-setqs;< Conditional tail updates.
 111            (setq ,@tail-setqs);< Update all tails.
 112            (go ,begin-loop-tag)
 113            ,end-loop-tag))
 114        ;V Loop is over, run user's cleanup forms.V
 115        ,@s-cleanup)))
 116