2 ; by Alex Klinkhamer (:handle grencez)
6 ; You may exploit this code,
7 ; and it may exploit you.
8 ; I am not responsible for either.
10 ;;; The do* macro with tails.
12 (((&body tails-args
) . do-args
)
13 (s-pred . s-cleanup
) . s-proc
)
14 (let ((begin-loop-tag (gensym))
15 (end-loop-tag (gensym))
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
)
28 ;V Find if the tail should be V
29 ;V initialized as something. V
33 (cadr (shiftf ta
(car ta
)))
35 ;V No tail mentioned by user, set /ta/ V
36 ;V as a symbol name and return nil. V
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
) =
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.^
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
=
59 (cons v
(cdr condit
)))
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
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
69 `(,ta
,(if tadef
`(setf (cdr ,ta
) ,a-init-part
)
73 :nconc default-val-setq
:into ilist
75 `(if ,(if (consp condit
) (car condit
) v
)
76 (setq ,ta
(setf (cdr ,ta
) (cons ,v nil
))
80 `(,ta
(setf (cdr ,ta
) (cons ,v nil
)))
82 :finally
(setq pre-inits vlist
84 s-conditail-setqs condlist
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.
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.
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.
114 ;V Loop is over, run user's cleanup forms.V