cl-macs.el 103 KB
Newer Older
1
;;; cl-macs.el --- Common Lisp macros
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3
;; Copyright (C) 1993, 2001-2011  Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5 6 7

;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
8
;; Package: emacs
Richard M. Stallman's avatar
Richard M. Stallman committed
9 10 11

;; This file is part of GNU Emacs.

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

;; 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
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
24

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

;; 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
44
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
45

46
(require 'cl)
Richard M. Stallman's avatar
Richard M. Stallman committed
47 48 49 50 51 52 53 54 55 56

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


Stefan Monnier's avatar
Stefan Monnier committed
57 58
;; This kludge allows macros which use cl-transform-function-property
;; to be called at compile-time.
Richard M. Stallman's avatar
Richard M. Stallman committed
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73

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

74 75 76 77 78 79 80 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
;;; 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)
131 132 133 134 135 136
  ;; This apparently tries to return nil iff the expression X evaluates
  ;; the variables V in the same order as they appear in V (so as to
  ;; be able to replace those vars with the expressions they're bound
  ;; to).
  ;; FIXME: This is very naive, it doesn't even check to see if those
  ;; variables appear more than once.
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
  (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
163 164 165
;;; Symbols.

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


;;; Program structure.

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

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

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

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

211
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
212
(defmacro function* (func)
213
  "Introduce a function.
214 215
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
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
  (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))

231 232 233 234 235
(defvar cl-macro-environment nil
  "Keep the list of currently active macros.
It is a list of elements of the form either:
- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function.
- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.")
Richard M. Stallman's avatar
Richard M. Stallman committed
236 237 238
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)

239 240
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))

Richard M. Stallman's avatar
Richard M. Stallman committed
241
(defun cl-transform-lambda (form bind-block)
242
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
Richard M. Stallman's avatar
Richard M. Stallman committed
243 244 245
	 (bind-defs nil) (bind-enquote nil)
	 (bind-inits nil) (bind-lets nil) (bind-forms nil)
	 (header nil) (simple-args nil))
246 247
    (while (or (stringp (car body))
	       (memq (car-safe (car body)) '(interactive declare)))
248
      (push (pop body) header))
Richard M. Stallman's avatar
Richard M. Stallman committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
    (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))))))
264
      (push (pop args) simple-args))
Richard M. Stallman's avatar
Richard M. Stallman committed
265 266 267 268
    (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))
269
      (if (memq '&optional simple-args) (push '&optional args))
Richard M. Stallman's avatar
Richard M. Stallman committed
270 271 272 273 274 275
      (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)
276 277
		    (list '&rest (car (pop bind-lets))))
	     (nconc (let ((hdr (nreverse header)))
278 279 280 281 282 283 284 285 286 287 288 289 290
                      ;; Macro expansion can take place in the middle of
                      ;; apparently harmless computation, so it should not
                      ;; touch the match-data.
                      (save-match-data
                        (require 'help-fns)
                        (cons (help-add-fundoc-usage
                               (if (stringp (car hdr)) (pop hdr))
                               ;; orig-args can contain &cl-defs (an internal
                               ;; CL thingy I don't understand), so remove it.
                               (let ((x (memq '&cl-defs orig-args)))
                                 (if (null x) orig-args
                                   (delq (car x) (remq (cadr x) orig-args)))))
                              hdr)))
Richard M. Stallman's avatar
Richard M. Stallman committed
291 292 293 294 295 296 297
		    (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)
298
	(push (list args expr) bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
299 300 301 302 303 304 305 306 307 308 309
    (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))
310
	  (setq restarg (make-symbol "--cl-rest--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
311
	(setq restarg (cadr restarg)))
312
      (push (list restarg expr) bind-lets)
Richard M. Stallman's avatar
Richard M. Stallman committed
313
      (if (eq (car args) '&whole)
314
	  (push (list (cl-pop2 args) restarg) bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
315 316 317 318 319 320 321 322 323 324 325 326 327
      (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
328
	   (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
329 330 331 332 333 334 335
	   (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))
336
      (while (and (eq (car args) '&optional) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
337
	(while (and args (not (memq (car args) lambda-list-keywords)))
338
	  (let ((arg (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
339 340 341 342 343 344 345 346 347 348 349 350 351 352
	    (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
353
	    (push (list 'if restarg
Richard M. Stallman's avatar
Richard M. Stallman committed
354 355 356 357 358 359
			   (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)))
360
      (while (and (eq (car args) '&key) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
361
	(while (and args (not (memq (car args) lambda-list-keywords)))
362
	  (let ((arg (pop args)))
363
	    (or (consp arg) (setq arg (list arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
364 365 366 367 368
	    (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)))))
369
		   (look (list 'memq (list 'quote karg) restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
370 371
	      (and def bind-enquote (setq def (list 'quote def)))
	      (if (cddr arg)
372
		  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390
			 (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))))))))
391
	      (push karg keys)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
392
      (setq keys (nreverse keys))
393
      (or (and (eq (car args) '&allow-other-keys) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
394
	  (null keys) (= safety 0)
395
	  (let* ((var (make-symbol "--cl-keys--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
396 397 398 399 400 401 402 403
		 (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))))
404 405 406 407
			  (list (list 'car
				      (list 'cdr
					    (list 'memq (cons 'quote allow)
						  restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
408 409 410 411 412 413 414
				(list 'setq var nil))
			  (list t
				(list
				 'error
				 (format "Keyword argument %%s not one of %s"
					 keys)
				 (list 'car var)))))))
415 416
	    (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
417 418 419 420
	(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)
421 422 423
				 (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
424 425 426 427 428 429
      (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)
430
	(setq arg (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
431
	(if (memq arg lambda-list-keywords) (setq kind arg)
432
	  (if (eq arg '&cl-defs) (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
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))))))

438
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
439 440
(defmacro destructuring-bind (args expr &rest body)
  (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
Helmut Eller's avatar
Helmut Eller committed
441
	 (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil))
Richard M. Stallman's avatar
Richard M. Stallman committed
442 443 444 445 446 447 448 449 450 451
    (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)

452
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
453
(defmacro eval-when (when &rest body)
454
  "Control when BODY is evaluated.
Richard M. Stallman's avatar
Richard M. Stallman committed
455 456
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.
457 458 459
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
460 461
  (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
	   (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
462
      (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
Richard M. Stallman's avatar
Richard M. Stallman committed
463
	    (cl-not-toplevel t))
464
	(if (or (memq 'load when) (memq :load-toplevel when))
Richard M. Stallman's avatar
Richard M. Stallman committed
465 466 467
	    (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
	      (list* 'if nil nil body))
	  (progn (if comp (eval (cons 'progn body))) nil)))
468
    (and (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
469 470 471 472 473 474 475 476 477 478
	 (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)))
479
	   (if (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
480 481 482 483
	       (list* 'eval-when (cons 'compile when) (cddr form))
	     form)))
	(t (eval form) form)))

484
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
485 486 487 488 489 490 491 492 493 494 495 496 497 498 499
(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)))
500
	  (print set (symbol-value 'byte-compile--outbuffer)))
Richard M. Stallman's avatar
Richard M. Stallman committed
501 502 503 504 505 506
	(list 'symbol-value (list 'quote temp)))
    (list 'quote (eval form))))


;;; Conditional control structures.

507
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
508
(defmacro case (expr &rest clauses)
509
  "Eval EXPR and choose among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
510 511 512
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
513
place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
Richard M. Stallman's avatar
Richard M. Stallman committed
514
allowed only in the final clause, and matches if no other keys match.
515 516
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
517
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
	 (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)))
535
				 (push (car c) head-list)
Richard M. Stallman's avatar
Richard M. Stallman committed
536 537 538 539 540 541
				 (list 'eql temp (list 'quote (car c)))))
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

542
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
543
(defmacro ecase (expr &rest clauses)
544
  "Like `case', but error if no case fits.
545 546
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
547 548
  (list* 'case expr (append clauses '((ecase-error-flag)))))

549
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
550
(defmacro typecase (expr &rest clauses)
551
  "Evals EXPR, chooses among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
552 553
Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
554
typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
555 556
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
557
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
558 559 560 561 562 563 564 565 566 567 568
	 (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
569
				 (push (car c) type-list)
Richard M. Stallman's avatar
Richard M. Stallman committed
570 571 572 573 574 575
				 (cl-make-type-test temp (car c))))
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

576
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
577
(defmacro etypecase (expr &rest clauses)
578
  "Like `typecase', but error if no case fits.
579 580
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
581 582 583 584 585
  (list* 'typecase expr (append clauses '((ecase-error-flag)))))


;;; Blocks and exits.

586
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
587
(defmacro block (name &rest body)
588
  "Define a lexically-scoped block named NAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
589 590 591 592 593 594 595 596 597 598 599 600
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))))

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

607
;;;###autoload
608 609
(defmacro return-from (name &optional result)
  "Return from the block named NAME.
610
This jumps out to the innermost enclosing `(block NAME ...)' form,
Richard M. Stallman's avatar
Richard M. Stallman committed
611 612 613 614
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))))
615
    (list 'cl-block-throw (list 'quote name2) result)))
Richard M. Stallman's avatar
Richard M. Stallman committed
616 617 618 619


;;; The "loop" macro.

Glenn Morris's avatar
Glenn Morris committed
620
(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
Richard M. Stallman's avatar
Richard M. Stallman committed
621 622 623 624 625 626
(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)

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

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

Glenn Morris's avatar
Glenn Morris committed
694 695
(defun cl-parse-loop-clause ()		; uses loop-*
  (let ((word (pop loop-args))
Richard M. Stallman's avatar
Richard M. Stallman committed
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

Glenn Morris's avatar
Glenn Morris committed
701
     ((null loop-args)
Richard M. Stallman's avatar
Richard M. Stallman committed
702 703 704
      (error "Malformed `loop' macro"))

     ((eq word 'named)
Glenn Morris's avatar
Glenn Morris committed
705
      (setq loop-name (pop loop-args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
706 707

     ((eq word 'initially)
Glenn Morris's avatar
Glenn Morris committed
708 709 710 711
      (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)))
Richard M. Stallman's avatar
Richard M. Stallman committed
712 713

     ((eq word 'finally)
Glenn Morris's avatar
Glenn Morris committed
714 715 716 717 718 719 720 721
      (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)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
722 723 724 725 726

     ((memq word '(for as))
      (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
	    (ands nil))
	(while
727 728 729
	    ;; 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.
Glenn Morris's avatar
Glenn Morris committed
730 731 732 733
	    (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)))
Richard M. Stallman's avatar
Richard M. Stallman committed
734
	      (if (memq word '(buffer buffers))
Glenn Morris's avatar
Glenn Morris committed
735
		  (setq word 'in loop-args (cons '(buffer-list) loop-args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
736 737 738 739
	      (cond

	       ((memq word '(from downfrom upfrom to downto upto
			     above below by))
Glenn Morris's avatar
Glenn Morris committed
740 741
		(push word loop-args)
		(if (memq (car loop-args) '(downto above))
Richard M. Stallman's avatar
Richard M. Stallman committed
742
		    (error "Must specify `from' value for downward loop"))
Glenn Morris's avatar
Glenn Morris committed
743 744 745 746 747 748 749
		(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)
Richard M. Stallman's avatar
Richard M. Stallman committed
750
				       '(to upto downto above below))
Glenn Morris's avatar
Glenn Morris committed
751 752
				 (cl-pop2 loop-args)))
		       (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
753 754
		       (end-var (and (not (cl-const-expr-p end))
				     (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
755
		       (step-var (and (not (cl-const-expr-p step))
756
				      (make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
757 758
		  (and step (numberp step) (<= step 0)
		       (error "Loop `by' value is not positive: %s" step))
759 760 761
		  (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)
762
				     loop-for-bindings))
Richard M. Stallman's avatar
Richard M. Stallman committed
763
		  (if end
764
		      (push (list
765 766
			     (if down (if excl '> '>=) (if excl '< '<=))
			     var (or end-var end)) loop-body))
767
		  (push (list var (list (if down '- '+) var
768 769
					(or step-var step 1)))
			loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
770 771 772

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

	       ((eq word '=)
Glenn Morris's avatar
Glenn Morris committed
797 798
		(let* ((start (pop loop-args))
		       (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
799
		  (push (list var nil) loop-for-bindings)
Glenn Morris's avatar
Glenn Morris committed
800
		  (if (or ands (eq (car loop-args) 'and))
Richard M. Stallman's avatar
Richard M. Stallman committed
801
		      (progn
802 803 804 805 806 807
			(push `(,var
				(if ,(or loop-first-flag
					 (setq loop-first-flag
					       (make-symbol "--cl-var--")))
				    ,start ,var))
			      loop-for-sets)
808 809
			(push (list var then) loop-for-steps))
		    (push (list var
810 811 812 813 814 815
				(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
816 817

	       ((memq word '(across across-ref))
818 819
		(let ((temp-vec (make-symbol "--cl-vec--"))
		      (temp-idx (make-symbol "--cl-idx--")))
Glenn Morris's avatar
Glenn Morris committed
820
		  (push (list temp-vec (pop loop-args)) loop-for-bindings)
821 822
		  (push (list temp-idx -1) loop-for-bindings)
		  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
823
			      (list 'length temp-vec)) loop-body)
Richard M. Stallman's avatar
Richard M. Stallman committed
824
		  (if (eq word 'across-ref)
825
		      (push (list var (list 'aref temp-vec temp-idx))
826
			    loop-symbol-macs)
827 828
		    (push (list var nil) loop-for-bindings)
		    (push (list var (list 'aref temp-vec temp-idx))
829
			  loop-for-sets))))
Richard M. Stallman's avatar
Richard M. Stallman committed
830 831

	       ((memq word '(element elements))
Glenn Morris's avatar
Glenn Morris committed
832 833
		(let ((ref (or (memq (car loop-args) '(in-ref of-ref))
			       (and (not (memq (car loop-args) '(in of)))
Richard M. Stallman's avatar
Richard M. Stallman committed
834
				    (error "Expected `of'"))))
Glenn Morris's avatar
Glenn Morris committed
835
		      (seq (cl-pop2 loop-args))
836
		      (temp-seq (make-symbol "--cl-seq--"))
Glenn Morris's avatar
Glenn Morris committed
837 838 839 840
		      (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))
Richard M. Stallman's avatar
Richard M. Stallman committed
841
				      (error "Bad `using' clause"))
842
				  (make-symbol "--cl-idx--"))))
843 844
		  (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
845
		  (if ref
846
		      (let ((temp-len (make-symbol "--cl-len--")))
847
			(push (list temp-len (list 'length temp-seq))
848
			      loop-for-bindings)
849
			(push (list var (list 'elt temp-seq temp-idx))
850
			      loop-symbol-macs)
851 852 853
			(push (list '< temp-idx temp-len) loop-body))
		    (push (list var nil) loop-for-bindings)
		    (push (list 'and temp-seq
854 855 856 857
				(list 'or (list 'consp temp-seq)
				      (list '< temp-idx
					    (list 'length temp-seq))))
			  loop-body)
858
		    (push (list var (list 'if (list 'consp temp-seq)
859 860 861
					  (list 'pop temp-seq)
					  (list 'aref temp-seq temp-idx)))
			  loop-for-sets))
862
		  (push (list temp-idx (list '1+ temp-idx))
863
			loop-for-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
864 865

	       ((memq word hash-types)
Glenn Morris's avatar
Glenn Morris committed
866 867 868 869 870 871 872
		(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))
Richard M. Stallman's avatar
Richard M. Stallman committed
873
				    (error "Bad `using' clause"))
874
				(make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
875 876 877
		  (if (memq word '(hash-value hash-values))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
878
			`(maphash (lambda (,var ,other) . --cl-map) ,table))))
Richard M. Stallman's avatar
Richard M. Stallman committed
879 880 881

	       ((memq word '(symbol present-symbol external-symbol
			     symbols present-symbols external-symbols))
Glenn Morris's avatar
Glenn Morris committed
882
		(let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
Richard M. Stallman's avatar
Richard M. Stallman committed
883
		  (setq loop-map-form
884
			`(mapatoms (lambda (,var) . --cl-map) ,ob))))
Richard M. Stallman's avatar
Richard M. Stallman committed
885 886 887

	       ((memq word '(overlay overlays extent extents))
		(let ((buf nil) (from nil) (to nil))
Glenn Morris's avatar
Glenn Morris committed
888 889 890 891
		  (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)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
892
		  (setq loop-map-form
893 894 895 896
			`(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
897 898 899

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

	       ((memq word key-types)
Glenn Morris's avatar
Glenn Morris committed
917 918 919 920 921 922 923
		(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))
Richard M. Stallman's avatar
Richard M. Stallman committed
924
				   (error "Bad `using' clause"))
925
			       (make-symbol "--cl-var--"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
926 927 928
		  (if (memq word '(key-binding key-bindings))
		      (setq var (prog1 other (setq other var))))
		  (setq loop-map-form
929 930 931
			`(,(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
932 933

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

	       ((memq word '(window windows))
Glenn Morris's avatar
Glenn Morris committed
945
		(let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
946 947
		      (temp (make-symbol "--cl-var--"))
		      (minip (make-symbol "--cl-minip--")))