comparison lisp/emacs-lisp/cl-macs.el @ 111405:942097a71997

Silence cl-macs.el compilation. * lisp/emacs-lisp/cl-macs.el (loop): Give local variable args a prefix. (cl-parse-loop-clause, cl-loop-handle-accum): Update for above change.

111404:b8abad9fb36c

    (list 'cl-block-throw (list 'quote name2) result)))


;;; The "loop" macro.

(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
(defvar loop-result) (defvar loop-result-explicit)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)

;;;###autoload
(defmacro loop (&rest args)
  "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,

  unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
  do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
  finally return EXPR, named NAME.

\(fn CLAUSE...)"
  (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
	  (push `((,loop-finish-flag t)) loop-bindings))
      (if loop-first-flag
	  (progn (push `((,loop-first-flag t)) loop-bindings)
		 (push `(setq ,loop-first-flag nil) loop-steps)))

	      (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 (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 (pop args)))

     ((eq word 'initially)
      (if (memq (car args) '(do doing)) (pop args))
      (or (consp (car args)) (error "Syntax error on `initially' clause"))
      (while (consp (car args))
	(push (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)) (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 (pop args)) '(quote nil)))
	  (while (consp (car args))
	    (push (pop args) loop-finally)))))

     ((memq word '(for as))
      (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
	    (ands nil))
	(while
	    ;; Use `gensym' rather than `make-symbol'.  It's important that
	    ;; (not (eq (symbol-name var1) (symbol-name var2))) because
	    ;; these vars get added to the cl-macro-environment.
	    (let ((var (or (pop args) (gensym "--cl-var--"))))
	      (setq word (pop args))
	      (if (eq word 'being) (setq word (pop args)))
	      (if (memq word '(the each)) (setq word (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))
		(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))
				     (make-symbol "--cl-var--")))
		       (step-var (and (not (cl-const-expr-p step))
				      (make-symbol "--cl-var--"))))
		  (and step (numberp step) (<= step 0)

	       ((memq word '(in in-ref on))
		(let* ((on (eq word 'on))
		       (temp (if (and on (symbolp var))
				 var (make-symbol "--cl-var--"))))
		  (push (list temp (pop args)) loop-for-bindings)
		  (push (list 'consp temp) loop-body)
		  (if (eq word 'in-ref)
		      (push (list var (list 'car temp)) loop-symbol-macs)
		    (or (eq temp var)
			(progn
			  (push (list var nil) loop-for-bindings)
			  (push (list var (if on temp (list 'car temp)))
				loop-for-sets))))
		  (push (list temp
			      (if (eq (car args) 'by)
				  (let ((step (cl-pop2 args)))
				    (if (and (memq (car-safe step)
						   '(quote function
							   function*))
					     (symbolp (nth 1 step)))
					(list (nth 1 step) temp)
				      (list 'funcall step temp)))
				(list 'cdr temp)))
			loop-for-steps)))

	       ((eq word '=)
		(let* ((start (pop args))
		       (then (if (eq (car args) 'then) (cl-pop2 args) start)))
		  (push (list var nil) loop-for-bindings)
		  (if (or ands (eq (car args) 'and))
		      (progn
			(push `(,var
				(if ,(or loop-first-flag
					 (setq loop-first-flag
					       (make-symbol "--cl-var--")))

			  loop-for-sets))))

	       ((memq word '(across across-ref))
		(let ((temp-vec (make-symbol "--cl-vec--"))
		      (temp-idx (make-symbol "--cl-idx--")))
		  (push (list temp-vec (pop args)) loop-for-bindings)
		  (push (list temp-idx -1) loop-for-bindings)
		  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
			      (list 'length temp-vec)) loop-body)
		  (if (eq word 'across-ref)
		      (push (list var (list 'aref temp-vec temp-idx))

		    (push (list var nil) loop-for-bindings)
		    (push (list var (list 'aref temp-vec temp-idx))
			  loop-for-sets))))

	       ((memq word '(element elements))
		(let ((ref (or (memq (car args) '(in-ref of-ref))
			       (and (not (memq (car args) '(in of)))
				    (error "Expected `of'"))))
		      (seq (cl-pop2 args))
		      (temp-seq (make-symbol "--cl-seq--"))
		      (temp-idx (if (eq (car args) 'using)
				    (if (and (= (length (cadr args)) 2)
					     (eq (caadr args) 'index))
					(cadr (cl-pop2 args))
				      (error "Bad `using' clause"))
				  (make-symbol "--cl-idx--"))))
		  (push (list temp-seq seq) loop-for-bindings)
		  (push (list temp-idx 0) loop-for-bindings)
		  (if ref

			  loop-for-sets))
		  (push (list temp-idx (list '1+ temp-idx))
			loop-for-steps)))

	       ((memq word hash-types)
		(or (memq (car args) '(in of)) (error "Expected `of'"))
		(let* ((table (cl-pop2 args))
		       (other (if (eq (car args) 'using)
				  (if (and (= (length (cadr args)) 2)
					   (memq (caadr args) hash-types)
					   (not (eq (caadr args) word)))
				      (cadr (cl-pop2 args))
				    (error "Bad `using' clause"))
				(make-symbol "--cl-var--"))))
		  (if (memq word '(hash-value hash-values))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
			`(maphash (lambda (,var ,other) . --cl-map) ,table))))

	       ((memq word '(symbol present-symbol external-symbol
			     symbols present-symbols external-symbols))
		(let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
		  (setq loop-map-form
			`(mapatoms (lambda (,var) . --cl-map) ,ob))))

	       ((memq word '(overlay overlays extent extents))
		(let ((buf nil) (from nil) (to nil))
		  (while (memq (car args) '(in of from to))
		    (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
			  ((eq (car args) 'to) (setq to (cl-pop2 args)))
			  (t (setq buf (cl-pop2 args)))))
		  (setq loop-map-form
			`(cl-map-extents
			  (lambda (,var ,(make-symbol "--cl-var--"))
			    (progn . --cl-map) nil)
			  ,buf ,from ,to))))

	       ((memq word '(interval intervals))
		(let ((buf nil) (prop nil) (from nil) (to nil)
		      (var1 (make-symbol "--cl-var1--"))
		      (var2 (make-symbol "--cl-var2--")))
		  (while (memq (car args) '(in of property from to))
		    (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
			  ((eq (car args) 'to) (setq to (cl-pop2 args)))
			  ((eq (car args) 'property)
			   (setq prop (cl-pop2 args)))
			  (t (setq buf (cl-pop2 args)))))
		  (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
		      (setq var1 (car var) var2 (cdr var))
		    (push (list var (list 'cons var1 var2)) loop-for-sets))
		  (setq loop-map-form
			`(cl-map-intervals
			  (lambda (,var1 ,var2) . --cl-map)
			  ,buf ,prop ,from ,to))))

	       ((memq word key-types)
		(or (memq (car args) '(in of)) (error "Expected `of'"))
		(let ((map (cl-pop2 args))
		      (other (if (eq (car args) 'using)
				 (if (and (= (length (cadr args)) 2)
					  (memq (caadr args) key-types)
					  (not (eq (caadr args) word)))
				     (cadr (cl-pop2 args))
				   (error "Bad `using' clause"))
			       (make-symbol "--cl-var--"))))
		  (if (memq word '(key-binding key-bindings))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form

			loop-body)
		  (push (list var (list 'next-frame var))
			loop-for-steps)))

	       ((memq word '(window windows))
		(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
		      (temp (make-symbol "--cl-var--")))
		  (push (list var (if scr
				      (list 'frame-selected-window scr)
				    '(selected-window)))
			loop-for-bindings)

		(let ((handler (and (symbolp word)
				    (get word 'cl-loop-for-handler))))
		  (if handler
		      (funcall handler var)
		    (error "Expected a `for' preposition, found %s" word)))))
	      (eq (car args) 'and))
	  (setq ands t)
	  (pop args))
	(if (and ands loop-for-bindings)
	    (push (nreverse loop-for-bindings) loop-bindings)
	  (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
				     loop-bindings)))
	(if loop-for-sets

			(apply 'append (nreverse loop-for-steps)))
		  loop-steps))))

     ((eq word 'repeat)
      (let ((temp (make-symbol "--cl-var--")))
	(push (list (list temp (pop args))) loop-bindings)
	(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))

     ((memq word '(collect collecting))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum nil 'nreverse)))
	(if (eq var loop-accum-var)
	    (push (list 'progn (list 'push what var) t) loop-body)
	  (push (list 'progn
		      (list 'setq var (list 'nconc var (list 'list what)))
		      t) loop-body))))

     ((memq word '(nconc nconcing append appending))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum nil 'nreverse)))
	(push (list 'progn
		    (list 'setq var
			  (if (eq var loop-accum-var)
			      (list 'nconc

			    (list (if (memq word '(nconc nconcing))
				      'nconc 'append)
				  var what))) t) loop-body)))

     ((memq word '(concat concating))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum "")))
	(push (list 'progn (list 'callf 'concat var what) t) loop-body)))

     ((memq word '(vconcat vconcating))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum [])))
	(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))

     ((memq word '(sum summing))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum 0)))
	(push (list 'progn (list 'incf var what) t) loop-body)))

     ((memq word '(count counting))
      (let ((what (pop args))
	    (var (cl-loop-handle-accum 0)))
	(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))

     ((memq word '(minimize minimizing maximize maximizing))
      (let* ((what (pop args))
	     (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
	     (var (cl-loop-handle-accum nil))
	     (func (intern (substring (symbol-name word) 0 3)))
	     (set (list 'setq var (list 'if var (list func var temp) temp))))
	(push (list 'progn (if (eq temp what) set
			     (list 'let (list (list temp what)) set))
		    t) loop-body)))

     ((eq word 'with)
      (let ((bindings nil))
	(while (progn (push (list (pop args)
				  (and (eq (car args) '=) (cl-pop2 args)))
			    bindings)
		      (eq (car args) 'and))
	  (pop args))
	(push (nreverse bindings) loop-bindings)))

     ((eq word 'while)
      (push (pop args) loop-body))

     ((eq word 'until)
      (push (list 'not (pop args)) loop-body))

     ((eq word 'always)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (push (list 'setq loop-finish-flag (pop args)) loop-body)
      (setq loop-result t))

     ((eq word 'never)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (push (list 'setq loop-finish-flag (list 'not (pop args)))
	    loop-body)
      (setq loop-result t))

     ((eq word 'thereis)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
      (push (list 'setq loop-finish-flag
		  (list 'not (list 'setq loop-result-var (pop args))))
	    loop-body))

     ((memq word '(if when unless))
      (let* ((cond (pop args))
	     (then (let ((loop-body nil))
		     (cl-parse-loop-clause)
		     (cl-loop-build-ands (nreverse loop-body))))
	     (else (let ((loop-body nil))
		     (if (eq (car args) 'else)
			 (progn (pop args) (cl-parse-loop-clause)))
		     (cl-loop-build-ands (nreverse loop-body))))
	     (simple (and (eq (car then) t) (eq (car else) t))))
	(if (eq (car args) 'end) (pop args))
	(if (eq word 'unless) (setq then (prog1 else (setq else then))))
	(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
			  (if simple (nth 1 else) (list (nth 2 else))))))
	  (if (cl-expr-contains form 'it)
	      (let ((temp (make-symbol "--cl-var--")))

	    (setq form (list* 'if cond form)))
	  (push (if simple (list 'progn form t) form) loop-body))))

     ((memq word '(do doing))
      (let ((body nil))
	(or (consp (car args)) (error "Syntax error on `do' clause"))
	(while (consp (car args)) (push (pop args) body))
	(push (cons 'progn (nreverse (cons t body))) loop-body)))

     ((eq word 'return)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
      (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
      (push (list 'setq loop-result-var (pop args)
		  loop-finish-flag nil) loop-body))

     (t
      (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
	(or handler (error "Expected a loop keyword, found %s" word))
	(funcall handler))))
    (if (eq (car args) 'and)
	(progn (pop args) (cl-parse-loop-clause)))))

(defun cl-loop-let (specs body par)   ; uses loop-*
  (let ((p specs) (temps nil) (new nil))
    (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
      (setq p (cdr p)))

	(let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
	  (if temps (list 'let* (nreverse temps) set) set))
      (list* (if par 'let 'let*)
	     (nconc (nreverse temps) (nreverse new)) body))))

(defun cl-loop-handle-accum (def &optional func)   ; uses args, loop-*
  (if (eq (car args) 'into)
      (let ((var (cl-pop2 args)))
	(or (memq var loop-accum-vars)
	    (progn (push (list (list var def)) loop-bindings)
		   (push var loop-accum-vars)))
	var)
    (or loop-accum-var

;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here

111405:942097a71997

    (list 'cl-block-throw (list 'quote name2) result)))


;;; The "loop" macro.

(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
(defvar loop-result) (defvar loop-result-explicit)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)

;;;###autoload
(defmacro loop (&rest loop-args)
  "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,

  unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
  do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
  finally return EXPR, named NAME.

\(fn CLAUSE...)"
  (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
      (list 'block nil (list* 'while t loop-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 loop-args (append loop-args '(cl-end-loop)))
      (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
      (if loop-finish-flag
	  (push `((,loop-finish-flag t)) loop-bindings))
      (if loop-first-flag
	  (progn (push `((,loop-first-flag t)) loop-bindings)
		 (push `(setq ,loop-first-flag nil) loop-steps)))

	      (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 loop-*
  (let ((word (pop loop-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 loop-args)
      (error "Malformed `loop' macro"))

     ((eq word 'named)
      (setq loop-name (pop loop-args)))

     ((eq word 'initially)
      (if (memq (car loop-args) '(do doing)) (pop loop-args))
      (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
      (while (consp (car loop-args))
	(push (pop loop-args) loop-initially)))

     ((eq word 'finally)
      (if (eq (car loop-args) 'return)
	  (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
	(if (memq (car loop-args) '(do doing)) (pop loop-args))
	(or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
	(if (and (eq (caar loop-args) 'return) (null loop-name))
	    (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
	  (while (consp (car loop-args))
	    (push (pop loop-args) loop-finally)))))

     ((memq word '(for as))
      (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
	    (ands nil))
	(while
	    ;; Use `gensym' rather than `make-symbol'.  It's important that
	    ;; (not (eq (symbol-name var1) (symbol-name var2))) because
	    ;; these vars get added to the cl-macro-environment.
	    (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
	      (setq word (pop loop-args))
	      (if (eq word 'being) (setq word (pop loop-args)))
	      (if (memq word '(the each)) (setq word (pop loop-args)))
	      (if (memq word '(buffer buffers))
		  (setq word 'in loop-args (cons '(buffer-list) loop-args)))
	      (cond

	       ((memq word '(from downfrom upfrom to downto upto
			     above below by))
		(push word loop-args)
		(if (memq (car loop-args) '(downto above))
		    (error "Must specify `from' value for downward loop"))
		(let* ((down (or (eq (car loop-args) 'downfrom)
				 (memq (caddr loop-args) '(downto above))))
		       (excl (or (memq (car loop-args) '(above below))
				 (memq (caddr loop-args) '(above below))))
		       (start (and (memq (car loop-args) '(from upfrom downfrom))
				   (cl-pop2 loop-args)))
		       (end (and (memq (car loop-args)
				       '(to upto downto above below))
				 (cl-pop2 loop-args)))
		       (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
		       (end-var (and (not (cl-const-expr-p end))
				     (make-symbol "--cl-var--")))
		       (step-var (and (not (cl-const-expr-p step))
				      (make-symbol "--cl-var--"))))
		  (and step (numberp step) (<= step 0)

	       ((memq word '(in in-ref on))
		(let* ((on (eq word 'on))
		       (temp (if (and on (symbolp var))
				 var (make-symbol "--cl-var--"))))
		  (push (list temp (pop loop-args)) loop-for-bindings)
		  (push (list 'consp temp) loop-body)
		  (if (eq word 'in-ref)
		      (push (list var (list 'car temp)) loop-symbol-macs)
		    (or (eq temp var)
			(progn
			  (push (list var nil) loop-for-bindings)
			  (push (list var (if on temp (list 'car temp)))
				loop-for-sets))))
		  (push (list temp
			      (if (eq (car loop-args) 'by)
				  (let ((step (cl-pop2 loop-args)))
				    (if (and (memq (car-safe step)
						   '(quote function
							   function*))
					     (symbolp (nth 1 step)))
					(list (nth 1 step) temp)
				      (list 'funcall step temp)))
				(list 'cdr temp)))
			loop-for-steps)))

	       ((eq word '=)
		(let* ((start (pop loop-args))
		       (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
		  (push (list var nil) loop-for-bindings)
		  (if (or ands (eq (car loop-args) 'and))
		      (progn
			(push `(,var
				(if ,(or loop-first-flag
					 (setq loop-first-flag
					       (make-symbol "--cl-var--")))

			  loop-for-sets))))

	       ((memq word '(across across-ref))
		(let ((temp-vec (make-symbol "--cl-vec--"))
		      (temp-idx (make-symbol "--cl-idx--")))
		  (push (list temp-vec (pop loop-args)) loop-for-bindings)
		  (push (list temp-idx -1) loop-for-bindings)
		  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
			      (list 'length temp-vec)) loop-body)
		  (if (eq word 'across-ref)
		      (push (list var (list 'aref temp-vec temp-idx))

		    (push (list var nil) loop-for-bindings)
		    (push (list var (list 'aref temp-vec temp-idx))
			  loop-for-sets))))

	       ((memq word '(element elements))
		(let ((ref (or (memq (car loop-args) '(in-ref of-ref))
			       (and (not (memq (car loop-args) '(in of)))
				    (error "Expected `of'"))))
		      (seq (cl-pop2 loop-args))
		      (temp-seq (make-symbol "--cl-seq--"))
		      (temp-idx (if (eq (car loop-args) 'using)
				    (if (and (= (length (cadr loop-args)) 2)
					     (eq (caadr loop-args) 'index))
					(cadr (cl-pop2 loop-args))
				      (error "Bad `using' clause"))
				  (make-symbol "--cl-idx--"))))
		  (push (list temp-seq seq) loop-for-bindings)
		  (push (list temp-idx 0) loop-for-bindings)
		  (if ref

			  loop-for-sets))
		  (push (list temp-idx (list '1+ temp-idx))
			loop-for-steps)))

	       ((memq word hash-types)
		(or (memq (car loop-args) '(in of)) (error "Expected `of'"))
		(let* ((table (cl-pop2 loop-args))
		       (other (if (eq (car loop-args) 'using)
				  (if (and (= (length (cadr loop-args)) 2)
					   (memq (caadr loop-args) hash-types)
					   (not (eq (caadr loop-args) word)))
				      (cadr (cl-pop2 loop-args))
				    (error "Bad `using' clause"))
				(make-symbol "--cl-var--"))))
		  (if (memq word '(hash-value hash-values))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
			`(maphash (lambda (,var ,other) . --cl-map) ,table))))

	       ((memq word '(symbol present-symbol external-symbol
			     symbols present-symbols external-symbols))
		(let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
		  (setq loop-map-form
			`(mapatoms (lambda (,var) . --cl-map) ,ob))))

	       ((memq word '(overlay overlays extent extents))
		(let ((buf nil) (from nil) (to nil))
		  (while (memq (car loop-args) '(in of from to))
		    (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
			  ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
			  (t (setq buf (cl-pop2 loop-args)))))
		  (setq loop-map-form
			`(cl-map-extents
			  (lambda (,var ,(make-symbol "--cl-var--"))
			    (progn . --cl-map) nil)
			  ,buf ,from ,to))))

	       ((memq word '(interval intervals))
		(let ((buf nil) (prop nil) (from nil) (to nil)
		      (var1 (make-symbol "--cl-var1--"))
		      (var2 (make-symbol "--cl-var2--")))
		  (while (memq (car loop-args) '(in of property from to))
		    (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
			  ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
			  ((eq (car loop-args) 'property)
			   (setq prop (cl-pop2 loop-args)))
			  (t (setq buf (cl-pop2 loop-args)))))
		  (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
		      (setq var1 (car var) var2 (cdr var))
		    (push (list var (list 'cons var1 var2)) loop-for-sets))
		  (setq loop-map-form
			`(cl-map-intervals
			  (lambda (,var1 ,var2) . --cl-map)
			  ,buf ,prop ,from ,to))))

	       ((memq word key-types)
		(or (memq (car loop-args) '(in of)) (error "Expected `of'"))
		(let ((map (cl-pop2 loop-args))
		      (other (if (eq (car loop-args) 'using)
				 (if (and (= (length (cadr loop-args)) 2)
					  (memq (caadr loop-args) key-types)
					  (not (eq (caadr loop-args) word)))
				     (cadr (cl-pop2 loop-args))
				   (error "Bad `using' clause"))
			       (make-symbol "--cl-var--"))))
		  (if (memq word '(key-binding key-bindings))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form

			loop-body)
		  (push (list var (list 'next-frame var))
			loop-for-steps)))

	       ((memq word '(window windows))
		(let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
		      (temp (make-symbol "--cl-var--")))
		  (push (list var (if scr
				      (list 'frame-selected-window scr)
				    '(selected-window)))
			loop-for-bindings)

		(let ((handler (and (symbolp word)
				    (get word 'cl-loop-for-handler))))
		  (if handler
		      (funcall handler var)
		    (error "Expected a `for' preposition, found %s" word)))))
	      (eq (car loop-args) 'and))
	  (setq ands t)
	  (pop loop-args))
	(if (and ands loop-for-bindings)
	    (push (nreverse loop-for-bindings) loop-bindings)
	  (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
				     loop-bindings)))
	(if loop-for-sets

			(apply 'append (nreverse loop-for-steps)))
		  loop-steps))))

     ((eq word 'repeat)
      (let ((temp (make-symbol "--cl-var--")))
	(push (list (list temp (pop loop-args))) loop-bindings)
	(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))

     ((memq word '(collect collecting))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum nil 'nreverse)))
	(if (eq var loop-accum-var)
	    (push (list 'progn (list 'push what var) t) loop-body)
	  (push (list 'progn
		      (list 'setq var (list 'nconc var (list 'list what)))
		      t) loop-body))))

     ((memq word '(nconc nconcing append appending))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum nil 'nreverse)))
	(push (list 'progn
		    (list 'setq var
			  (if (eq var loop-accum-var)
			      (list 'nconc

			    (list (if (memq word '(nconc nconcing))
				      'nconc 'append)
				  var what))) t) loop-body)))

     ((memq word '(concat concating))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum "")))
	(push (list 'progn (list 'callf 'concat var what) t) loop-body)))

     ((memq word '(vconcat vconcating))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum [])))
	(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))

     ((memq word '(sum summing))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum 0)))
	(push (list 'progn (list 'incf var what) t) loop-body)))

     ((memq word '(count counting))
      (let ((what (pop loop-args))
	    (var (cl-loop-handle-accum 0)))
	(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))

     ((memq word '(minimize minimizing maximize maximizing))
      (let* ((what (pop loop-args))
	     (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
	     (var (cl-loop-handle-accum nil))
	     (func (intern (substring (symbol-name word) 0 3)))
	     (set (list 'setq var (list 'if var (list func var temp) temp))))
	(push (list 'progn (if (eq temp what) set
			     (list 'let (list (list temp what)) set))
		    t) loop-body)))

     ((eq word 'with)
      (let ((bindings nil))
	(while (progn (push (list (pop loop-args)
				  (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
			    bindings)
		      (eq (car loop-args) 'and))
	  (pop loop-args))
	(push (nreverse bindings) loop-bindings)))

     ((eq word 'while)
      (push (pop loop-args) loop-body))

     ((eq word 'until)
      (push (list 'not (pop loop-args)) loop-body))

     ((eq word 'always)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (push (list 'setq loop-finish-flag (pop loop-args)) loop-body)
      (setq loop-result t))

     ((eq word 'never)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (push (list 'setq loop-finish-flag (list 'not (pop loop-args)))
	    loop-body)
      (setq loop-result t))

     ((eq word 'thereis)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
      (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
      (push (list 'setq loop-finish-flag
		  (list 'not (list 'setq loop-result-var (pop loop-args))))
	    loop-body))

     ((memq word '(if when unless))
      (let* ((cond (pop loop-args))
	     (then (let ((loop-body nil))
		     (cl-parse-loop-clause)
		     (cl-loop-build-ands (nreverse loop-body))))
	     (else (let ((loop-body nil))
		     (if (eq (car loop-args) 'else)
			 (progn (pop loop-args) (cl-parse-loop-clause)))
		     (cl-loop-build-ands (nreverse loop-body))))
	     (simple (and (eq (car then) t) (eq (car else) t))))
	(if (eq (car loop-args) 'end) (pop loop-args))
	(if (eq word 'unless) (setq then (prog1 else (setq else then))))
	(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
			  (if simple (nth 1 else) (list (nth 2 else))))))
	  (if (cl-expr-contains form 'it)
	      (let ((temp (make-symbol "--cl-var--")))

	    (setq form (list* 'if cond form)))
	  (push (if simple (list 'progn form t) form) loop-body))))

     ((memq word '(do doing))
      (let ((body nil))
	(or (consp (car loop-args)) (error "Syntax error on `do' clause"))
	(while (consp (car loop-args)) (push (pop loop-args) body))
	(push (cons 'progn (nreverse (cons t body))) loop-body)))

     ((eq word 'return)
      (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
      (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
      (push (list 'setq loop-result-var (pop loop-args)
		  loop-finish-flag nil) loop-body))

     (t
      (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
	(or handler (error "Expected a loop keyword, found %s" word))
	(funcall handler))))
    (if (eq (car loop-args) 'and)
	(progn (pop loop-args) (cl-parse-loop-clause)))))

(defun cl-loop-let (specs body par)   ; uses loop-*
  (let ((p specs) (temps nil) (new nil))
    (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
      (setq p (cdr p)))

	(let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
	  (if temps (list 'let* (nreverse temps) set) set))
      (list* (if par 'let 'let*)
	     (nconc (nreverse temps) (nreverse new)) body))))

(defun cl-loop-handle-accum (def &optional func)   ; uses loop-*
  (if (eq (car loop-args) 'into)
      (let ((var (cl-pop2 loop-args)))
	(or (memq var loop-accum-vars)
	    (progn (push (list (list var def)) loop-bindings)
		   (push var loop-accum-vars)))
	var)
    (or loop-accum-var

;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

;;; cl-macs.el ends here