Name:
Anonymous
2007-10-27 17:11
Maintain this:
(defmacro loop (&rest args)
"(loop CLAUSE...): The Common Lisp `loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
always COND, never COND, thereis COND, collect EXPR into VAR,
append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
finally return EXPR, named NAME."
(if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
(list 'block nil (list* 'while t args))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
(loop-result nil) (loop-result-explicit nil)
(loop-result-var nil) (loop-finish-flag nil)
(loop-accum-var nil) (loop-accum-vars nil)
(loop-initially nil) (loop-finally nil)
(loop-map-form nil) (loop-first-flag nil)
(loop-destr-temps nil) (loop-symbol-macs nil))
(setq args (append args '(cl-end-loop)))
(while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
(if loop-finish-flag
(cl-push (list (list loop-finish-flag t)) loop-bindings))
(if loop-first-flag
(progn (cl-push (list (list loop-first-flag t)) loop-bindings)
(cl-push (list 'setq loop-first-flag nil) loop-steps)))
(let* ((epilogue (nconc (nreverse loop-finally)
(list (or loop-result-explicit loop-result))))
(ands (cl-loop-build-ands (nreverse loop-body)))
(while-body (nconc (cadr ands) (nreverse loop-steps)))
(body (append
(nreverse loop-initially)
(list (if loop-map-form
(list 'block '--cl-finish--
(subst
(if (eq (car ands) t) while-body
(cons (list 'or (car ands)
'(return-from --cl-finish--
nil))
while-body))
'--cl-map loop-map-form))
(list* 'while (car ands) while-body)))
(if loop-finish-flag
(if (equal epilogue '(nil)) (list loop-result-var)
(list (list 'if loop-finish-flag
(cons 'progn epilogue) loop-result-var)))
epilogue))))
(if loop-result-var (cl-push (list loop-result-var) loop-bindings))
(while loop-bindings
(if (cdar loop-bindings)
(setq body (list (cl-loop-let (cl-pop loop-bindings) body t)))
(let ((lets nil))
(while (and loop-bindings
(not (cdar loop-bindings)))
(cl-push (car (cl-pop loop-bindings)) lets))
(setq body (list (cl-loop-let lets body nil))))))
(if loop-symbol-macs
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
(defun cl-parse-loop-clause () ; uses args, loop-*
(let ((word (cl-pop args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
((null args)
(error "Malformed `loop' macro"))
((eq word 'named)
(setq loop-name (cl-pop args)))
((eq word 'initially)
(if (memq (car args) '(do doing)) (cl-pop args))
(or (consp (car args)) (error "Syntax error on `initially' clause"))
(while (consp (car args))
(cl-push (cl-pop args) loop-initially)))
((eq word 'finally)
(if (eq (car args) 'return)
(setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
(if (memq (car args) '(do doing)) (cl-pop args))
(or (consp (car args)) (error "Syntax error on `finally' clause"))
(if (and (eq (caar args) 'return) (null loop-name))
(setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil)))
(while (consp (car args))
(cl-push (cl-pop args) loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
(ands nil))
(while
(let ((var (or (cl-pop args) (gensym))))
(setq word (cl-pop args))
(if (eq word 'being) (setq word (cl-pop args)))
(if (memq word '(the each)) (setq word (cl-pop args)))
(if (memq word '(buffer buffers))
(setq word 'in args (cons '(buffer-list) args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
(cl-push word args)
(if (memq (car args) '(downto above))
(error "Must specify `from' value for downward loop"))
(let* ((down (or (eq (car args) 'downfrom)
(memq (caddr args) '(downto above))))
(excl (or (memq (car args) '(above below))
(memq (caddr args) '(above below))))
(start (and (memq (car args) '(from upfrom downfrom))
(cl-pop2 args)))
(end (and (memq (car args)
'(to upto downto above below))
(cl-pop2 args)))
(step (and (eq (car args) 'by) (cl-pop2 args)))
(end-var (and (not (cl-const-expr-p end)) (gensym)))
(step-var (and (not (cl-const-expr-p step))
(gensym))))
(and step (numberp step) (<= step 0)
(error "Loop `by' value is not positive: %s" step))
(cl-push (list var (or start 0)) loop-for-bindings)
(if end-var (cl-push (list end-var end) loop-for-bindings))
(if step-var (cl-push (list step-var step)
loop-for-bindings))
(if end
(cl-push (list
(if down (if excl '> '>=) (if excl '< '<=))
var (or end-var end)) loop-body))
(cl-push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))