cl-macs.el 98.4 KB
Newer Older
1
;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3
;; Copyright (C) 1993, 2003, 2004, 2005 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5 6 7 8 9 10 11 12

;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
Karl Heuer's avatar
Karl Heuer committed
13
;; the Free Software Foundation; either version 2, or (at your option)
Richard M. Stallman's avatar
Richard M. Stallman committed
14 15 16 17 18 19 20 21
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
Erik Naggum's avatar
Erik Naggum committed
22 23 24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
25

Richard M. Stallman's avatar
Richard M. Stallman committed
26
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44

;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains the portions of the Common Lisp extensions
;; package which should be autoloaded, but need only be present
;; if the compiler or interpreter is used---this file is not
;; necessary for executing compiled code.

;; See cl.el for Change Log.


Richard M. Stallman's avatar
Richard M. Stallman committed
45
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80

(or (memq 'cl-19 features)
    (error "Tried to load `cl-macs' before `cl'!"))


(defmacro cl-pop2 (place)
  (list 'prog1 (list 'car (list 'cdr place))
	(list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)

(defvar cl-optimize-safety)
(defvar cl-optimize-speed)


;;; This kludge allows macros which use cl-transform-function-property
;;; to be called at compile-time.

(require
 (progn
   (or (fboundp 'cl-transform-function-property)
       (defalias 'cl-transform-function-property
	 (function (lambda (n p f)
		     (list 'put (list 'quote n) (list 'quote p)
			   (list 'function (cons 'lambda f)))))))
   (car (or features (setq features (list 'cl-kludge))))))


;;; Initialization.

(defvar cl-old-bc-file-form nil)

(defun cl-compile-time-init ()
  (run-hooks 'cl-hack-bytecomp-hook))


81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
;;; Some predicates for analyzing Lisp forms.  These are used by various
;;; macro expanders to optimize the results in certain common cases.

(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
			    car-safe cdr-safe progn prog1 prog2))
(defconst cl-safe-funcs '(* / % length memq list vector vectorp
			  < > <= >= = error))

;;; Check if no side effects, and executes quickly.
(defun cl-simple-expr-p (x &optional size)
  (or size (setq size 10))
  (if (and (consp x) (not (memq (car x) '(quote function function*))))
      (and (symbolp (car x))
	   (or (memq (car x) cl-simple-funcs)
	       (get (car x) 'side-effect-free))
	   (progn
	     (setq size (1- size))
	     (while (and (setq x (cdr x))
			 (setq size (cl-simple-expr-p (car x) size))))
	     (and (null x) (>= size 0) size)))
    (and (> size 0) (1- size))))

(defun cl-simple-exprs-p (xs)
  (while (and xs (cl-simple-expr-p (car xs)))
    (setq xs (cdr xs)))
  (not xs))

;;; Check if no side effects.
(defun cl-safe-expr-p (x)
  (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
      (and (symbolp (car x))
	   (or (memq (car x) cl-simple-funcs)
	       (memq (car x) cl-safe-funcs)
	       (get (car x) 'side-effect-free))
	   (progn
	     (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
	     (null x)))))

;;; Check if constant (i.e., no side effects or dependencies).
(defun cl-const-expr-p (x)
  (cond ((consp x)
	 (or (eq (car x) 'quote)
	     (and (memq (car x) '(function function*))
		  (or (symbolp (nth 1 x))
		      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
	((symbolp x) (and (memq x '(nil t)) t))
	(t t)))

(defun cl-const-exprs-p (xs)
  (while (and xs (cl-const-expr-p (car xs)))
    (setq xs (cdr xs)))
  (not xs))

(defun cl-const-expr-val (x)
  (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))

(defun cl-expr-access-order (x v)
  (if (cl-const-expr-p x) v
    (if (consp x)
	(progn
	  (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
	  v)
      (if (eq x (car v)) (cdr v) '(t)))))

;;; Count number of times X refers to Y.  Return nil for 0 times.
(defun cl-expr-contains (x y)
  (cond ((equal y x) 1)
	((and (consp x) (not (memq (car-safe x) '(quote function function*))))
	 (let ((sum 0))
	   (while x
	     (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
	   (and (> sum 0) sum)))
	(t nil)))

(defun cl-expr-contains-any (x y)
  (while (and y (not (cl-expr-contains x (car y)))) (pop y))
  y)

;;; Check whether X may depend on any of the symbols in Y.
(defun cl-expr-depends-p (x y)
  (and (not (cl-const-expr-p x))
       (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))

Richard M. Stallman's avatar
Richard M. Stallman committed
164 165 166
;;; Symbols.

(defvar *gensym-counter*)
167
(defun gensym (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
168 169
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
170 171
  (let ((pfix (if (stringp prefix) prefix "G"))
	(num (if (integerp prefix) prefix
Richard M. Stallman's avatar
Richard M. Stallman committed
172 173
	       (prog1 *gensym-counter*
		 (setq *gensym-counter* (1+ *gensym-counter*))))))
174
    (make-symbol (format "%s%d" pfix num))))
Richard M. Stallman's avatar
Richard M. Stallman committed
175

176
(defun gentemp (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
177 178
  "Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
179
  (let ((pfix (if (stringp prefix) prefix "G"))
Richard M. Stallman's avatar
Richard M. Stallman committed
180
	name)
181
    (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
Richard M. Stallman's avatar
Richard M. Stallman committed
182 183 184 185 186 187 188
      (setq *gensym-counter* (1+ *gensym-counter*)))
    (intern name)))


;;; Program structure.

(defmacro defun* (name args &rest body)
189
  "Define NAME as a function.
Richard M. Stallman's avatar
Richard M. Stallman committed
190
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
191 192 193
and BODY is implicitly surrounded by (block NAME ...).

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
194 195 196 197 198
  (let* ((res (cl-transform-lambda (cons args body) name))
	 (form (list* 'defun name (cdr res))))
    (if (car res) (list 'progn (car res) form) form)))

(defmacro defmacro* (name args &rest body)
199
  "Define NAME as a macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
200
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
201 202 203
and BODY is implicitly surrounded by (block NAME ...).

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
204 205 206 207 208
  (let* ((res (cl-transform-lambda (cons args body) name))
	 (form (list* 'defmacro name (cdr res))))
    (if (car res) (list 'progn (car res) form) form)))

(defmacro function* (func)
209
  "Introduce a function.
210 211
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
Richard M. Stallman's avatar
Richard M. Stallman committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
  (if (eq (car-safe func) 'lambda)
      (let* ((res (cl-transform-lambda (cdr func) 'cl-none))
	     (form (list 'function (cons 'lambda (cdr res)))))
	(if (car res) (list 'progn (car res) form) form))
    (list 'function func)))

(defun cl-transform-function-property (func prop form)
  (let ((res (cl-transform-lambda form func)))
    (append '(progn) (cdr (cdr (car res)))
	    (list (list 'put (list 'quote func) (list 'quote prop)
			(list 'function (cons 'lambda (cdr res))))))))

(defconst lambda-list-keywords
  '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))

(defvar cl-macro-environment nil)
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)

(defun cl-transform-lambda (form bind-block)
232
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
Richard M. Stallman's avatar
Richard M. Stallman committed
233 234 235
	 (bind-defs nil) (bind-enquote nil)
	 (bind-inits nil) (bind-lets nil) (bind-forms nil)
	 (header nil) (simple-args nil))
236 237
    (while (or (stringp (car body))
	       (memq (car-safe (car body)) '(interactive declare)))
238
      (push (pop body) header))
Richard M. Stallman's avatar
Richard M. Stallman committed
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
    (setq args (if (listp args) (copy-list args) (list '&rest args)))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (if (setq bind-defs (cadr (memq '&cl-defs args)))
	(setq args (delq '&cl-defs (delq bind-defs args))
	      bind-defs (cadr bind-defs)))
    (if (setq bind-enquote (memq '&cl-quote args))
	(setq args (delq '&cl-quote args)))
    (if (memq '&whole args) (error "&whole not currently implemented"))
    (let* ((p (memq '&environment args)) (v (cadr p)))
      (if p (setq args (nconc (delq (car p) (delq v args))
			      (list '&aux (list v 'cl-macro-environment))))))
    (while (and args (symbolp (car args))
		(not (memq (car args) '(nil &rest &body &key &aux)))
		(not (and (eq (car args) '&optional)
			  (or bind-defs (consp (cadr args))))))
254
      (push (pop args) simple-args))
Richard M. Stallman's avatar
Richard M. Stallman committed
255 256 257 258
    (or (eq bind-block 'cl-none)
	(setq body (list (list* 'block bind-block body))))
    (if (null args)
	(list* nil (nreverse simple-args) (nconc (nreverse header) body))
259
      (if (memq '&optional simple-args) (push '&optional args))
Richard M. Stallman's avatar
Richard M. Stallman committed
260 261 262 263 264 265
      (cl-do-arglist args nil (- (length simple-args)
				 (if (memq '&optional simple-args) 1 0)))
      (setq bind-lets (nreverse bind-lets))
      (list* (and bind-inits (list* 'eval-when '(compile load eval)
				    (nreverse bind-inits)))
	     (nconc (nreverse simple-args)
266 267
		    (list '&rest (car (pop bind-lets))))
	     (nconc (let ((hdr (nreverse header)))
268
		      (require 'help-fns)
269
		      (cons (help-add-fundoc-usage
270 271 272 273 274 275
			     (if (stringp (car hdr)) (pop hdr))
			     ;; orig-args can contain &cl-defs (an internal CL
			     ;; thingy that I do not understand), so remove it.
			     (let ((x (memq '&cl-defs orig-args)))
			       (if (null x) orig-args
				 (delq (car x) (remq (cadr x) orig-args)))))
276
			    hdr))
Richard M. Stallman's avatar
Richard M. Stallman committed
277 278 279 280 281 282 283
		    (list (nconc (list 'let* bind-lets)
				 (nreverse bind-forms) body)))))))

(defun cl-do-arglist (args expr &optional num)   ; uses bind-*
  (if (nlistp args)
      (if (or (memq args lambda-list-keywords) (not (symbolp args)))
	  (error "Invalid argument name: %s" args)
284
	(push (list args expr) bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
285 286 287 288 289 290 291 292 293 294 295
    (setq args (copy-list args))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (let ((p (memq '&body args))) (if p (setcar p '&rest)))
    (if (memq '&environment args) (error "&environment used incorrectly"))
    (let ((save-args args)
	  (restarg (memq '&rest args))
	  (safety (if (cl-compiling-file) cl-optimize-safety 3))
	  (keys nil)
	  (laterarg nil) (exactarg nil) minarg)
      (or num (setq num 0))
      (if (listp (cadr restarg))
296
	  (setq restarg (make-symbol "--cl-rest--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
297
	(setq restarg (cadr restarg)))
298
      (push (list restarg expr) bind-lets)
Richard M. Stallman's avatar
Richard M. Stallman committed
299
      (if (eq (car args) '&whole)
300
	  (push (list (cl-pop2 args) restarg) bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
301 302 303 304 305 306 307 308 309 310 311 312 313
      (let ((p args))
	(setq minarg restarg)
	(while (and p (not (memq (car p) lambda-list-keywords)))
	  (or (eq p args) (setq minarg (list 'cdr minarg)))
	  (setq p (cdr p)))
	(if (memq (car p) '(nil &aux))
	    (setq minarg (list '= (list 'length restarg)
			       (length (ldiff args p)))
		  exactarg (not (eq args p)))))
      (while (and args (not (memq (car args) lambda-list-keywords)))
	(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
			    restarg)))
	  (cl-do-arglist
314
	   (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
315 316 317 318 319 320 321
	   (if (or laterarg (= safety 0)) poparg
	     (list 'if minarg poparg
		   (list 'signal '(quote wrong-number-of-arguments)
			 (list 'list (and (not (eq bind-block 'cl-none))
					  (list 'quote bind-block))
			       (list 'length restarg)))))))
	(setq num (1+ num) laterarg t))
322
      (while (and (eq (car args) '&optional) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
323
	(while (and args (not (memq (car args) lambda-list-keywords)))
324
	  (let ((arg (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
325 326 327 328 329 330 331 332 333 334 335 336 337 338
	    (or (consp arg) (setq arg (list arg)))
	    (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
	    (let ((def (if (cdr arg) (nth 1 arg)
			 (or (car bind-defs)
			     (nth 1 (assq (car arg) bind-defs)))))
		  (poparg (list 'pop restarg)))
	      (and def bind-enquote (setq def (list 'quote def)))
	      (cl-do-arglist (car arg)
			     (if def (list 'if restarg poparg def) poparg))
	      (setq num (1+ num))))))
      (if (eq (car args) '&rest)
	  (let ((arg (cl-pop2 args)))
	    (if (consp arg) (cl-do-arglist arg restarg)))
	(or (eq (car args) '&key) (= safety 0) exactarg
339
	    (push (list 'if restarg
Richard M. Stallman's avatar
Richard M. Stallman committed
340 341 342 343 344 345
			   (list 'signal '(quote wrong-number-of-arguments)
				 (list 'list
				       (and (not (eq bind-block 'cl-none))
					    (list 'quote bind-block))
				       (list '+ num (list 'length restarg)))))
		     bind-forms)))
346
      (while (and (eq (car args) '&key) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
347
	(while (and args (not (memq (car args) lambda-list-keywords)))
348
	  (let ((arg (pop args)))
349
	    (or (consp arg) (setq arg (list arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
350 351 352 353 354
	    (let* ((karg (if (consp (car arg)) (caar arg)
			   (intern (format ":%s" (car arg)))))
		   (varg (if (consp (car arg)) (cadar arg) (car arg)))
		   (def (if (cdr arg) (cadr arg)
			  (or (car bind-defs) (cadr (assq varg bind-defs)))))
355
		   (look (list 'memq (list 'quote karg) restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
356 357
	      (and def bind-enquote (setq def (list 'quote def)))
	      (if (cddr arg)
358
		  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376
			 (val (list 'car (list 'cdr temp))))
		    (cl-do-arglist temp look)
		    (cl-do-arglist varg
				   (list 'if temp
					 (list 'prog1 val (list 'setq temp t))
					 def)))
		(cl-do-arglist
		 varg
		 (list 'car
		       (list 'cdr
			     (if (null def)
				 look
			       (list 'or look
				     (if (eq (cl-const-expr-p def) t)
					 (list
					  'quote
					  (list nil (cl-const-expr-val def)))
				       (list 'list nil def))))))))
377
	      (push karg keys)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
378
      (setq keys (nreverse keys))
379
      (or (and (eq (car args) '&allow-other-keys) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
380
	  (null keys) (= safety 0)
381
	  (let* ((var (make-symbol "--cl-keys--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
382 383 384 385 386 387 388 389
		 (allow '(:allow-other-keys))
		 (check (list
			 'while var
			 (list
			  'cond
			  (list (list 'memq (list 'car var)
				      (list 'quote (append keys allow)))
				(list 'setq var (list 'cdr (list 'cdr var))))
390 391 392 393
			  (list (list 'car
				      (list 'cdr
					    (list 'memq (cons 'quote allow)
						  restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
394 395 396 397 398 399 400
				(list 'setq var nil))
			  (list t
				(list
				 'error
				 (format "Keyword argument %%s not one of %s"
					 keys)
				 (list 'car var)))))))
401 402
	    (push (list 'let (list (list var restarg)) check) bind-forms)))
      (while (and (eq (car args) '&aux) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
403 404 405 406
	(while (and args (not (memq (car args) lambda-list-keywords)))
	  (if (consp (car args))
	      (if (and bind-enquote (cadar args))
		  (cl-do-arglist (caar args)
407 408 409
				 (list 'quote (cadr (pop args))))
		(cl-do-arglist (caar args) (cadr (pop args))))
	    (cl-do-arglist (pop args) nil))))
Richard M. Stallman's avatar
Richard M. Stallman committed
410 411 412 413 414 415
      (if args (error "Malformed argument list %s" save-args)))))

(defun cl-arglist-args (args)
  (if (nlistp args) (list args)
    (let ((res nil) (kind nil) arg)
      (while (consp args)
416
	(setq arg (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
417
	(if (memq arg lambda-list-keywords) (setq kind arg)
418
	  (if (eq arg '&cl-defs) (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437
	    (and (consp arg) kind (setq arg (car arg)))
	    (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
	    (setq res (nconc res (cl-arglist-args arg))))))
      (nconc res (and args (list args))))))

(defmacro destructuring-bind (args expr &rest body)
  (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
	 (bind-defs nil) (bind-block 'cl-none))
    (cl-do-arglist (or args '(&aux)) expr)
    (append '(progn) bind-inits
	    (list (nconc (list 'let* (nreverse bind-lets))
			 (nreverse bind-forms) body)))))


;;; The `eval-when' form.

(defvar cl-not-toplevel nil)

(defmacro eval-when (when &rest body)
438
  "Control when BODY is evaluated.
Richard M. Stallman's avatar
Richard M. Stallman committed
439 440
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
441 442 443
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.

\(fn (WHEN...) BODY...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
444 445
  (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
	   (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
446
      (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
Richard M. Stallman's avatar
Richard M. Stallman committed
447
	    (cl-not-toplevel t))
448
	(if (or (memq 'load when) (memq :load-toplevel when))
Richard M. Stallman's avatar
Richard M. Stallman committed
449 450 451
	    (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
	      (list* 'if nil nil body))
	  (progn (if comp (eval (cons 'progn body))) nil)))
452
    (and (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
453 454 455 456 457 458 459 460 461 462
	 (cons 'progn body))))

(defun cl-compile-time-too (form)
  (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
      (setq form (macroexpand
		  form (cons '(eval-when) byte-compile-macro-environment))))
  (cond ((eq (car-safe form) 'progn)
	 (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
	((eq (car-safe form) 'eval-when)
	 (let ((when (nth 1 form)))
463
	   (if (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490
	       (list* 'eval-when (cons 'compile when) (cddr form))
	     form)))
	(t (eval form) form)))

(defmacro load-time-value (form &optional read-only)
  "Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
  (if (cl-compiling-file)
      (let* ((temp (gentemp "--cl-load-time--"))
	     (set (list 'set (list 'quote temp) form)))
	(if (and (fboundp 'byte-compile-file-form-defmumble)
		 (boundp 'this-kind) (boundp 'that-one))
	    (fset 'byte-compile-file-form
		  (list 'lambda '(form)
			(list 'fset '(quote byte-compile-file-form)
			      (list 'quote
				    (symbol-function 'byte-compile-file-form)))
			(list 'byte-compile-file-form (list 'quote set))
			'(byte-compile-file-form form)))
	  (print set (symbol-value 'outbuffer)))
	(list 'symbol-value (list 'quote temp)))
    (list 'quote (eval form))))


;;; Conditional control structures.

(defmacro case (expr &rest clauses)
491
  "Eval EXPR and choose among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
492 493 494
Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
If no clause succeeds, case returns nil.  A single atom may be used in
495
place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
Richard M. Stallman's avatar
Richard M. Stallman committed
496
allowed only in the final clause, and matches if no other keys match.
497 498
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
499
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
	 (head-list nil)
	 (body (cons
		'cond
		(mapcar
		 (function
		  (lambda (c)
		    (cons (cond ((memq (car c) '(t otherwise)) t)
				((eq (car c) 'ecase-error-flag)
				 (list 'error "ecase failed: %s, %s"
				       temp (list 'quote (reverse head-list))))
				((listp (car c))
				 (setq head-list (append (car c) head-list))
				 (list 'member* temp (list 'quote (car c))))
				(t
				 (if (memq (car c) head-list)
				     (error "Duplicate key in case: %s"
					    (car c)))
517
				 (push (car c) head-list)
Richard M. Stallman's avatar
Richard M. Stallman committed
518 519 520 521 522 523 524
				 (list 'eql temp (list 'quote (car c)))))
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

(defmacro ecase (expr &rest clauses)
525
  "Like `case', but error if no case fits.
526 527
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
528 529 530
  (list* 'case expr (append clauses '((ecase-error-flag)))))

(defmacro typecase (expr &rest clauses)
531
  "Evals EXPR, chooses among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
532 533
Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
534
typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
535 536
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
537
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
538 539 540 541 542 543 544 545 546 547 548
	 (type-list nil)
	 (body (cons
		'cond
		(mapcar
		 (function
		  (lambda (c)
		    (cons (cond ((eq (car c) 'otherwise) t)
				((eq (car c) 'ecase-error-flag)
				 (list 'error "etypecase failed: %s, %s"
				       temp (list 'quote (reverse type-list))))
				(t
549
				 (push (car c) type-list)
Richard M. Stallman's avatar
Richard M. Stallman committed
550 551 552 553 554 555 556
				 (cl-make-type-test temp (car c))))
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

(defmacro etypecase (expr &rest clauses)
557
  "Like `typecase', but error if no case fits.
558 559
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
560 561 562 563 564 565
  (list* 'typecase expr (append clauses '((ecase-error-flag)))))


;;; Blocks and exits.

(defmacro block (name &rest body)
566
  "Define a lexically-scoped block named NAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
NAME may be any symbol.  Code inside the BODY forms can call `return-from'
to jump prematurely out of the block.  This differs from `catch' and `throw'
in two respects:  First, the NAME is an unevaluated symbol rather than a
quoted symbol or other form; and second, NAME is lexically rather than
dynamically scoped:  Only references to it within BODY will work.  These
references may appear inside macro expansions, but not inside functions
called from BODY."
  (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
    (list 'cl-block-wrapper
	  (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
		 body))))

(defvar cl-active-block-names nil)

(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
(defun cl-byte-compile-block (cl-form)
  (if (fboundp 'byte-compile-form-do-effect)  ; Check for optimizing compiler
      (progn
	(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
	       (cl-active-block-names (cons cl-entry cl-active-block-names))
	       (cl-body (byte-compile-top-level
			 (cons 'progn (cddr (nth 1 cl-form))))))
	  (if (cdr cl-entry)
	      (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
	    (byte-compile-form cl-body))))
    (byte-compile-form (nth 1 cl-form))))

(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
(defun cl-byte-compile-throw (cl-form)
  (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
    (if cl-found (setcdr cl-found t)))
  (byte-compile-normal-call (cons 'throw (cdr cl-form))))

600 601
(defmacro return (&optional result)
  "Return from the block named nil.
Richard M. Stallman's avatar
Richard M. Stallman committed
602
This is equivalent to `(return-from nil RESULT)'."
603
  (list 'return-from nil result))
Richard M. Stallman's avatar
Richard M. Stallman committed
604

605 606
(defmacro return-from (name &optional result)
  "Return from the block named NAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
607 608 609 610 611
This jump out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
  (let ((name2 (intern (format "--cl-block-%s--" name))))
612
    (list 'cl-block-throw (list 'quote name2) result)))
Richard M. Stallman's avatar
Richard M. Stallman committed
613 614 615 616 617 618 619 620 621 622 623 624


;;; 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)

(defmacro loop (&rest args)
625
  "The Common Lisp `loop' macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
626 627 628 629 630 631 632 633 634 635
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,
636 637 638
  finally return EXPR, named NAME.

\(fn CLAUSE...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
639 640 641 642 643 644 645 646 647 648 649 650 651
  (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
652
	  (push `((,loop-finish-flag t)) loop-bindings))
Richard M. Stallman's avatar
Richard M. Stallman committed
653
      (if loop-first-flag
654 655
	  (progn (push `((,loop-first-flag t)) loop-bindings)
		 (push `(setq ,loop-first-flag nil) loop-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
656 657 658 659 660 661 662 663 664 665
      (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
666 667 668
				       (cons `(or ,(car ands)
						  (return-from --cl-finish--
						    nil))
Richard M. Stallman's avatar
Richard M. Stallman committed
669 670 671 672 673
					     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)
674 675
			  `((if ,loop-finish-flag
				(progn ,@epilogue) ,loop-result-var)))
Richard M. Stallman's avatar
Richard M. Stallman committed
676
		      epilogue))))
677
	(if loop-result-var (push (list loop-result-var) loop-bindings))
Richard M. Stallman's avatar
Richard M. Stallman committed
678 679
	(while loop-bindings
	  (if (cdar loop-bindings)
680
	      (setq body (list (cl-loop-let (pop loop-bindings) body t)))
Richard M. Stallman's avatar
Richard M. Stallman committed
681 682 683
	    (let ((lets nil))
	      (while (and loop-bindings
			  (not (cdar loop-bindings)))
684
		(push (car (pop loop-bindings)) lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
685 686 687 688 689
	      (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)))))

690
(defun cl-parse-loop-clause ()		; uses args, loop-*
691
  (let ((word (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
692 693 694 695 696 697 698 699 700
	(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)
701
      (setq loop-name (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
702 703

     ((eq word 'initially)
704
      (if (memq (car args) '(do doing)) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
705 706
      (or (consp (car args)) (error "Syntax error on `initially' clause"))
      (while (consp (car args))
707
	(push (pop args) loop-initially)))
Richard M. Stallman's avatar
Richard M. Stallman committed
708 709 710 711

     ((eq word 'finally)
      (if (eq (car args) 'return)
	  (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
712
	(if (memq (car args) '(do doing)) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
713 714
	(or (consp (car args)) (error "Syntax error on `finally' clause"))
	(if (and (eq (caar args) 'return) (null loop-name))
715
	    (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
Richard M. Stallman's avatar
Richard M. Stallman committed
716
	  (while (consp (car args))
717
	    (push (pop args) loop-finally)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
718 719 720 721 722

     ((memq word '(for as))
      (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
	    (ands nil))
	(while
723 724 725 726
	    ;; 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--"))))
727 728 729
	      (setq word (pop args))
	      (if (eq word 'being) (setq word (pop args)))
	      (if (memq word '(the each)) (setq word (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
730 731 732 733 734 735
	      (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))
736
		(push word args)
Richard M. Stallman's avatar
Richard M. Stallman committed
737 738 739 740 741 742 743 744 745 746 747 748
		(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)))
749 750
		       (end-var (and (not (cl-const-expr-p end))
				     (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
751
		       (step-var (and (not (cl-const-expr-p step))
752
				      (make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
753 754
		  (and step (numberp step) (<= step 0)
		       (error "Loop `by' value is not positive: %s" step))
755 756 757
		  (push (list var (or start 0)) loop-for-bindings)
		  (if end-var (push (list end-var end) loop-for-bindings))
		  (if step-var (push (list step-var step)
758
				     loop-for-bindings))
Richard M. Stallman's avatar
Richard M. Stallman committed
759
		  (if end
760
		      (push (list
761 762
			     (if down (if excl '> '>=) (if excl '< '<=))
			     var (or end-var end)) loop-body))
763
		  (push (list var (list (if down '- '+) var
764 765
					(or step-var step 1)))
			loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
766 767 768

	       ((memq word '(in in-ref on))
		(let* ((on (eq word 'on))
769 770
		       (temp (if (and on (symbolp var))
				 var (make-symbol "--cl-var--"))))
771 772
		  (push (list temp (pop args)) loop-for-bindings)
		  (push (list 'consp temp) loop-body)
Richard M. Stallman's avatar
Richard M. Stallman committed
773
		  (if (eq word 'in-ref)
774
		      (push (list var (list 'car temp)) loop-symbol-macs)
Richard M. Stallman's avatar
Richard M. Stallman committed
775 776
		    (or (eq temp var)
			(progn
777 778
			  (push (list var nil) loop-for-bindings)
			  (push (list var (if on temp (list 'car temp)))
779
				loop-for-sets))))
780
		  (push (list temp
781 782 783 784 785 786 787 788 789 790
			      (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)))
Richard M. Stallman's avatar
Richard M. Stallman committed
791 792

	       ((eq word '=)
793
		(let* ((start (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
794
		       (then (if (eq (car args) 'then) (cl-pop2 args) start)))
795
		  (push (list var nil) loop-for-bindings)
Richard M. Stallman's avatar
Richard M. Stallman committed
796 797
		  (if (or ands (eq (car args) 'and))
		      (progn
798 799 800 801 802 803
			(push `(,var
				(if ,(or loop-first-flag
					 (setq loop-first-flag
					       (make-symbol "--cl-var--")))
				    ,start ,var))
			      loop-for-sets)
804 805
			(push (list var then) loop-for-steps))
		    (push (list var
806 807 808 809 810 811
				(if (eq start then) start
				  `(if ,(or loop-first-flag
					    (setq loop-first-flag
						  (make-symbol "--cl-var--")))
				       ,start ,then)))
			  loop-for-sets))))
Richard M. Stallman's avatar
Richard M. Stallman committed
812 813

	       ((memq word '(across across-ref))
814 815
		(let ((temp-vec (make-symbol "--cl-vec--"))
		      (temp-idx (make-symbol "--cl-idx--")))
816 817 818
		  (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))
819
			      (list 'length temp-vec)) loop-body)
Richard M. Stallman's avatar
Richard M. Stallman committed
820
		  (if (eq word 'across-ref)
821
		      (push (list var (list 'aref temp-vec temp-idx))
822
			    loop-symbol-macs)
823 824
		    (push (list var nil) loop-for-bindings)
		    (push (list var (list 'aref temp-vec temp-idx))
825
			  loop-for-sets))))
Richard M. Stallman's avatar
Richard M. Stallman committed
826 827 828 829 830 831

	       ((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))
832
		      (temp-seq (make-symbol "--cl-seq--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
833 834 835 836 837
		      (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"))
838
				  (make-symbol "--cl-idx--"))))
839 840
		  (push (list temp-seq seq) loop-for-bindings)
		  (push (list temp-idx 0) loop-for-bindings)
Richard M. Stallman's avatar
Richard M. Stallman committed
841
		  (if ref
842
		      (let ((temp-len (make-symbol "--cl-len--")))
843
			(push (list temp-len (list 'length temp-seq))
844
			      loop-for-bindings)
845
			(push (list var (list 'elt temp-seq temp-idx))
846
			      loop-symbol-macs)
847 848 849
			(push (list '< temp-idx temp-len) loop-body))
		    (push (list var nil) loop-for-bindings)
		    (push (list 'and temp-seq
850 851 852 853
				(list 'or (list 'consp temp-seq)
				      (list '< temp-idx
					    (list 'length temp-seq))))
			  loop-body)
854
		    (push (list var (list 'if (list 'consp temp-seq)
855 856 857
					  (list 'pop temp-seq)
					  (list 'aref temp-seq temp-idx)))
			  loop-for-sets))
858
		  (push (list temp-idx (list '1+ temp-idx))
859
			loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
860 861 862 863 864 865 866 867 868 869

	       ((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"))
870
				(make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
871 872 873
		  (if (memq word '(hash-value hash-values))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
874
			`(maphash (lambda (,var ,other) . --cl-map) ,table))))
Richard M. Stallman's avatar
Richard M. Stallman committed
875 876 877 878 879

	       ((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
880
			`(mapatoms (lambda (,var) . --cl-map) ,ob))))
Richard M. Stallman's avatar
Richard M. Stallman committed
881 882 883 884 885 886 887 888

	       ((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
889 890 891 892
			`(cl-map-extents
			  (lambda (,var ,(make-symbol "--cl-var--"))
			    (progn . --cl-map) nil)
			  ,buf ,from ,to))))
Richard M. Stallman's avatar
Richard M. Stallman committed
893 894 895

	       ((memq word '(interval intervals))
		(let ((buf nil) (prop nil) (from nil) (to nil)
896 897
		      (var1 (make-symbol "--cl-var1--"))
		      (var2 (make-symbol "--cl-var2--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
898 899 900 901 902 903 904 905
		  (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))
906
		    (push (list var (list 'cons var1 var2)) loop-for-sets))
Richard M. Stallman's avatar
Richard M. Stallman committed
907
		  (setq loop-map-form
908 909 910
			`(cl-map-intervals
			  (lambda (,var1 ,var2) . --cl-map)
			  ,buf ,prop ,from ,to))))
Richard M. Stallman's avatar
Richard M. Stallman committed
911 912 913 914 915 916 917 918 919 920

	       ((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"))
921
			       (make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
922 923 924
		  (if (memq word '(key-binding key-bindings))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
925 926 927
			`(,(if (memq word '(key-seq key-seqs))
			       'cl-map-keymap-recursively 'map-keymap)
			  (lambda (,var ,other) . --cl-map) ,map))))
Richard M. Stallman's avatar
Richard M. Stallman committed
928 929

	       ((memq word '(frame frames screen screens))
930
		(let ((temp (make-symbol "--cl-var--")))
931
		  (push (list var  '(selected-frame))
932
			loop-for-bindings)
933 934
		  (push (list temp nil) loop-for-bindings)
		  (push (list 'prog1 (list 'not (list 'eq var temp))
935 936
			      (list 'or temp (list 'setq temp var)))
			loop-body)
937
		  (push (list var (list 'next-frame var))
938
			loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
939 940 941

	       ((memq word '(window windows))
		(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
942
		      (temp (make-symbol "--cl-var--")))
943
		  (push (list var (if scr
944 945 946
				      (list 'frame-selected-window scr)
				    '(selected-window)))
			loop-for-bindings)
947 948
		  (push (list temp nil) loop-for-bindings)
		  (push (list 'prog1 (list 'not (list 'eq var temp))
949 950
			      (list 'or temp (list 'setq temp var)))
			loop-body)
951
		  (push (list var (list 'next-window var)) loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
952 953 954 955 956 957 958 959 960

	       (t
		(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)
961
	  (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
962
	(if (and ands loop-for-bindings)
963
	    (push (nreverse loop-for-bindings) loop-bindings)
Richard M. Stallman's avatar
Richard M. Stallman committed
964 965 966
	  (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
				     loop-bindings)))
	(if loop-for-sets
967
	    (push (list 'progn
968 969
			(cl-loop-let (nreverse loop-for-sets) 'setq ands)
			t) loop-body))
Richard M. Stallman's avatar
Richard M. Stallman committed
970
	(if loop-for-steps
971
	    (push (cons (if ands 'psetq 'setq)
972 973
			(apply 'append (nreverse loop-for-steps)))
		  loop-steps))))
Richard M. Stallman's avatar
Richard M. Stallman committed
974 975

     ((eq word 'repeat)
976
      (let ((temp (make-symbol "--cl-var--")))
977 978
	(push (list (list temp (pop args))) loop-bindings)
	(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
Richard M. Stallman's avatar
Richard M. Stallman committed
979

980
     ((memq word '(collect collecting))
981
      (let ((what (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
982 983
	    (var (cl-loop-handle-accum nil 'nreverse)))
	(if (eq var loop-accum-var)
984 985
	    (push (list 'progn (list 'push what var) t) loop-body)
	  (push (list 'progn
986 987
		      (list 'setq var (list 'nconc var (list 'list what)))
		      t) loop-body))))
Richard M. Stallman's avatar
Richard M. Stallman committed
988 989

     ((memq word '(nconc nconcing append appending))
990
      (let ((what (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
991
	    (var (cl-loop-handle-accum nil 'nreverse)))
992
	(push (list 'progn
993 994 995 996 997 998 999 1000 1001 1002
		    (list 'setq var
			  (if (eq var loop-accum-var)
			      (list 'nconc
				    (list (if (memq word '(nconc nconcing))
					      'nreverse 'reverse)
					  what)
				    var)
			    (list (if (memq word '(nconc nconcing))
				      'nconc 'append)
				  var what))) t) loop-body)))
Richard M. Stallman's avatar
Richard M. Stallman committed
1003 1004

     ((memq word '(concat concating))
1005
      (let ((what (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
1006
	    (var (cl-loop-handle-accum "")))
1007
	(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
Richard M. Stallman's avatar
Richard M. Stallman committed
1008 1009

     ((memq word '(vconcat vconcating))
1010
      (let ((what (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
1011
	    (var (cl-loop-handle-accum [])))
1012
	(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
Richard M. Stallman's avatar
Richard M. Stallman committed
1013 1014

     ((memq word '(sum summing))
1015
      (let ((what (pop args))