git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/cl-macs.el

   1 ;;; cl-macs.el --- Common Lisp extensions for GNU Emacs Lisp (part four)
   2
   3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Gillespie <daveg@synaptics.com>
   6 ;; Version: 2.02
   7 ;; Keywords: extensions
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;;; Synched up with: FSF 19.34.
  27
  28 ;;; Commentary:
  29
  30 ;; These are extensions to Emacs Lisp that provide a degree of
  31 ;; Common Lisp compatibility, beyond what is already built-in
  32 ;; in Emacs Lisp.
  33 ;;
  34 ;; This package was written by Dave Gillespie; it is a complete
  35 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  36 ;;
  37 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
  38 ;;
  39 ;; Bug reports, comments, and suggestions are welcome!
  40
  41 ;; This file contains the portions of the Common Lisp extensions
  42 ;; package which should be autoloaded, but need only be present
  43 ;; if the compiler or interpreter is used---this file is not
  44 ;; necessary for executing compiled code.
  45
  46 ;; See cl.el for Change Log.
  47
  48
  49 ;;; Code:
  50
  51 (or (memq 'cl-19 features)
  52     (error "Tried to load `cl-macs' before `cl'!"))
  53
  54
  55 ;;; We define these here so that this file can compile without having
  56 ;;; loaded the cl.el file already.
  57
  58 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
  59 (defmacro cl-pop (place)
  60   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
  61 (defmacro cl-pop2 (place)
  62   (list 'prog1 (list 'car (list 'cdr place))
  63         (list 'setq place (list 'cdr (list 'cdr place)))))
  64 (put 'cl-push 'edebug-form-spec 'edebug-sexps)
  65 (put 'cl-pop 'edebug-form-spec 'edebug-sexps)
  66 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
  67
  68 (defvar cl-emacs-type)
  69 (defvar cl-optimize-safety)
  70 (defvar cl-optimize-speed)
  71
  72
  73 ;;; This kludge allows macros which use cl-transform-function-property
  74 ;;; to be called at compile-time.
  75
  76 (require
  77  (progn
  78    (or (fboundp 'defalias) (fset 'defalias 'fset))
  79    (or (fboundp 'cl-transform-function-property)
  80        (defalias 'cl-transform-function-property
  81          #'(lambda (n p f)
  82              (list 'put (list 'quote n) (list 'quote p)
  83                    (list 'function (cons 'lambda f))))))
  84    (car (or features (setq features (list 'cl-kludge))))))
  85
  86
  87 ;;; Initialization.
  88
  89 (defvar cl-old-bc-file-form nil)
  90
  91 ;; Patch broken Emacs 18 compiler (re top-level macros).
  92 ;; Emacs 19 compiler doesn't need this patch.
  93 ;; Also, undo broken definition of `eql' that uses same bytecode as `eq'.
  94
  95 ;;;###autoload
  96 (defun cl-compile-time-init ()
  97   (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form))
  98   (or (fboundp 'byte-compile-flush-pending)   ; Emacs 19 compiler?
  99       (defalias 'byte-compile-file-form
 100         #'(lambda (form)
 101             (setq form (macroexpand form byte-compile-macro-environment))
 102             (if (eq (car-safe form) 'progn)
 103                 (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
 104               (funcall cl-old-bc-file-form form)))))
 105   (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
 106   (run-hooks 'cl-hack-bytecomp-hook))
 107
 108
 109 ;;; Symbols.
 110
 111 (defvar *gensym-counter*)
 112
 113 ;;;###autoload
 114 (defun gensym (&optional arg)
 115   "Generate a new uninterned symbol.
 116 The name is made by appending a number to PREFIX, default \"G\"."
 117   (let ((prefix (if (stringp arg) arg "G"))
 118         (num (if (integerp arg) arg
 119                (prog1 *gensym-counter*
 120                  (setq *gensym-counter* (1+ *gensym-counter*))))))
 121     (make-symbol (format "%s%d" prefix num))))
 122
 123 ;;;###autoload
 124 (defun gentemp (&optional arg)
 125   "Generate a new interned symbol with a unique name.
 126 The name is made by appending a number to PREFIX, default \"G\"."
 127   (let ((prefix (if (stringp arg) arg "G"))
 128         name)
 129     (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
 130       (setq *gensym-counter* (1+ *gensym-counter*)))
 131     (intern name)))
 132
 133
 134 ;;; Program structure.
 135
 136 ;;;###autoload
 137 (defmacro defun* (name args &rest body)
 138   "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
 139 Like normal `defun', except ARGLIST allows full Common Lisp conventions,
 140 and BODY is implicitly surrounded by (block NAME ...)."
 141   (let* ((res (cl-transform-lambda (cons args body) name))
 142          (form (list* 'defun name (cdr res))))
 143     (if (car res) (list 'progn (car res) form) form)))
 144
 145 ;;;###autoload
 146 (defmacro defmacro* (name args &rest body)
 147   "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
 148 Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
 149 and BODY is implicitly surrounded by (block NAME ...)."
 150   (let* ((res (cl-transform-lambda (cons args body) name))
 151          (form (list* 'defmacro name (cdr res))))
 152     (if (car res) (list 'progn (car res) form) form)))
 153
 154 ;;;###autoload
 155 (defmacro function* (func)
 156   "(function* SYMBOL-OR-LAMBDA): introduce a function.
 157 Like normal `function', except that if argument is a lambda form, its
 158 ARGLIST allows full Common Lisp conventions."
 159   (if (eq (car-safe func) 'lambda)
 160       (let* ((res (cl-transform-lambda (cdr func) 'cl-none))
 161              (form (list 'function (cons 'lambda (cdr res)))))
 162         (if (car res) (list 'progn (car res) form) form))
 163     (list 'function func)))
 164
 165 (defun cl-transform-function-property (func prop form)
 166   (let ((res (cl-transform-lambda form func)))
 167     (append '(progn) (cdr (cdr (car res)))
 168             (list (list 'put (list 'quote func) (list 'quote prop)
 169                         (list 'function (cons 'lambda (cdr res))))))))
 170
 171 (defconst lambda-list-keywords
 172   '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 173
 174 (defvar cl-macro-environment nil)
 175 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 176 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
 177
 178 (defun cl-transform-lambda (form bind-block)
 179   (let* ((args (car form)) (body (cdr form))
 180          (bind-defs nil) (bind-enquote nil)
 181          (bind-inits nil) (bind-lets nil) (bind-forms nil)
 182          (header nil) (simple-args nil))
 183     (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
 184       (cl-push (cl-pop body) header))
 185     (setq args (if (listp args) (copy-list args) (list '&rest args)))
 186     (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 187     (if (setq bind-defs (cadr (memq '&cl-defs args)))
 188         (setq args (delq '&cl-defs (delq bind-defs args))
 189               bind-defs (cadr bind-defs)))
 190     (if (setq bind-enquote (memq '&cl-quote args))
 191         (setq args (delq '&cl-quote args)))
 192     (if (memq '&whole args) (error "&whole not currently implemented"))
 193     (let* ((p (memq '&environment args)) (v (cadr p)))
 194       (if p (setq args (nconc (delq (car p) (delq v args))
 195                               (list '&aux (list v 'cl-macro-environment))))))
 196     (while (and args (symbolp (car args))
 197                 (not (memq (car args) '(nil &rest &body &key &aux)))
 198                 (not (and (eq (car args) '&optional)
 199                           (or bind-defs (consp (cadr args))))))
 200       (cl-push (cl-pop args) simple-args))
 201     (or (eq bind-block 'cl-none)
 202         (setq body (list (list* 'block bind-block body))))
 203     (if (null args)
 204         (list* nil (nreverse simple-args) (nconc (nreverse header) body))
 205       (if (memq '&optional simple-args) (cl-push '&optional args))
 206       (cl-do-arglist args nil (- (length simple-args)
 207                                  (if (memq '&optional simple-args) 1 0)))
 208       (setq bind-lets (nreverse bind-lets))
 209       (list* (and bind-inits (list* 'eval-when '(compile load eval)
 210                                     (nreverse bind-inits)))
 211              (nconc (nreverse simple-args)
 212                     (list '&rest (car (cl-pop bind-lets))))
 213              (nconc (nreverse header)
 214                     (list (nconc (list 'let* bind-lets)
 215                                  (nreverse bind-forms) body)))))))
 216
 217 (defun cl-do-arglist (args expr &optional num)   ; uses bind-*
 218   (if (nlistp args)
 219       (if (or (memq args lambda-list-keywords) (not (symbolp args)))
 220           (error "Invalid argument name: %s" args)
 221         (cl-push (list args expr) bind-lets))
 222     (setq args (copy-list args))
 223     (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 224     (let ((p (memq '&body args))) (if p (setcar p '&rest)))
 225     (if (memq '&environment args) (error "&environment used incorrectly"))
 226     (let ((save-args args)
 227           (restarg (memq '&rest args))
 228           (safety (if (cl-compiling-file) cl-optimize-safety 3))
 229           (keys nil)
 230           (laterarg nil) (exactarg nil) minarg)
 231       (or num (setq num 0))
 232       (if (listp (cadr restarg))
 233           (setq restarg (gensym "--rest--"))
 234         (setq restarg (cadr restarg)))
 235       (cl-push (list restarg expr) bind-lets)
 236       (if (eq (car args) '&whole)
 237           (cl-push (list (cl-pop2 args) restarg) bind-lets))
 238       (let ((p args))
 239         (setq minarg restarg)
 240         (while (and p (not (memq (car p) lambda-list-keywords)))
 241           (or (eq p args) (setq minarg (list 'cdr minarg)))
 242           (setq p (cdr p)))
 243         (if (memq (car p) '(nil &aux))
 244             (setq minarg (list '= (list 'length restarg)
 245                                (length (ldiff args p)))
 246                   exactarg (not (eq args p)))))
 247       (while (and args (not (memq (car args) lambda-list-keywords)))
 248         (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
 249                             restarg)))
 250           (cl-do-arglist
 251            (cl-pop args)
 252            (if (or laterarg (= safety 0)) poparg
 253              (list 'if minarg poparg
 254                    (list 'signal '(quote wrong-number-of-arguments)
 255                          (list 'list (and (not (eq bind-block 'cl-none))
 256                                           (list 'quote bind-block))
 257                                (list 'length restarg)))))))
 258         (setq num (1+ num) laterarg t))
 259       (while (and (eq (car args) '&optional) (cl-pop args))
 260         (while (and args (not (memq (car args) lambda-list-keywords)))
 261           (let ((arg (cl-pop args)))
 262             (or (consp arg) (setq arg (list arg)))
 263             (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
 264             (let ((def (if (cdr arg) (nth 1 arg)
 265                          (or (car bind-defs)
 266                              (nth 1 (assq (car arg) bind-defs)))))
 267                   (poparg (list 'pop restarg)))
 268               (and def bind-enquote (setq def (list 'quote def)))
 269               (cl-do-arglist (car arg)
 270                              (if def (list 'if restarg poparg def) poparg))
 271               (setq num (1+ num))))))
 272       (if (eq (car args) '&rest)
 273           (let ((arg (cl-pop2 args)))
 274             (if (consp arg) (cl-do-arglist arg restarg)))
 275         (or (eq (car args) '&key) (= safety 0) exactarg
 276             (cl-push (list 'if restarg
 277                            (list 'signal '(quote wrong-number-of-arguments)
 278                                  (list 'list
 279                                        (and (not (eq bind-block 'cl-none))
 280                                             (list 'quote bind-block))
 281                                        (list '+ num (list 'length restarg)))))
 282                      bind-forms)))
 283       (while (and (eq (car args) '&key) (cl-pop args))
 284         (while (and args (not (memq (car args) lambda-list-keywords)))
 285           (let ((arg (cl-pop args)))
 286             (or (consp arg) (setq arg (list arg)))
 287             (let* ((karg (if (consp (car arg)) (caar arg)
 288                            (intern (format ":%s" (car arg)))))
 289                    (varg (if (consp (car arg)) (cadar arg) (car arg)))
 290                    (def (if (cdr arg) (cadr arg)
 291                           (or (car bind-defs) (cadr (assq varg bind-defs)))))
 292                    (look (list 'memq (list 'quote karg) restarg)))
 293               (and def bind-enquote (setq def (list 'quote def)))
 294               (if (cddr arg)
 295                   (let* ((temp (or (nth 2 arg) (gensym)))
 296                          (val (list 'car (list 'cdr temp))))
 297                     (cl-do-arglist temp look)
 298                     (cl-do-arglist varg
 299                                    (list 'if temp
 300                                          (list 'prog1 val (list 'setq temp t))
 301                                          def)))
 302                 (cl-do-arglist
 303                  varg
 304                  (list 'car
 305                        (list 'cdr
 306                              (if (null def)
 307                                  look
 308                                (list 'or look
 309                                      (if (eq (cl-const-expr-p def) t)
 310                                          (list
 311                                           'quote
 312                                           (list nil (cl-const-expr-val def)))
 313                                        (list 'list nil def))))))))
 314               (cl-push karg keys)
 315               (if (= (aref (symbol-name karg) 0) ?:)
 316                   (progn (set karg karg)
 317                          (cl-push (list 'setq karg (list 'quote karg))
 318                                   bind-inits)))))))
 319       (setq keys (nreverse keys))
 320       (or (and (eq (car args) '&allow-other-keys) (cl-pop args))
 321           (null keys) (= safety 0)
 322           (let* ((var (gensym "--keys--"))
 323                  (allow '(:allow-other-keys))
 324                  (check (list
 325                          'while var
 326                          (list
 327                           'cond
 328                           (list (list 'memq (list 'car var)
 329                                       (list 'quote (append keys allow)))
 330                                 (list 'setq var (list 'cdr (list 'cdr var))))
 331                           (list (list 'car
 332                                       (list 'cdr
 333                                             (list 'memq (cons 'quote allow)
 334                                                   restarg)))
 335                                 (list 'setq var nil))
 336                           (list t
 337                                 (list
 338                                  'error
 339                                  (format "Keyword argument %%s not one of %s"
 340                                          keys)
 341                                  (list 'car var)))))))
 342             (cl-push (list 'let (list (list var restarg)) check) bind-forms)))
 343       (while (and (eq (car args) '&aux) (cl-pop args))
 344         (while (and args (not (memq (car args) lambda-list-keywords)))
 345           (if (consp (car args))
 346               (if (and bind-enquote (cadar args))
 347                   (cl-do-arglist (caar args)
 348                                  (list 'quote (cadr (cl-pop args))))
 349                 (cl-do-arglist (caar args) (cadr (cl-pop args))))
 350             (cl-do-arglist (cl-pop args) nil))))
 351       (if args (error "Malformed argument list %s" save-args)))))
 352
 353 (defun cl-arglist-args (args)
 354   (if (nlistp args) (list args)
 355     (let ((res nil) (kind nil) arg)
 356       (while (consp args)
 357         (setq arg (cl-pop args))
 358         (if (memq arg lambda-list-keywords) (setq kind arg)
 359           (if (eq arg '&cl-defs) (cl-pop args)
 360             (and (consp arg) kind (setq arg (car arg)))
 361             (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
 362             (setq res (nconc res (cl-arglist-args arg))))))
 363       (nconc res (and args (list args))))))
 364
 365 ;;;###autoload
 366 (defmacro destructuring-bind (args expr &rest body)
 367   (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
 368          (bind-defs nil) (bind-block 'cl-none))
 369     (cl-do-arglist (or args '(&aux)) expr)
 370     (append '(progn) bind-inits
 371             (list (nconc (list 'let* (nreverse bind-lets))
 372                          (nreverse bind-forms) body)))))
 373
 374
 375 ;;; The `eval-when' form.
 376
 377 (defvar cl-not-toplevel nil)
 378
 379 ;;;###autoload
 380 (defmacro eval-when (when &rest body)
 381   "(eval-when (WHEN...) BODY...): control when BODY is evaluated.
 382 If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
 383 If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
 384 If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level."
 385   (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
 386            (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
 387       (let ((comp (or (memq 'compile when) (memq ':compile-toplevel when)))
 388             (cl-not-toplevel t))
 389         (if (or (memq 'load when) (memq ':load-toplevel when))
 390             (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
 391               (list* 'if nil nil body))
 392           (progn (if comp (eval (cons 'progn body))) nil)))
 393     (and (or (memq 'eval when) (memq ':execute when))
 394          (cons 'progn body))))
 395
 396 (defun cl-compile-time-too (form)
 397   (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
 398       (setq form (macroexpand
 399                   form (cons '(eval-when) byte-compile-macro-environment))))
 400   (cond ((eq (car-safe form) 'progn)
 401          (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
 402         ((eq (car-safe form) 'eval-when)
 403          (let ((when (nth 1 form)))
 404            (if (or (memq 'eval when) (memq ':execute when))
 405                (list* 'eval-when (cons 'compile when) (cddr form))
 406              form)))
 407         (t (eval form) form)))
 408
 409 (or (and (fboundp 'eval-when-compile)
 410          (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload)))
 411     (eval '(defmacro eval-when-compile (&rest body)
 412              "Like `progn', but evaluates the body at compile time.
 413 The result of the body appears to the compiler as a quoted constant."
 414              (list 'quote (eval (cons 'progn body))))))
 415
 416 ;;;###autoload
 417 (defmacro load-time-value (form &optional read-only)
 418   "Like `progn', but evaluates the body at load time.
 419 The result of the body appears to the compiler as a quoted constant."
 420   (if (cl-compiling-file)
 421       (let* ((temp (gentemp "--cl-load-time--"))
 422              (set (list 'set (list 'quote temp) form)))
 423         (if (and (fboundp 'byte-compile-file-form-defmumble)
 424                  (boundp 'this-kind) (boundp 'that-one))
 425             (fset 'byte-compile-file-form
 426                   (list 'lambda '(form)
 427                         (list 'fset '(quote byte-compile-file-form)
 428                               (list 'quote
 429                                     (symbol-function 'byte-compile-file-form)))
 430                         (list 'byte-compile-file-form (list 'quote set))
 431                         '(byte-compile-file-form form)))
 432           ;; XEmacs change
 433           (print set (symbol-value ;;'outbuffer
 434                                    'byte-compile-output-buffer
 435                                    )))
 436         (list 'symbol-value (list 'quote temp)))
 437     (list 'quote (eval form))))
 438
 439
 440 ;;; Conditional control structures.
 441
 442 ;;;###autoload
 443 (defmacro case (expr &rest clauses)
 444   "(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value.
 445 Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
 446 against each key in each KEYLIST; the corresponding BODY is evaluated.
 447 If no clause succeeds, case returns nil.  A single atom may be used in
 448 place of a KEYLIST of one atom.  A KEYLIST of `t' or `otherwise' is
 449 allowed only in the final clause, and matches if no other keys match.
 450 Key values are compared by `eql'."
 451   (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
 452          (head-list nil)
 453          (last-clause (car (last clauses)))
 454          (body (cons
 455                 'cond
 456                 (mapcar
 457                  #'(lambda (c)
 458                      (cons (cond ((memq (car c) '(t otherwise))
 459                                   (or (eq c last-clause)
 460                                       (error
 461                                        "`%s' is allowed only as the last case clause"
 462                                        (car c)))
 463                                   t)
 464                                  ((eq (car c) 'ecase-error-flag)
 465                                   (list 'error "ecase failed: %s, %s"
 466                                         temp (list 'quote (reverse head-list))))
 467                                  ((listp (car c))
 468                                   (setq head-list (append (car c) head-list))
 469                                   (list 'member* temp (list 'quote (car c))))
 470                                  (t
 471                                   (if (memq (car c) head-list)
 472                                       (error "Duplicate key in case: %s"
 473                                              (car c)))
 474                                   (cl-push (car c) head-list)
 475                                   (list 'eql temp (list 'quote (car c)))))
 476                            (or (cdr c) '(nil))))
 477                  clauses))))
 478     (if (eq temp expr) body
 479       (list 'let (list (list temp expr)) body))))
 480
 481 ;; #### CL standard also requires `ccase', which signals a continuable
 482 ;; error (`cerror' in XEmacs).  However, I don't think it buys us
 483 ;; anything to introduce it, as there is probably much more CL stuff
 484 ;; missing, and the feature is not essential.  --hniksic
 485
 486 ;;;###autoload
 487 (defmacro ecase (expr &rest clauses)
 488   "(ecase EXPR CLAUSES...): like `case', but error if no case fits.
 489 `otherwise'-clauses are not allowed."
 490   (let ((disallowed (or (assq t clauses)
 491                         (assq 'otherwise clauses))))
 492     (if disallowed
 493         (error "`%s' is not allowed in ecase" (car disallowed))))
 494   (list* 'case expr (append clauses '((ecase-error-flag)))))
 495
 496 ;;;###autoload
 497 (defmacro typecase (expr &rest clauses)
 498   "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value.
 499 Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
 500 satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
 501 typecase returns nil.  A TYPE of `t' or `otherwise' is allowed only in the
 502 final clause, and matches if no other keys match."
 503   (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
 504          (type-list nil)
 505          (body (cons
 506                 'cond
 507                 (mapcar
 508                  #'(lambda (c)
 509                      (cons (cond ((eq (car c) 'otherwise) t)
 510                                  ((eq (car c) 'ecase-error-flag)
 511                                   (list 'error "etypecase failed: %s, %s"
 512                                         temp (list 'quote (reverse type-list))))
 513                                  (t
 514                                   (cl-push (car c) type-list)
 515                                   (cl-make-type-test temp (car c))))
 516                            (or (cdr c) '(nil))))
 517                  clauses))))
 518     (if (eq temp expr) body
 519       (list 'let (list (list temp expr)) body))))
 520
 521 ;;;###autoload
 522 (defmacro etypecase (expr &rest clauses)
 523   "(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits.
 524 `otherwise'-clauses are not allowed."
 525   (list* 'typecase expr (append clauses '((ecase-error-flag)))))
 526
 527
 528 ;;; Blocks and exits.
 529
 530 ;;;###autoload
 531 (defmacro block (name &rest body)
 532   "(block NAME BODY...): define a lexically-scoped block named NAME.
 533 NAME may be any symbol.  Code inside the BODY forms can call `return-from'
 534 to jump prematurely out of the block.  This differs from `catch' and `throw'
 535 in two respects:  First, the NAME is an unevaluated symbol rather than a
 536 quoted symbol or other form; and second, NAME is lexically rather than
 537 dynamically scoped:  Only references to it within BODY will work.  These
 538 references may appear inside macro expansions, but not inside functions
 539 called from BODY."
 540   (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
 541     (list 'cl-block-wrapper
 542           (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
 543                  body))))
 544
 545 (defvar cl-active-block-names nil)
 546
 547 (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
 548 (defun cl-byte-compile-block (cl-form)
 549   (if (fboundp 'byte-compile-form-do-effect)  ; Check for optimizing compiler
 550       (progn
 551         (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
 552                (cl-active-block-names (cons cl-entry cl-active-block-names))
 553                (cl-body (byte-compile-top-level
 554                          (cons 'progn (cddr (nth 1 cl-form))))))
 555           (if (cdr cl-entry)
 556               (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
 557             (byte-compile-form cl-body))))
 558     (byte-compile-form (nth 1 cl-form))))
 559
 560 (put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
 561 (defun cl-byte-compile-throw (cl-form)
 562   (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
 563     (if cl-found (setcdr cl-found t)))
 564   (byte-compile-normal-call (cons 'throw (cdr cl-form))))
 565
 566 ;;;###autoload
 567 (defmacro return (&optional res)
 568   "(return [RESULT]): return from the block named nil.
 569 This is equivalent to `(return-from nil RESULT)'."
 570   (list 'return-from nil res))
 571
 572 ;;;###autoload
 573 (defmacro return-from (name &optional res)
 574   "(return-from NAME [RESULT]): return from the block named NAME.
 575 This jumps out to the innermost enclosing `(block NAME ...)' form,
 576 returning RESULT from that form (or nil if RESULT is omitted).
 577 This is compatible with Common Lisp, but note that `defun' and
 578 `defmacro' do not create implicit blocks as they do in Common Lisp."
 579   (let ((name2 (intern (format "--cl-block-%s--" name))))
 580     (list 'cl-block-throw (list 'quote name2) res)))
 581
 582
 583 ;;; The "loop" macro.
 584
 585 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
 586 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
 587 (defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
 588 (defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
 589 (defvar loop-result) (defvar loop-result-explicit)
 590 (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
 591
 592 ;;;###autoload
 593 (defmacro loop (&rest args)
 594   "(loop CLAUSE...): The Common Lisp `loop' macro.
 595 Valid clauses are:
 596   for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
 597   for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
 598   for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
 599   always COND, never COND, thereis COND, collect EXPR into VAR,
 600   append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
 601   count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
 602   if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
 603   unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
 604   do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
 605   finally return EXPR, named NAME."
 606   (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
 607       (list 'block nil (list* 'while t args))
 608     (let ((loop-name nil)       (loop-bindings nil)
 609           (loop-body nil)       (loop-steps nil)
 610           (loop-result nil)     (loop-result-explicit nil)
 611           (loop-result-var nil) (loop-finish-flag nil)
 612           (loop-accum-var nil)  (loop-accum-vars nil)
 613           (loop-initially nil)  (loop-finally nil)
 614           (loop-map-form nil)   (loop-first-flag nil)
 615           (loop-destr-temps nil) (loop-symbol-macs nil))
 616       (setq args (append args '(cl-end-loop)))
 617       (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
 618       (if loop-finish-flag
 619           (cl-push (list (list loop-finish-flag t)) loop-bindings))
 620       (if loop-first-flag
 621           (progn (cl-push (list (list loop-first-flag t)) loop-bindings)
 622                  (cl-push (list 'setq loop-first-flag nil) loop-steps)))
 623       (let* ((epilogue (nconc (nreverse loop-finally)
 624                               (list (or loop-result-explicit loop-result))))
 625              (ands (cl-loop-build-ands (nreverse loop-body)))
 626              (while-body (nconc (cadr ands) (nreverse loop-steps)))
 627              (body (append
 628                     (nreverse loop-initially)
 629                     (list (if loop-map-form
 630                               (list 'block '--cl-finish--
 631                                     (subst
 632                                      (if (eq (car ands) t) while-body
 633                                        (cons (list 'or (car ands)
 634                                                    '(return-from --cl-finish--
 635                                                       nil))
 636                                              while-body))
 637                                      '--cl-map loop-map-form))
 638                             (list* 'while (car ands) while-body)))
 639                     (if loop-finish-flag
 640                         (if (equal epilogue '(nil)) (list loop-result-var)
 641                           (list (list 'if loop-finish-flag
 642                                       (cons 'progn epilogue) loop-result-var)))
 643                       epilogue))))
 644         (if loop-result-var (cl-push (list loop-result-var) loop-bindings))
 645         (while loop-bindings
 646           (if (cdar loop-bindings)
 647               (setq body (list (cl-loop-let (cl-pop loop-bindings) body t)))
 648             (let ((lets nil))
 649               (while (and loop-bindings
 650                           (not (cdar loop-bindings)))
 651                 (cl-push (car (cl-pop loop-bindings)) lets))
 652               (setq body (list (cl-loop-let lets body nil))))))
 653         (if loop-symbol-macs
 654             (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
 655         (list* 'block loop-name body)))))
 656
 657 (defun cl-parse-loop-clause ()   ; uses args, loop-*
 658   (let ((word (cl-pop args))
 659         (hash-types '(hash-key hash-keys hash-value hash-values))
 660         (key-types '(key-code key-codes key-seq key-seqs
 661                      key-binding key-bindings)))
 662     (cond
 663
 664      ((null args)
 665       (error "Malformed `loop' macro"))
 666
 667      ((eq word 'named)
 668       (setq loop-name (cl-pop args)))
 669
 670      ((eq word 'initially)
 671       (if (memq (car args) '(do doing)) (cl-pop args))
 672       (or (consp (car args)) (error "Syntax error on `initially' clause"))
 673       (while (consp (car args))
 674         (cl-push (cl-pop args) loop-initially)))
 675
 676      ((eq word 'finally)
 677       (if (eq (car args) 'return)
 678           (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
 679         (if (memq (car args) '(do doing)) (cl-pop args))
 680         (or (consp (car args)) (error "Syntax error on `finally' clause"))
 681         (if (and (eq (caar args) 'return) (null loop-name))
 682             (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil)))
 683           (while (consp (car args))
 684             (cl-push (cl-pop args) loop-finally)))))
 685
 686      ((memq word '(for as))
 687       (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
 688             (ands nil))
 689         (while
 690             (let ((var (or (cl-pop args) (gensym))))
 691               (setq word (cl-pop args))
 692               (if (eq word 'being) (setq word (cl-pop args)))
 693               (if (memq word '(the each)) (setq word (cl-pop args)))
 694               (if (memq word '(buffer buffers))
 695                   (setq word 'in args (cons '(buffer-list) args)))
 696               (cond
 697
 698                ((memq word '(from downfrom upfrom to downto upto
 699                              above below by))
 700                 (cl-push word args)
 701                 (if (memq (car args) '(downto above))
 702                     (error "Must specify `from' value for downward loop"))
 703                 (let* ((down (or (eq (car args) 'downfrom)
 704                                  (memq (caddr args) '(downto above))))
 705                        (excl (or (memq (car args) '(above below))
 706                                  (memq (caddr args) '(above below))))
 707                        (start (and (memq (car args) '(from upfrom downfrom))
 708                                    (cl-pop2 args)))
 709                        (end (and (memq (car args)
 710                                        '(to upto downto above below))
 711                                  (cl-pop2 args)))
 712                        (step (and (eq (car args) 'by) (cl-pop2 args)))
 713                        (end-var (and (not (cl-const-expr-p end)) (gensym)))
 714                        (step-var (and (not (cl-const-expr-p step))
 715                                       (gensym))))
 716                   (and step (numberp step) (<= step 0)
 717                        (error "Loop `by' value is not positive: %s" step))
 718                   (cl-push (list var (or start 0)) loop-for-bindings)
 719                   (if end-var (cl-push (list end-var end) loop-for-bindings))
 720                   (if step-var (cl-push (list step-var step)
 721                                         loop-for-bindings))
 722                   (if end
 723                       (cl-push (list
 724                                 (if down (if excl '> '>=) (if excl '< '<=))
 725                                 var (or end-var end)) loop-body))
 726                   (cl-push (list var (list (if down '- '+) var
 727                                            (or step-var step 1)))
 728                            loop-for-steps)))
 729
 730                ((memq word '(in in-ref on))
 731                 (let* ((on (eq word 'on))
 732                        (temp (if (and on (symbolp var)) var (gensym))))
 733                   (cl-push (list temp (cl-pop args)) loop-for-bindings)
 734                   (cl-push (list 'consp temp) loop-body)
 735                   (if (eq word 'in-ref)
 736                       (cl-push (list var (list 'car temp)) loop-symbol-macs)
 737                     (or (eq temp var)
 738                         (progn
 739                           (cl-push (list var nil) loop-for-bindings)
 740                           (cl-push (list var (if on temp (list 'car temp)))
 741                                    loop-for-sets))))
 742                   (cl-push (list temp
 743                                  (if (eq (car args) 'by)
 744                                      (let ((step (cl-pop2 args)))
 745                                        (if (and (memq (car-safe step)
 746                                                       '(quote function
 747                                                               function*))
 748                                                 (symbolp (nth 1 step)))
 749                                            (list (nth 1 step) temp)
 750                                          (list 'funcall step temp)))
 751                                    (list 'cdr temp)))
 752                            loop-for-steps)))
 753
 754                ((eq word '=)
 755                 (let* ((start (cl-pop args))
 756                        (then (if (eq (car args) 'then) (cl-pop2 args) start)))
 757                   (cl-push (list var nil) loop-for-bindings)
 758                   (if (or ands (eq (car args) 'and))
 759                       (progn
 760                         (cl-push (list var
 761                                        (list 'if
 762                                              (or loop-first-flag
 763                                                  (setq loop-first-flag
 764                                                        (gensym)))
 765                                              start var))
 766                                  loop-for-sets)
 767                         (cl-push (list var then) loop-for-steps))
 768                     (cl-push (list var
 769                                    (if (eq start then) start
 770                                      (list 'if
 771                                            (or loop-first-flag
 772                                                (setq loop-first-flag (gensym)))
 773                                            start then)))
 774                              loop-for-sets))))
 775
 776                ((memq word '(across across-ref))
 777                 (let ((temp-vec (gensym)) (temp-idx (gensym)))
 778                   (cl-push (list temp-vec (cl-pop args)) loop-for-bindings)
 779                   (cl-push (list temp-idx -1) loop-for-bindings)
 780                   (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx))
 781                                  (list 'length temp-vec)) loop-body)
 782                   (if (eq word 'across-ref)
 783                       (cl-push (list var (list 'aref temp-vec temp-idx))
 784                                loop-symbol-macs)
 785                     (cl-push (list var nil) loop-for-bindings)
 786                     (cl-push (list var (list 'aref temp-vec temp-idx))
 787                              loop-for-sets))))
 788
 789                ((memq word '(element elements))
 790                 (let ((ref (or (memq (car args) '(in-ref of-ref))
 791                                (and (not (memq (car args) '(in of)))
 792                                     (error "Expected `of'"))))
 793                       (seq (cl-pop2 args))
 794                       (temp-seq (gensym))
 795                       (temp-idx (if (eq (car args) 'using)
 796                                     (if (and (= (length (cadr args)) 2)
 797                                              (eq (caadr args) 'index))
 798                                         (cadr (cl-pop2 args))
 799                                       (error "Bad `using' clause"))
 800                                   (gensym))))
 801                   (cl-push (list temp-seq seq) loop-for-bindings)
 802                   (cl-push (list temp-idx 0) loop-for-bindings)
 803                   (if ref
 804                       (let ((temp-len (gensym)))
 805                         (cl-push (list temp-len (list 'length temp-seq))
 806                                  loop-for-bindings)
 807                         (cl-push (list var (list 'elt temp-seq temp-idx))
 808                                  loop-symbol-macs)
 809                         (cl-push (list '< temp-idx temp-len) loop-body))
 810                     (cl-push (list var nil) loop-for-bindings)
 811                     (cl-push (list 'and temp-seq
 812                                    (list 'or (list 'consp temp-seq)
 813                                          (list '< temp-idx
 814                                                (list 'length temp-seq))))
 815                              loop-body)
 816                     (cl-push (list var (list 'if (list 'consp temp-seq)
 817                                              (list 'pop temp-seq)
 818                                              (list 'aref temp-seq temp-idx)))
 819                              loop-for-sets))
 820                   (cl-push (list temp-idx (list '1+ temp-idx))
 821                            loop-for-steps)))
 822
 823                ((memq word hash-types)
 824                 (or (memq (car args) '(in of)) (error "Expected `of'"))
 825                 (let* ((table (cl-pop2 args))
 826                        (other (if (eq (car args) 'using)
 827                                   (if (and (= (length (cadr args)) 2)
 828                                            (memq (caadr args) hash-types)
 829                                            (not (eq (caadr args) word)))
 830                                       (cadr (cl-pop2 args))
 831                                     (error "Bad `using' clause"))
 832                                 (gensym))))
 833                   (if (memq word '(hash-value hash-values))
 834                       (setq var (prog1 other (setq other var))))
 835                   (setq loop-map-form
 836                         (list 'maphash (list 'function
 837                                              (list* 'lambda (list var other)
 838                                                     '--cl-map)) table))))
 839
 840                ((memq word '(symbol present-symbol external-symbol
 841                              symbols present-symbols external-symbols))
 842                 (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
 843                   (setq loop-map-form
 844                         (list 'mapatoms (list 'function
 845                                               (list* 'lambda (list var)
 846                                                      '--cl-map)) ob))))
 847
 848                ((memq word '(overlay overlays extent extents))
 849                 (let ((buf nil) (from nil) (to nil))
 850                   (while (memq (car args) '(in of from to))
 851                     (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
 852                           ((eq (car args) 'to) (setq to (cl-pop2 args)))
 853                           (t (setq buf (cl-pop2 args)))))
 854                   (setq loop-map-form
 855                         (list 'cl-map-extents
 856                               (list 'function (list 'lambda (list var (gensym))
 857                                                     '(progn . --cl-map) nil))
 858                               buf from to))))
 859
 860                ((memq word '(interval intervals))
 861                 (let ((buf nil) (prop nil) (from nil) (to nil)
 862                       (var1 (gensym)) (var2 (gensym)))
 863                   (while (memq (car args) '(in of property from to))
 864                     (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
 865                           ((eq (car args) 'to) (setq to (cl-pop2 args)))
 866                           ((eq (car args) 'property)
 867                            (setq prop (cl-pop2 args)))
 868                           (t (setq buf (cl-pop2 args)))))
 869                   (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
 870                       (setq var1 (car var) var2 (cdr var))
 871                     (cl-push (list var (list 'cons var1 var2)) loop-for-sets))
 872                   (setq loop-map-form
 873                         (list 'cl-map-intervals
 874                               (list 'function (list 'lambda (list var1 var2)
 875                                                     '(progn . --cl-map)))
 876                               buf prop from to))))
 877
 878                ((memq word key-types)
 879                 (or (memq (car args) '(in of)) (error "Expected `of'"))
 880                 (let ((map (cl-pop2 args))
 881                       (other (if (eq (car args) 'using)
 882                                  (if (and (= (length (cadr args)) 2)
 883                                           (memq (caadr args) key-types)
 884                                           (not (eq (caadr args) word)))
 885                                      (cadr (cl-pop2 args))
 886                                    (error "Bad `using' clause"))
 887                                (gensym))))
 888                   (if (memq word '(key-binding key-bindings))
 889                       (setq var (prog1 other (setq other var))))
 890                   (setq loop-map-form
 891                         (list (if (memq word '(key-seq key-seqs))
 892                                   'cl-map-keymap-recursively 'cl-map-keymap)
 893                               (list 'function (list* 'lambda (list var other)
 894                                                      '--cl-map)) map))))
 895
 896                ((memq word '(frame frames screen screens))
 897                 (let ((temp (gensym)))
 898                   (cl-push (list var '(selected-frame))
 899                            loop-for-bindings)
 900                   (cl-push (list temp nil) loop-for-bindings)
 901                   (cl-push (list 'prog1 (list 'not (list 'eq var temp))
 902                                  (list 'or temp (list 'setq temp var)))
 903                            loop-body)
 904                   (cl-push (list var (list 'next-frame var))
 905                            loop-for-steps)))
 906
 907                ((memq word '(window windows))
 908                 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
 909                       (temp (gensym)))
 910                   (cl-push (list var (if scr
 911                                          (list 'frame-selected-window scr)
 912                                        '(selected-window)))
 913                            loop-for-bindings)
 914                   (cl-push (list temp nil) loop-for-bindings)
 915                   (cl-push (list 'prog1 (list 'not (list 'eq var temp))
 916                                  (list 'or temp (list 'setq temp var)))
 917                            loop-body)
 918                   (cl-push (list var (list 'next-window var)) loop-for-steps)))
 919
 920                (t
 921                 (let ((handler (and (symbolp word)
 922                                     (get word 'cl-loop-for-handler))))
 923                   (if handler
 924                       (funcall handler var)
 925                     (error "Expected a `for' preposition, found %s" word)))))
 926               (eq (car args) 'and))
 927           (setq ands t)
 928           (cl-pop args))
 929         (if (and ands loop-for-bindings)
 930             (cl-push (nreverse loop-for-bindings) loop-bindings)
 931           (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
 932                                      loop-bindings)))
 933         (if loop-for-sets
 934             (cl-push (list 'progn
 935                            (cl-loop-let (nreverse loop-for-sets) 'setq ands)
 936                            t) loop-body))
 937         (if loop-for-steps
 938             (cl-push (cons (if ands 'psetq 'setq)
 939                            (apply 'append (nreverse loop-for-steps)))
 940                      loop-steps))))
 941
 942      ((eq word 'repeat)
 943       (let ((temp (gensym)))
 944         (cl-push (list (list temp (cl-pop args))) loop-bindings)
 945         (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
 946
 947      ((eq word 'collect)
 948       (let ((what (cl-pop args))
 949             (var (cl-loop-handle-accum nil 'nreverse)))
 950         (if (eq var loop-accum-var)
 951             (cl-push (list 'progn (list 'push what var) t) loop-body)
 952           (cl-push (list 'progn
 953                          (list 'setq var (list 'nconc var (list 'list what)))
 954                          t) loop-body))))
 955
 956      ((memq word '(nconc nconcing append appending))
 957       (let ((what (cl-pop args))
 958             (var (cl-loop-handle-accum nil 'nreverse)))
 959         (cl-push (list 'progn
 960                        (list 'setq var
 961                              (if (eq var loop-accum-var)
 962                                  (list 'nconc
 963                                        (list (if (memq word '(nconc nconcing))
 964                                                  'nreverse 'reverse)
 965                                              what)
 966                                        var)
 967                                (list (if (memq word '(nconc nconcing))
 968                                          'nconc 'append)
 969                                      var what))) t) loop-body)))
 970
 971      ((memq word '(concat concating))
 972       (let ((what (cl-pop args))
 973             (var (cl-loop-handle-accum "")))
 974         (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body)))
 975
 976      ((memq word '(vconcat vconcating))
 977       (let ((what (cl-pop args))
 978             (var (cl-loop-handle-accum [])))
 979         (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
 980
 981      ((memq word '(sum summing))
 982       (let ((what (cl-pop args))
 983             (var (cl-loop-handle-accum 0)))
 984         (cl-push (list 'progn (list 'incf var what) t) loop-body)))
 985
 986      ((memq word '(count counting))
 987       (let ((what (cl-pop args))
 988             (var (cl-loop-handle-accum 0)))
 989         (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
 990
 991      ((memq word '(minimize minimizing maximize maximizing))
 992       (let* ((what (cl-pop args))
 993              (temp (if (cl-simple-expr-p what) what (gensym)))
 994              (var (cl-loop-handle-accum nil))
 995              (func (intern (substring (symbol-name word) 0 3)))
 996              (set (list 'setq var (list 'if var (list func var temp) temp))))
 997         (cl-push (list 'progn (if (eq temp what) set
 998                                 (list 'let (list (list temp what)) set))
 999                        t) loop-body)))
1000
1001      ((eq word 'with)
1002       (let ((bindings nil))
1003         (while (progn (cl-push (list (cl-pop args)
1004                                      (and (eq (car args) '=) (cl-pop2 args)))
1005                                bindings)
1006                       (eq (car args) 'and))
1007           (cl-pop args))
1008         (cl-push (nreverse bindings) loop-bindings)))
1009
1010      ((eq word 'while)
1011       (cl-push (cl-pop args) loop-body))
1012
1013      ((eq word 'until)
1014       (cl-push (list 'not (cl-pop args)) loop-body))
1015
1016      ((eq word 'always)
1017       (or loop-finish-flag (setq loop-finish-flag (gensym)))
1018       (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body)
1019       (setq loop-result t))
1020
1021      ((eq word 'never)
1022       (or loop-finish-flag (setq loop-finish-flag (gensym)))
1023       (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args)))
1024                loop-body)
1025       (setq loop-result t))
1026
1027      ((eq word 'thereis)
1028       (or loop-finish-flag (setq loop-finish-flag (gensym)))
1029       (or loop-result-var (setq loop-result-var (gensym)))
1030       (cl-push (list 'setq loop-finish-flag
1031                      (list 'not (list 'setq loop-result-var (cl-pop args))))
1032                loop-body))
1033
1034      ((memq word '(if when unless))
1035       (let* ((cond (cl-pop args))
1036              (then (let ((loop-body nil))
1037                      (cl-parse-loop-clause)
1038                      (cl-loop-build-ands (nreverse loop-body))))
1039              (else (let ((loop-body nil))
1040                      (if (eq (car args) 'else)
1041                          (progn (cl-pop args) (cl-parse-loop-clause)))
1042                      (cl-loop-build-ands (nreverse loop-body))))
1043              (simple (and (eq (car then) t) (eq (car else) t))))
1044         (if (eq (car args) 'end) (cl-pop args))
1045         (if (eq word 'unless) (setq then (prog1 else (setq else then))))
1046         (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
1047                           (if simple (nth 1 else) (list (nth 2 else))))))
1048           (if (cl-expr-contains form 'it)
1049               (let ((temp (gensym)))
1050                 (cl-push (list temp) loop-bindings)
1051                 (setq form (list* 'if (list 'setq temp cond)
1052                                   (subst temp 'it form))))
1053             (setq form (list* 'if cond form)))
1054           (cl-push (if simple (list 'progn form t) form) loop-body))))
1055
1056      ((memq word '(do doing))
1057       (let ((body nil))
1058         (or (consp (car args)) (error "Syntax error on `do' clause"))
1059         (while (consp (car args)) (cl-push (cl-pop args) body))
1060         (cl-push (cons 'progn (nreverse (cons t body))) loop-body)))
1061
1062      ((eq word 'return)
1063       (or loop-finish-flag (setq loop-finish-flag (gensym)))
1064       (or loop-result-var (setq loop-result-var (gensym)))
1065       (cl-push (list 'setq loop-result-var (cl-pop args)
1066                      loop-finish-flag nil) loop-body))
1067
1068      (t
1069       (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
1070         (or handler (error "Expected a loop keyword, found %s" word))
1071         (funcall handler))))
1072     (if (eq (car args) 'and)
1073         (progn (cl-pop args) (cl-parse-loop-clause)))))
1074
1075 (defun cl-loop-let (specs body par)   ; uses loop-*
1076   (let ((p specs) (temps nil) (new nil))
1077     (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
1078       (setq p (cdr p)))
1079     (and par p
1080          (progn
1081            (setq par nil p specs)
1082            (while p
1083              (or (cl-const-expr-p (cadar p))
1084                  (let ((temp (gensym)))
1085                    (cl-push (list temp (cadar p)) temps)
1086                    (setcar (cdar p) temp)))
1087              (setq p (cdr p)))))
1088     (while specs
1089       (if (and (consp (car specs)) (listp (caar specs)))
1090           (let* ((spec (caar specs)) (nspecs nil)
1091                  (expr (cadr (cl-pop specs)))
1092                  (temp (cdr (or (assq spec loop-destr-temps)
1093                                 (car (cl-push (cons spec (or (last spec 0)
1094                                                              (gensym)))
1095                                               loop-destr-temps))))))
1096             (cl-push (list temp expr) new)
1097             (while (consp spec)
1098               (cl-push (list (cl-pop spec)
1099                              (and expr (list (if spec 'pop 'car) temp)))
1100                        nspecs))
1101             (setq specs (nconc (nreverse nspecs) specs)))
1102         (cl-push (cl-pop specs) new)))
1103     (if (eq body 'setq)
1104         (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
1105           (if temps (list 'let* (nreverse temps) set) set))
1106       (list* (if par 'let 'let*)
1107              (nconc (nreverse temps) (nreverse new)) body))))
1108
1109 (defun cl-loop-handle-accum (def &optional func)   ; uses args, loop-*
1110   (if (eq (car args) 'into)
1111       (let ((var (cl-pop2 args)))
1112         (or (memq var loop-accum-vars)
1113             (progn (cl-push (list (list var def)) loop-bindings)
1114                    (cl-push var loop-accum-vars)))
1115         var)
1116     (or loop-accum-var
1117         (progn
1118           (cl-push (list (list (setq loop-accum-var (gensym)) def))
1119                    loop-bindings)
1120           (setq loop-result (if func (list func loop-accum-var)
1121                               loop-accum-var))
1122           loop-accum-var))))
1123
1124 (defun cl-loop-build-ands (clauses)
1125   (let ((ands nil)
1126         (body nil))
1127     (while clauses
1128       (if (and (eq (car-safe (car clauses)) 'progn)
1129                (eq (car (last (car clauses))) t))
1130           (if (cdr clauses)
1131               (setq clauses (cons (nconc (butlast (car clauses))
1132                                          (if (eq (car-safe (cadr clauses))
1133                                                  'progn)
1134                                              (cdadr clauses)
1135                                            (list (cadr clauses))))
1136                                   (cddr clauses)))
1137             (setq body (cdr (butlast (cl-pop clauses)))))
1138         (cl-push (cl-pop clauses) ands)))
1139     (setq ands (or (nreverse ands) (list t)))
1140     (list (if (cdr ands) (cons 'and ands) (car ands))
1141           body
1142           (let ((full (if body
1143                           (append ands (list (cons 'progn (append body '(t)))))
1144                         ands)))
1145             (if (cdr full) (cons 'and full) (car full))))))
1146
1147
1148 ;;; Other iteration control structures.
1149
1150 ;;;###autoload
1151 (defmacro do (steps endtest &rest body)
1152   "The Common Lisp `do' loop.
1153 Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1154   (cl-expand-do-loop steps endtest body nil))
1155
1156 ;;;###autoload
1157 (defmacro do* (steps endtest &rest body)
1158   "The Common Lisp `do*' loop.
1159 Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1160   (cl-expand-do-loop steps endtest body t))
1161
1162 (defun cl-expand-do-loop (steps endtest body star)
1163   (list 'block nil
1164         (list* (if star 'let* 'let)
1165                (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
1166                        steps)
1167                (list* 'while (list 'not (car endtest))
1168                       (append body
1169                               (let ((sets (mapcar
1170                                            #'(lambda (c)
1171                                                (and (consp c) (cdr (cdr c))
1172                                                     (list (car c) (nth 2 c))))
1173                                            steps)))
1174                                 (setq sets (delq nil sets))
1175                                 (and sets
1176                                      (list (cons (if (or star (not (cdr sets)))
1177                                                      'setq 'psetq)
1178                                                  (apply 'append sets)))))))
1179                (or (cdr endtest) '(nil)))))
1180
1181 ;;;###autoload
1182 (defmacro dolist (spec &rest body)
1183   "(dolist (VAR LIST [RESULT]) BODY...): loop over a list.
1184 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1185 Then evaluate RESULT to get return value, default nil."
1186   (let ((temp (gensym "--dolist-temp--")))
1187     (list 'block nil
1188           (list* 'let (list (list temp (nth 1 spec)) (car spec))
1189                  (list* 'while temp (list 'setq (car spec) (list 'car temp))
1190                         (append body (list (list 'setq temp
1191                                                  (list 'cdr temp)))))
1192                  (if (cdr (cdr spec))
1193                      (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
1194                    '(nil))))))
1195
1196 ;;;###autoload
1197 (defmacro dotimes (spec &rest body)
1198   "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times.
1199 Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1200 to COUNT, exclusive.  Then evaluate RESULT to get return value, default
1201 nil."
1202   (let ((temp (gensym "--dotimes-temp--")))
1203     (list 'block nil
1204           (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
1205                  (list* 'while (list '< (car spec) temp)
1206                         (append body (list (list 'incf (car spec)))))
1207                  (or (cdr (cdr spec)) '(nil))))))
1208
1209 ;;;###autoload
1210 (defmacro do-symbols (spec &rest body)
1211   "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols.
1212 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1213 from OBARRAY."
1214   ;; Apparently this doesn't have an implicit block.
1215   (list 'block nil
1216         (list 'let (list (car spec))
1217               (list* 'mapatoms
1218                      (list 'function (list* 'lambda (list (car spec)) body))
1219                      (and (cadr spec) (list (cadr spec))))
1220               (caddr spec))))
1221
1222 ;;;###autoload
1223 (defmacro do-all-symbols (spec &rest body)
1224   (list* 'do-symbols (list (car spec) nil (cadr spec)) body))
1225
1226
1227 ;;; Assignments.
1228
1229 ;;;###autoload
1230 (defmacro psetq (&rest args)
1231   "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel.
1232 This is like `setq', except that all VAL forms are evaluated (in order)
1233 before assigning any symbols SYM to the corresponding values."
1234   (cons 'psetf args))
1235
1236
1237 ;;; Binding control structures.
1238
1239 ;;;###autoload
1240 (defmacro progv (symbols values &rest body)
1241   "(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY.
1242 The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
1243 Each SYMBOL in the first list is bound to the corresponding VALUE in the
1244 second list (or made unbound if VALUES is shorter than SYMBOLS); then the
1245 BODY forms are executed and their result is returned.  This is much like
1246 a `let' form, except that the list of symbols can be computed at run-time."
1247   (list 'let '((cl-progv-save nil))
1248         (list 'unwind-protect
1249               (list* 'progn (list 'cl-progv-before symbols values) body)
1250               '(cl-progv-after))))
1251
1252 ;;; This should really have some way to shadow 'byte-compile properties, etc.
1253 ;;;###autoload
1254 (defmacro flet (bindings &rest body)
1255   "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns.
1256 This is an analogue of `let' that operates on the function cell of FUNC
1257 rather than its value cell.  The FORMs are evaluated with the specified
1258 function definitions in place, then the definitions are undone (the FUNCs
1259 go back to their previous definitions, or lack thereof)."
1260   (list* 'letf*
1261          (mapcar
1262           #'(lambda (x)
1263               (if (or (and (fboundp (car x))
1264                            (eq (car-safe (symbol-function (car x))) 'macro))
1265                       (cdr (assq (car x) cl-macro-environment)))
1266                   (error "Use `labels', not `flet', to rebind macro names"))
1267               (let ((func (list 'function*
1268                                 (list 'lambda (cadr x)
1269                                       (list* 'block (car x) (cddr x))))))
1270                 (if (and (cl-compiling-file)
1271                          (boundp 'byte-compile-function-environment))
1272                     (cl-push (cons (car x) (eval func))
1273                              byte-compile-function-environment))
1274                 (list (list 'symbol-function (list 'quote (car x))) func)))
1275           bindings)
1276          body))
1277
1278 ;;;###autoload
1279 (defmacro labels (bindings &rest body)
1280   "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.
1281 This is like `flet', except the bindings are lexical instead of dynamic.
1282 Unlike `flet', this macro is fully compliant with the Common Lisp standard."
1283   (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1284     (while bindings
1285       (let ((var (gensym)))
1286         (cl-push var vars)
1287         (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)
1288         (cl-push var sets)
1289         (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args)
1290                        (list 'list* '(quote funcall) (list 'quote var)
1291                              'cl-labels-args))
1292                  cl-macro-environment)))
1293     (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
1294                         cl-macro-environment)))
1295
1296 ;; The following ought to have a better definition for use with newer
1297 ;; byte compilers.
1298 ;;;###autoload
1299 (defmacro macrolet (bindings &rest body)
1300   "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.
1301 This is like `flet', but for macros instead of functions."
1302   (if (cdr bindings)
1303       (list 'macrolet
1304             (list (car bindings)) (list* 'macrolet (cdr bindings) body))
1305     (if (null bindings) (cons 'progn body)
1306       (let* ((name (caar bindings))
1307              (res (cl-transform-lambda (cdar bindings) name)))
1308         (eval (car res))
1309         (cl-macroexpand-all (cons 'progn body)
1310                             (cons (list* name 'lambda (cdr res))
1311                                   cl-macro-environment))))))
1312
1313 ;;;###autoload
1314 (defmacro symbol-macrolet (bindings &rest body)
1315   "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns.
1316 Within the body FORMs, references to the variable NAME will be replaced
1317 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
1318   (if (cdr bindings)
1319       (list 'symbol-macrolet
1320             (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
1321     (if (null bindings) (cons 'progn body)
1322       (cl-macroexpand-all (cons 'progn body)
1323                           (cons (list (symbol-name (caar bindings))
1324                                       (cadar bindings))
1325                                 cl-macro-environment)))))
1326
1327 (defvar cl-closure-vars nil)
1328 ;;;###autoload
1329 (defmacro lexical-let (bindings &rest body)
1330   "(lexical-let BINDINGS BODY...): like `let', but lexically scoped.
1331 The main visible difference is that lambdas inside BODY will create
1332 lexical closures as in Common Lisp."
1333   (let* ((cl-closure-vars cl-closure-vars)
1334          (vars (mapcar #'(lambda (x)
1335                            (or (consp x) (setq x (list x)))
1336                            (cl-push (gensym (format "--%s--" (car x)))
1337                                     cl-closure-vars)
1338                            (list (car x) (cadr x) (car cl-closure-vars)))
1339                        bindings))
1340          (ebody
1341           (cl-macroexpand-all
1342            (cons 'progn body)
1343            (nconc (mapcar #'(lambda (x)
1344                               (list (symbol-name (car x))
1345                                     (list 'symbol-value (caddr x))
1346                                     t))
1347                           vars)
1348                   (list '(defun . cl-defun-expander))
1349                   cl-macro-environment))))
1350     (if (not (get (car (last cl-closure-vars)) 'used))
1351         (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
1352               (sublis (mapcar #'(lambda (x)
1353                                   (cons (caddr x) (list 'quote (caddr x))))
1354                               vars)
1355                       ebody))
1356       (list 'let (mapcar #'(lambda (x)
1357                              (list (caddr x)
1358                                    (list 'make-symbol
1359                                          (format "--%s--" (car x)))))
1360                          vars)
1361             (apply 'append '(setf)
1362                    (mapcar #'(lambda (x)
1363                                (list (list 'symbol-value (caddr x)) (cadr x)))
1364                            vars))
1365             ebody))))
1366
1367 ;;;###autoload
1368 (defmacro lexical-let* (bindings &rest body)
1369   "(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped.
1370 The main visible difference is that lambdas inside BODY will create
1371 lexical closures as in Common Lisp."
1372   (if (null bindings) (cons 'progn body)
1373     (setq bindings (reverse bindings))
1374     (while bindings
1375       (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body))))
1376     (car body)))
1377
1378 (defun cl-defun-expander (func &rest rest)
1379   (list 'progn
1380         (list 'defalias (list 'quote func)
1381               (list 'function (cons 'lambda rest)))
1382         (list 'quote func)))
1383
1384
1385 ;;; Multiple values.
1386
1387 ;;;###autoload
1388 (defmacro multiple-value-bind (vars form &rest body)
1389   "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values.
1390 FORM must return a list; the BODY is then executed with the first N elements
1391 of this list bound (`let'-style) to each of the symbols SYM in turn.  This
1392 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
1393 simulate true multiple return values.  For compatibility, (values A B C) is
1394 a synonym for (list A B C)."
1395   (let ((temp (gensym)) (n -1))
1396     (list* 'let* (cons (list temp form)
1397                        (mapcar #'(lambda (v)
1398                                    (list v (list 'nth (setq n (1+ n)) temp)))
1399                                vars))
1400            body)))
1401
1402 ;;;###autoload
1403 (defmacro multiple-value-setq (vars form)
1404   "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values.
1405 FORM must return a list; the first N elements of this list are stored in
1406 each of the symbols SYM in turn.  This is analogous to the Common Lisp
1407 `multiple-value-setq' macro, using lists to simulate true multiple return
1408 values.  For compatibility, (values A B C) is a synonym for (list A B C)."
1409   (cond ((null vars) (list 'progn form nil))
1410         ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1411         (t
1412          (let* ((temp (gensym)) (n 0))
1413            (list 'let (list (list temp form))
1414                  (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp))
1415                        (cons 'setq
1416                              (apply 'nconc
1417                                     (mapcar
1418                                      #'(lambda (v)
1419                                          (list v (list
1420                                                   'nth
1421                                                   (setq n (1+ n))
1422                                                   temp)))
1423                                             vars)))))))))
1424
1425
1426 ;;; Declarations.
1427
1428 ;;;###autoload
1429 (defmacro locally (&rest body) (cons 'progn body))
1430 ;;;###autoload
1431 (defmacro the (type form) form)
1432
1433 (defvar cl-proclaim-history t)    ; for future compilers
1434 (defvar cl-declare-stack t)       ; for future compilers
1435
1436 (defun cl-do-proclaim (spec hist)
1437   (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))
1438   (cond ((eq (car-safe spec) 'special)
1439          (if (boundp 'byte-compile-bound-variables)
1440              (setq byte-compile-bound-variables
1441                    ;; todo: this should compute correct binding bits vs. 0
1442                    (append (mapcar #'(lambda (v) (cons v 0))
1443                                    (cdr spec))
1444                            byte-compile-bound-variables))))
1445
1446         ((eq (car-safe spec) 'inline)
1447          (while (setq spec (cdr spec))
1448            (or (memq (get (car spec) 'byte-optimizer)
1449                      '(nil byte-compile-inline-expand))
1450                (error "%s already has a byte-optimizer, can't make it inline"
1451                       (car spec)))
1452            (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
1453
1454         ((eq (car-safe spec) 'notinline)
1455          (while (setq spec (cdr spec))
1456            (if (eq (get (car spec) 'byte-optimizer)
1457                    'byte-compile-inline-expand)
1458                (put (car spec) 'byte-optimizer nil))))
1459
1460         ((eq (car-safe spec) 'optimize)
1461          (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
1462                             '((0 nil) (1 t) (2 t) (3 t))))
1463                (safety (assq (nth 1 (assq 'safety (cdr spec)))
1464                              '((0 t) (1 t) (2 t) (3 nil)))))
1465            (if speed (setq cl-optimize-speed (car speed)
1466                            byte-optimize (nth 1 speed)))
1467            (if safety (setq cl-optimize-safety (car safety)
1468                             byte-compile-delete-errors (nth 1 safety)))))
1469
1470         ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
1471          (if (eq byte-compile-warnings t)
1472              ;; XEmacs change
1473              (setq byte-compile-warnings byte-compile-default-warnings))
1474          (while (setq spec (cdr spec))
1475            (if (consp (car spec))
1476                (if (eq (cadar spec) 0)
1477                    (setq byte-compile-warnings
1478                          (delq (caar spec) byte-compile-warnings))
1479                  (setq byte-compile-warnings
1480                        (adjoin (caar spec) byte-compile-warnings)))))))
1481   nil)
1482
1483 ;;; Process any proclamations made before cl-macs was loaded.
1484 (defvar cl-proclaims-deferred)
1485 (let ((p (reverse cl-proclaims-deferred)))
1486   (while p (cl-do-proclaim (cl-pop p) t))
1487   (setq cl-proclaims-deferred nil))
1488
1489 ;;;###autoload
1490 (defmacro declare (&rest specs)
1491   (if (cl-compiling-file)
1492       (while specs
1493         (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack))
1494         (cl-do-proclaim (cl-pop specs) nil)))
1495   nil)
1496
1497
1498
1499 ;;; Generalized variables.
1500
1501 ;;;###autoload
1502 (defmacro define-setf-method (func args &rest body)
1503   "(define-setf-method NAME ARGLIST BODY...): define a `setf' method.
1504 This method shows how to handle `setf's to places of the form (NAME ARGS...).
1505 The argument forms ARGS are bound according to ARGLIST, as if NAME were
1506 going to be expanded as a macro, then the BODY forms are executed and must
1507 return a list of five elements: a temporary-variables list, a value-forms
1508 list, a store-variables list (of length one), a store-form, and an access-
1509 form.  See `defsetf' for a simpler way to define most setf-methods."
1510   (append '(eval-when (compile load eval))
1511           (if (stringp (car body))
1512               (list (list 'put (list 'quote func) '(quote setf-documentation)
1513                           (cl-pop body))))
1514           (list (cl-transform-function-property
1515                  func 'setf-method (cons args body)))))
1516
1517 ;;;###autoload
1518 (defmacro defsetf (func arg1 &rest args)
1519   "(defsetf NAME FUNC): define a `setf' method.
1520 This macro is an easy-to-use substitute for `define-setf-method' that works
1521 well for simple place forms.  In the simple `defsetf' form, `setf's of
1522 the form (setf (NAME ARGS...) VAL) are transformed to function or macro
1523 calls of the form (FUNC ARGS... VAL).  Example: (defsetf aref aset).
1524 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
1525 Here, the above `setf' call is expanded by binding the argument forms ARGS
1526 according to ARGLIST, binding the value form VAL to STORE, then executing
1527 BODY, which must return a Lisp form that does the necessary `setf' operation.
1528 Actually, ARGLIST and STORE may be bound to temporary variables which are
1529 introduced automatically to preserve proper execution order of the arguments.
1530 Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
1531   (if (listp arg1)
1532       (let* ((largs nil) (largsr nil)
1533              (temps nil) (tempsr nil)
1534              (restarg nil) (rest-temps nil)
1535              (store-var (car (prog1 (car args) (setq args (cdr args)))))
1536              (store-temp (intern (format "--%s--temp--" store-var)))
1537              (lets1 nil) (lets2 nil)
1538              (docstr nil) (p arg1))
1539         (if (stringp (car args))
1540             (setq docstr (prog1 (car args) (setq args (cdr args)))))
1541         (while (and p (not (eq (car p) '&aux)))
1542           (if (eq (car p) '&rest)
1543               (setq p (cdr p) restarg (car p))
1544             (or (memq (car p) '(&optional &key &allow-other-keys))
1545                 (setq largs (cons (if (consp (car p)) (car (car p)) (car p))
1546                                   largs)
1547                       temps (cons (intern (format "--%s--temp--" (car largs)))
1548                                   temps))))
1549           (setq p (cdr p)))
1550         (setq largs (nreverse largs) temps (nreverse temps))
1551         (if restarg
1552             (setq largsr (append largs (list restarg))
1553                   rest-temps (intern (format "--%s--temp--" restarg))
1554                   tempsr (append temps (list rest-temps)))
1555           (setq largsr largs tempsr temps))
1556         (let ((p1 largs) (p2 temps))
1557           (while p1
1558             (setq lets1 (cons (list (car p2)
1559                                     (list 'gensym (format "--%s--" (car p1))))
1560                               lets1)
1561                   lets2 (cons (list (car p1) (car p2)) lets2)
1562                   p1 (cdr p1) p2 (cdr p2))))
1563         (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
1564         (append (list 'define-setf-method func arg1)
1565                 (and docstr (list docstr))
1566                 (list
1567                  (list 'let*
1568                        (nreverse
1569                         (cons (list store-temp
1570                                     (list 'gensym (format "--%s--" store-var)))
1571                               (if restarg
1572                                   (append
1573                                    (list
1574                                     (list rest-temps
1575                                           (list 'mapcar '(quote gensym)
1576                                                 restarg)))
1577                                    lets1)
1578                                 lets1)))
1579                        (list 'list  ; 'values
1580                              (cons (if restarg 'list* 'list) tempsr)
1581                              (cons (if restarg 'list* 'list) largsr)
1582                              (list 'list store-temp)
1583                              (cons 'let*
1584                                    (cons (nreverse
1585                                           (cons (list store-var store-temp)
1586                                                 lets2))
1587                                          args))
1588                              (cons (if restarg 'list* 'list)
1589                                    (cons (list 'quote func) tempsr)))))))
1590     (list 'defsetf func '(&rest args) '(store)
1591           (let ((call (list 'cons (list 'quote arg1)
1592                             '(append args (list store)))))
1593             (if (car args)
1594                 (list 'list '(quote progn) call 'store)
1595               call)))))
1596
1597 ;;; Some standard place types from Common Lisp.
1598 (eval-when-compile (defvar ignored-arg)) ; Warning suppression
1599 (defsetf aref aset)
1600 (defsetf car setcar)
1601 (defsetf cdr setcdr)
1602 (defsetf elt (seq n) (store)
1603   (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
1604         (list 'aset seq n store)))
1605 (defsetf get (x y &optional ignored-arg) (store) (list 'put x y store))
1606 (defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store))
1607 (defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h))
1608 (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
1609 (defsetf subseq (seq start &optional end) (new)
1610   (list 'progn (list 'replace seq new ':start1 start ':end1 end) new))
1611 (defsetf symbol-function fset)
1612 (defsetf symbol-plist setplist)
1613 (defsetf symbol-value set)
1614
1615 ;;; Various car/cdr aliases.  Note that `cadr' is handled specially.
1616 (defsetf first setcar)
1617 (defsetf second (x) (store) (list 'setcar (list 'cdr x) store))
1618 (defsetf third (x) (store) (list 'setcar (list 'cddr x) store))
1619 (defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store))
1620 (defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store))
1621 (defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store))
1622 (defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store))
1623 (defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store))
1624 (defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store))
1625 (defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store))
1626 (defsetf rest setcdr)
1627
1628 ;;; Some more Emacs-related place types.
1629 (defsetf buffer-file-name set-visited-file-name t)
1630 (defsetf buffer-modified-p set-buffer-modified-p t)
1631 (defsetf buffer-name rename-buffer t)
1632 (defsetf buffer-string () (store)
1633   (list 'progn '(erase-buffer) (list 'insert store)))
1634 (defsetf buffer-substring cl-set-buffer-substring)
1635 (defsetf current-buffer set-buffer)
1636 (defsetf current-case-table set-case-table)
1637 (defsetf current-column move-to-column t)
1638 (defsetf current-global-map use-global-map t)
1639 (defsetf current-input-mode () (store)
1640   (list 'progn (list 'apply 'set-input-mode store) store))
1641 (defsetf current-local-map use-local-map t)
1642 (defsetf current-window-configuration set-window-configuration t)
1643 (defsetf default-file-modes set-default-file-modes t)
1644 (defsetf default-value set-default)
1645 (defsetf documentation-property put)
1646 (defsetf extent-face set-extent-face)
1647 (defsetf extent-priority set-extent-priority)
1648 (defsetf extent-property (x y &optional ignored-arg) (arg)
1649   (list 'set-extent-property x y arg))
1650 (defsetf extent-end-position (ext) (store)
1651   (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
1652                      store) store))
1653 (defsetf extent-start-position (ext) (store)
1654   (list 'progn (list 'set-extent-endpoints store
1655                      (list 'extent-end-position ext)) store))
1656 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
1657 (defsetf face-background-pixmap (f &optional s) (x)
1658   (list 'set-face-background-pixmap f x s))
1659 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
1660 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
1661 (defsetf face-underline-p (f &optional s) (x)
1662   (list 'set-face-underline-p f x s))
1663 (defsetf file-modes set-file-modes t)
1664 (defsetf frame-parameters modify-frame-parameters t)
1665 (defsetf frame-visible-p cl-set-frame-visible-p)
1666 (defsetf frame-properties (&optional f) (p)
1667   `(progn (set-frame-properties ,f ,p) ,p))
1668 (defsetf frame-property (f p &optional ignored-arg) (v)
1669   `(progn (set-frame-property ,f ,v) ,p))
1670 (defsetf frame-width (&optional f) (v)
1671   `(progn (set-frame-width ,f ,v) ,v))
1672 (defsetf frame-height (&optional f) (v)
1673   `(progn (set-frame-height ,f ,v) ,v))
1674 (defsetf current-frame-configuration set-frame-configuration)
1675
1676 ;; XEmacs: new stuff
1677 ;; Consoles
1678 (defsetf selected-console select-console t)
1679 (defsetf selected-device select-device t)
1680 (defsetf device-baud-rate (&optional d) (v)
1681   `(set-device-baud-rate ,d ,v))
1682 ;; This setf method is a bad idea, because set-specifier *adds* a
1683 ;; specification, rather than just setting it.  The net effect is that
1684 ;; it makes specifier-instance return VAL, but other things don't work
1685 ;; as expected -- letf, to name one.
1686 ;(defsetf specifier-instance (spec &optional dom def nof) (val)
1687 ;  `(set-specifier ,spec ,val ,dom))
1688
1689 ;; Annotations
1690 (defsetf annotation-glyph set-annotation-glyph)
1691 (defsetf annotation-down-glyph set-annotation-down-glyph)
1692 (defsetf annotation-face set-annotation-face)
1693 (defsetf annotation-layout set-annotation-layout)
1694 (defsetf annotation-data set-annotation-data)
1695 (defsetf annotation-action set-annotation-action)
1696 (defsetf annotation-menu set-annotation-menu)
1697 ;; Widget
1698 (defsetf widget-get widget-put t)
1699 (defsetf widget-value widget-value-set t)
1700
1701 ;; Misc
1702 (defsetf recent-keys-ring-size set-recent-keys-ring-size)
1703 (defsetf symbol-value-in-buffer (s b &optional ignored-arg) (store)
1704   `(with-current-buffer ,b (set ,s ,store)))
1705 (defsetf symbol-value-in-console (s c &optional ignored-arg) (store)
1706   `(letf (((selected-console) ,c))
1707      (set ,s ,store)))
1708
1709 (defsetf buffer-dedicated-frame (&optional b) (v)
1710   `(set-buffer-dedicated-frame ,b ,v))
1711 (defsetf console-type-image-conversion-list
1712   set-console-type-image-conversion-list)
1713 (defsetf default-toolbar-position set-default-toolbar-position)
1714 (defsetf device-class (&optional d) (v)
1715   `(set-device-class ,d ,v))
1716 (defsetf extent-begin-glyph set-extent-begin-glyph)
1717 (defsetf extent-begin-glyph-layout set-extent-begin-glyph-layout)
1718 (defsetf extent-end-glyph set-extent-end-glyph)
1719 (defsetf extent-end-glyph-layout set-extent-end-glyph-layout)
1720 (defsetf extent-keymap set-extent-keymap)
1721 (defsetf extent-parent set-extent-parent)
1722 (defsetf extent-properties set-extent-properties)
1723 ;; Avoid adding various face and glyph functions.
1724 (defsetf frame-selected-window (&optional f) (v)
1725   `(set-frame-selected-window ,f ,v))
1726 (defsetf glyph-image (glyph &optional domain) (i)
1727   (list 'set-glyph-image glyph i domain))
1728 (defsetf itimer-function set-itimer-function)
1729 (defsetf itimer-function-arguments set-itimer-function-arguments)
1730 (defsetf itimer-is-idle set-itimer-is-idle)
1731 (defsetf itimer-recorded-run-time set-itimer-recorded-run-time)
1732 (defsetf itimer-restart set-itimer-restart)
1733 (defsetf itimer-uses-arguments set-itimer-uses-arguments)
1734 (defsetf itimer-value set-itimer-value)
1735 (defsetf keymap-parents set-keymap-parents)
1736 (defsetf marker-insertion-type set-marker-insertion-type)
1737 (defsetf mouse-pixel-position (&optional d) (v)
1738   `(progn
1739      (set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)))
1740      ,v))
1741 (defsetf trunc-stack-length set-trunc-stack-length)
1742 (defsetf trunc-stack-stack set-trunc-stack-stack)
1743 (defsetf undoable-stack-max set-undoable-stack-max)
1744 (defsetf weak-list-list set-weak-list-list)
1745
1746
1747 (defsetf getenv setenv t)
1748 (defsetf get-register set-register)
1749 (defsetf global-key-binding global-set-key)
1750 (defsetf keymap-parent set-keymap-parent)
1751 (defsetf keymap-name set-keymap-name)
1752 (defsetf keymap-prompt set-keymap-prompt)
1753 (defsetf keymap-default-binding set-keymap-default-binding)
1754 (defsetf local-key-binding local-set-key)
1755 (defsetf mark set-mark t)
1756 (defsetf mark-marker set-mark t)
1757 (defsetf marker-position set-marker t)
1758 (defsetf match-data store-match-data t)
1759 (defsetf mouse-position (scr) (store)
1760   (list 'set-mouse-position scr (list 'car store) (list 'cadr store)
1761         (list 'cddr store)))
1762 (defsetf overlay-get overlay-put)
1763 (defsetf overlay-start (ov) (store)
1764   (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store))
1765 (defsetf overlay-end (ov) (store)
1766   (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store))
1767 (defsetf point goto-char)
1768 (defsetf point-marker goto-char t)
1769 (defsetf point-max () (store)
1770   (list 'progn (list 'narrow-to-region '(point-min) store) store))
1771 (defsetf point-min () (store)
1772   (list 'progn (list 'narrow-to-region store '(point-max)) store))
1773 (defsetf process-buffer set-process-buffer)
1774 (defsetf process-filter set-process-filter)
1775 (defsetf process-sentinel set-process-sentinel)
1776 (defsetf read-mouse-position (scr) (store)
1777   (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
1778 (defsetf selected-window select-window)
1779 (defsetf selected-frame select-frame)
1780 (defsetf standard-case-table set-standard-case-table)
1781 (defsetf syntax-table set-syntax-table)
1782 (defsetf visited-file-modtime set-visited-file-modtime t)
1783 (defsetf window-buffer set-window-buffer t)
1784 (defsetf window-display-table set-window-display-table t)
1785 (defsetf window-dedicated-p set-window-dedicated-p t)
1786 (defsetf window-height (&optional window) (store)
1787   `(progn (enlarge-window (- ,store (window-height)) nil ,window) ,store))
1788 (defsetf window-hscroll set-window-hscroll)
1789 (defsetf window-point set-window-point)
1790 (defsetf window-start set-window-start)
1791 (defsetf window-width (&optional window) (store)
1792   `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store))
1793 (defsetf x-get-cutbuffer x-store-cutbuffer t)
1794 (defsetf x-get-cut-buffer x-store-cut-buffer t)   ; groan.
1795 (defsetf x-get-secondary-selection x-own-secondary-selection t)
1796 (defsetf x-get-selection x-own-selection t)
1797
1798 ;;; More complex setf-methods.
1799 ;;; These should take &environment arguments, but since full arglists aren't
1800 ;;; available while compiling cl-macs, we fake it by referring to the global
1801 ;;; variable cl-macro-environment directly.
1802
1803 (define-setf-method apply (func arg1 &rest rest)
1804   (or (and (memq (car-safe func) '(quote function function*))
1805            (symbolp (car-safe (cdr-safe func))))
1806       (error "First arg to apply in setf is not (function SYM): %s" func))
1807   (let* ((form (cons (nth 1 func) (cons arg1 rest)))
1808          (method (get-setf-method form cl-macro-environment)))
1809     (list (car method) (nth 1 method) (nth 2 method)
1810           (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
1811           (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
1812
1813 (defun cl-setf-make-apply (form func temps)
1814   (if (eq (car form) 'progn)
1815       (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form))
1816     (or (equal (last form) (last temps))
1817         (error "%s is not suitable for use with setf-of-apply" func))
1818     (list* 'apply (list 'quote (car form)) (cdr form))))
1819
1820 (define-setf-method nthcdr (n place)
1821   (let ((method (get-setf-method place cl-macro-environment))
1822         (n-temp (gensym "--nthcdr-n--"))
1823         (store-temp (gensym "--nthcdr-store--")))
1824     (list (cons n-temp (car method))
1825           (cons n (nth 1 method))
1826           (list store-temp)
1827           (list 'let (list (list (car (nth 2 method))
1828                                  (list 'cl-set-nthcdr n-temp (nth 4 method)
1829                                        store-temp)))
1830                 (nth 3 method) store-temp)
1831           (list 'nthcdr n-temp (nth 4 method)))))
1832
1833 (define-setf-method getf (place tag &optional def)
1834   (let ((method (get-setf-method place cl-macro-environment))
1835         (tag-temp (gensym "--getf-tag--"))
1836         (def-temp (gensym "--getf-def--"))
1837         (store-temp (gensym "--getf-store--")))
1838     (list (append (car method) (list tag-temp def-temp))
1839           (append (nth 1 method) (list tag def))
1840           (list store-temp)
1841           (list 'let (list (list (car (nth 2 method))
1842                                  (list 'cl-set-getf (nth 4 method)
1843                                        tag-temp store-temp)))
1844                 (nth 3 method) store-temp)
1845           (list 'getf (nth 4 method) tag-temp def-temp))))
1846
1847 (define-setf-method substring (place from &optional to)
1848   (let ((method (get-setf-method place cl-macro-environment))
1849         (from-temp (gensym "--substring-from--"))
1850         (to-temp (gensym "--substring-to--"))
1851         (store-temp (gensym "--substring-store--")))
1852     (list (append (car method) (list from-temp to-temp))
1853           (append (nth 1 method) (list from to))
1854           (list store-temp)
1855           (list 'let (list (list (car (nth 2 method))
1856                                  (list 'cl-set-substring (nth 4 method)
1857                                        from-temp to-temp store-temp)))
1858                 (nth 3 method) store-temp)
1859           (list 'substring (nth 4 method) from-temp to-temp))))
1860
1861 (define-setf-method values (&rest args)
1862   (let ((methods (mapcar #'(lambda (x)
1863                              (get-setf-method x cl-macro-environment))
1864                          args))
1865         (store-temp (gensym "--values-store--")))
1866     (list (apply 'append (mapcar 'first methods))
1867           (apply 'append (mapcar 'second methods))
1868           (list store-temp)
1869           (cons 'list
1870                 (mapcar #'(lambda (m)
1871                             (cl-setf-do-store (cons (car (third m)) (fourth m))
1872                                               (list 'pop store-temp)))
1873                         methods))
1874           (cons 'list (mapcar 'fifth methods)))))
1875
1876 ;;; Getting and optimizing setf-methods.
1877 ;;;###autoload
1878 (defun get-setf-method (place &optional env)
1879   "Return a list of five values describing the setf-method for PLACE.
1880 PLACE may be any Lisp form which can appear as the PLACE argument to
1881 a macro like `setf' or `incf'."
1882   (if (symbolp place)
1883       (let ((temp (gensym "--setf--")))
1884         (list nil nil (list temp) (list 'setq place temp) place))
1885     (or (and (symbolp (car place))
1886              (let* ((func (car place))
1887                     (name (symbol-name func))
1888                     (method (get func 'setf-method))
1889                     (case-fold-search nil))
1890                (or (and method
1891                         (let ((cl-macro-environment env))
1892                           (setq method (apply method (cdr place))))
1893                         (if (and (consp method) (= (length method) 5))
1894                             method
1895                           (error "Setf-method for %s returns malformed method"
1896                                  func)))
1897                    (and (save-match-data
1898                           (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name))
1899                         (get-setf-method (compiler-macroexpand place)))
1900                    (and (eq func 'edebug-after)
1901                         (get-setf-method (nth (1- (length place)) place)
1902                                          env)))))
1903         (if (eq place (setq place (macroexpand place env)))
1904             (if (and (symbolp (car place)) (fboundp (car place))
1905                      (symbolp (symbol-function (car place))))
1906                 (get-setf-method (cons (symbol-function (car place))
1907                                        (cdr place)) env)
1908               (error "No setf-method known for %s" (car place)))
1909           (get-setf-method place env)))))
1910
1911 (defun cl-setf-do-modify (place opt-expr)
1912   (let* ((method (get-setf-method place cl-macro-environment))
1913          (temps (car method)) (values (nth 1 method))
1914          (lets nil) (subs nil)
1915          (optimize (and (not (eq opt-expr 'no-opt))
1916                         (or (and (not (eq opt-expr 'unsafe))
1917                                  (cl-safe-expr-p opt-expr))
1918                             (cl-setf-simple-store-p (car (nth 2 method))
1919                                                     (nth 3 method)))))
1920          (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
1921     (while values
1922       (if (or simple (cl-const-expr-p (car values)))
1923           (cl-push (cons (cl-pop temps) (cl-pop values)) subs)
1924         (cl-push (list (cl-pop temps) (cl-pop values)) lets)))
1925     (list (nreverse lets)
1926           (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
1927           (sublis subs (nth 4 method)))))
1928
1929 (defun cl-setf-do-store (spec val)
1930   (let ((sym (car spec))
1931         (form (cdr spec)))
1932     (if (or (cl-const-expr-p val)
1933             (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
1934             (cl-setf-simple-store-p sym form))
1935         (subst val sym form)
1936       (list 'let (list (list sym val)) form))))
1937
1938 (defun cl-setf-simple-store-p (sym form)
1939   (and (consp form) (eq (cl-expr-contains form sym) 1)
1940        (eq (nth (1- (length form)) form) sym)
1941        (symbolp (car form)) (fboundp (car form))
1942        (not (eq (car-safe (symbol-function (car form))) 'macro))))
1943
1944 ;;; The standard modify macros.
1945 ;;;###autoload
1946 (defmacro setf (&rest args)
1947   "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL.
1948 This is a generalized version of `setq'; the PLACEs may be symbolic
1949 references such as (car x) or (aref x i), as well as plain symbols.
1950 For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
1951 The return value is the last VAL in the list."
1952   (if (cdr (cdr args))
1953       (let ((sets nil))
1954         (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets))
1955         (cons 'progn (nreverse sets)))
1956     (if (symbolp (car args))
1957         (and args (cons 'setq args))
1958       (let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
1959              (store (cl-setf-do-store (nth 1 method) (nth 1 args))))
1960         (if (car method) (list 'let* (car method) store) store)))))
1961
1962 ;;;###autoload
1963 (defmacro psetf (&rest args)
1964   "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel.
1965 This is like `setf', except that all VAL forms are evaluated (in order)
1966 before assigning any PLACEs to the corresponding values."
1967   (let ((p args) (simple t) (vars nil))
1968     (while p
1969       (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
1970           (setq simple nil))
1971       (if (memq (car p) vars)
1972           (error "Destination duplicated in psetf: %s" (car p)))
1973       (cl-push (cl-pop p) vars)
1974       (or p (error "Odd number of arguments to psetf"))
1975       (cl-pop p))
1976     (if simple
1977         (list 'progn (cons 'setf args) nil)
1978       (setq args (reverse args))
1979       (let ((expr (list 'setf (cadr args) (car args))))
1980         (while (setq args (cddr args))
1981           (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr))))
1982         (list 'progn expr nil)))))
1983
1984 ;;;###autoload
1985 (defun cl-do-pop (place)
1986   (if (cl-simple-expr-p place)
1987       (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
1988     (let* ((method (cl-setf-do-modify place t))
1989            (temp (gensym "--pop--")))
1990       (list 'let*
1991             (append (car method)
1992                     (list (list temp (nth 2 method))))
1993             (list 'prog1
1994                   (list 'car temp)
1995                   (cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
1996
1997 ;;;###autoload
1998 (defmacro remf (place tag)
1999   "(remf PLACE TAG): remove TAG from property list PLACE.
2000 PLACE may be a symbol, or any generalized variable allowed by `setf'.
2001 The form returns true if TAG was found and removed, nil otherwise."
2002   (let* ((method (cl-setf-do-modify place t))
2003          (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--")))
2004          (val-temp (and (not (cl-simple-expr-p place))
2005                         (gensym "--remf-place--")))
2006          (ttag (or tag-temp tag))
2007          (tval (or val-temp (nth 2 method))))
2008     (list 'let*
2009           (append (car method)
2010                   (and val-temp (list (list val-temp (nth 2 method))))
2011                   (and tag-temp (list (list tag-temp tag))))
2012           (list 'if (list 'eq ttag (list 'car tval))
2013                 (list 'progn
2014                       (cl-setf-do-store (nth 1 method) (list 'cddr tval))
2015                       t)
2016                 (list 'cl-do-remf tval ttag)))))
2017
2018 ;;;###autoload
2019 (defmacro shiftf (place &rest args)
2020   "(shiftf PLACE PLACE... VAL): shift left among PLACEs.
2021 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
2022 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2023   (if (not (memq nil (mapcar 'symbolp (butlast (cons place args)))))
2024       (list* 'prog1 place
2025              (let ((sets nil))
2026                (while args
2027                  (cl-push (list 'setq place (car args)) sets)
2028                  (setq place (cl-pop args)))
2029                (nreverse sets)))
2030     (let* ((places (reverse (cons place args)))
2031            (form (cl-pop places)))
2032       (while places
2033         (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe)))
2034           (setq form (list 'let* (car method)
2035                            (list 'prog1 (nth 2 method)
2036                                  (cl-setf-do-store (nth 1 method) form))))))
2037       form)))
2038
2039 ;;;###autoload
2040 (defmacro rotatef (&rest args)
2041   "(rotatef PLACE...): rotate left among PLACEs.
2042 Example: (rotatef A B C) sets A to B, B to C, and C to A.  It returns nil.
2043 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2044   (if (not (memq nil (mapcar 'symbolp args)))
2045       (and (cdr args)
2046            (let ((sets nil)
2047                  (first (car args)))
2048              (while (cdr args)
2049                (setq sets (nconc sets (list (cl-pop args) (car args)))))
2050              (nconc (list 'psetf) sets (list (car args) first))))
2051     (let* ((places (reverse args))
2052            (temp (gensym "--rotatef--"))
2053            (form temp))
2054       (while (cdr places)
2055         (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe)))
2056           (setq form (list 'let* (car method)
2057                            (list 'prog1 (nth 2 method)
2058                                  (cl-setf-do-store (nth 1 method) form))))))
2059       (let ((method (cl-setf-do-modify (car places) 'unsafe)))
2060         (list 'let* (append (car method) (list (list temp (nth 2 method))))
2061               (cl-setf-do-store (nth 1 method) form) nil)))))
2062
2063 ;;;###autoload
2064 (defmacro letf (bindings &rest body)
2065   "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs.
2066 This is the analogue of `let', but with generalized variables (in the
2067 sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding
2068 VALUE, then the BODY forms are executed.  On exit, either normally or
2069 because of a `throw' or error, the PLACEs are set back to their original
2070 values.  Note that this macro is *not* available in Common Lisp.
2071 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2072 the PLACE is not modified before executing BODY."
2073   (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
2074       (list* 'let bindings body)
2075     (let ((lets nil)
2076           (rev (reverse bindings)))
2077       (while rev
2078         (let* ((place (if (symbolp (caar rev))
2079                           (list 'symbol-value (list 'quote (caar rev)))
2080                         (caar rev)))
2081                (value (cadar rev))
2082                (method (cl-setf-do-modify place 'no-opt))
2083                (save (gensym "--letf-save--"))
2084                (bound (and (memq (car place) '(symbol-value symbol-function))
2085                            (gensym "--letf-bound--")))
2086                (temp (and (not (cl-const-expr-p value)) (cdr bindings)
2087                           (gensym "--letf-val--"))))
2088           (setq lets (nconc (car method)
2089                             (if bound
2090                                 (list (list bound
2091                                             (list (if (eq (car place)
2092                                                           'symbol-value)
2093                                                       'boundp 'fboundp)
2094                                                   (nth 1 (nth 2 method))))
2095                                       (list save (list 'and bound
2096                                                        (nth 2 method))))
2097                               (list (list save (nth 2 method))))
2098                             (and temp (list (list temp value)))
2099                             lets)
2100                 body (list
2101                       (list 'unwind-protect
2102                             (cons 'progn
2103                                   (if (cdr (car rev))
2104                                       (cons (cl-setf-do-store (nth 1 method)
2105                                                               (or temp value))
2106                                             body)
2107                                     body))
2108                             (if bound
2109                                 (list 'if bound
2110                                       (cl-setf-do-store (nth 1 method) save)
2111                                       (list (if (eq (car place) 'symbol-value)
2112                                                 'makunbound 'fmakunbound)
2113                                             (nth 1 (nth 2 method))))
2114                               (cl-setf-do-store (nth 1 method) save))))
2115                 rev (cdr rev))))
2116       (list* 'let* lets body))))
2117
2118 ;;;###autoload
2119 (defmacro letf* (bindings &rest body)
2120   "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs.
2121 This is the analogue of `let*', but with generalized variables (in the
2122 sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding
2123 VALUE, then the BODY forms are executed.  On exit, either normally or
2124 because of a `throw' or error, the PLACEs are set back to their original
2125 values.  Note that this macro is *not* available in Common Lisp.
2126 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2127 the PLACE is not modified before executing BODY."
2128   (if (null bindings)
2129       (cons 'progn body)
2130     (setq bindings (reverse bindings))
2131     (while bindings
2132       (setq body (list (list* 'letf (list (cl-pop bindings)) body))))
2133     (car body)))
2134
2135 ;;;###autoload
2136 (defmacro callf (func place &rest args)
2137   "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...).
2138 FUNC should be an unquoted function name.  PLACE may be a symbol,
2139 or any generalized variable allowed by `setf'."
2140   (let* ((method (cl-setf-do-modify place (cons 'list args)))
2141          (rargs (cons (nth 2 method) args)))
2142     (list 'let* (car method)
2143           (cl-setf-do-store (nth 1 method)
2144                             (if (symbolp func) (cons func rargs)
2145                               (list* 'funcall (list 'function func)
2146                                      rargs))))))
2147
2148 ;;;###autoload
2149 (defmacro callf2 (func arg1 place &rest args)
2150   "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...).
2151 Like `callf', but PLACE is the second argument of FUNC, not the first."
2152   (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
2153       (list 'setf place (list* func arg1 place args))
2154     (let* ((method (cl-setf-do-modify place (cons 'list args)))
2155            (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--")))
2156            (rargs (list* (or temp arg1) (nth 2 method) args)))
2157       (list 'let* (append (and temp (list (list temp arg1))) (car method))
2158             (cl-setf-do-store (nth 1 method)
2159                               (if (symbolp func) (cons func rargs)
2160                                 (list* 'funcall (list 'function func)
2161                                        rargs)))))))
2162
2163 ;;;###autoload
2164 (defmacro define-modify-macro (name arglist func &optional doc)
2165   "(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro.
2166 If NAME is called, it combines its PLACE argument with the other arguments
2167 from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
2168   (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
2169   (let ((place (gensym "--place--")))
2170     (list 'defmacro* name (cons place arglist) doc
2171           (list* (if (memq '&rest arglist) 'list* 'list)
2172                  '(quote callf) (list 'quote func) place
2173                  (cl-arglist-args arglist)))))
2174
2175
2176 ;;; Structures.
2177
2178 ;;;###autoload
2179 (defmacro defstruct (struct &rest descs)
2180   "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type.
2181 This macro defines a new Lisp data type called NAME, which contains data
2182 stored in SLOTs.  This defines a `make-NAME' constructor, a `copy-NAME'
2183 copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2184   (let* ((name (if (consp struct) (car struct) struct))
2185          (opts (cdr-safe struct))
2186          (slots nil)
2187          (defaults nil)
2188          (conc-name (concat (symbol-name name) "-"))
2189          (constructor (intern (format "make-%s" name)))
2190          (constrs nil)
2191          (copier (intern (format "copy-%s" name)))
2192          (predicate (intern (format "%s-p" name)))
2193          (print-func nil) (print-auto nil)
2194          (safety (if (cl-compiling-file) cl-optimize-safety 3))
2195          (include nil)
2196          (tag (intern (format "cl-struct-%s" name)))
2197          (tag-symbol (intern (format "cl-struct-%s-tags" name)))
2198          (include-descs nil)
2199          (side-eff nil)
2200          (type nil)
2201          (named nil)
2202          (forms nil)
2203          pred-form pred-check)
2204     (if (stringp (car descs))
2205         (cl-push (list 'put (list 'quote name) '(quote structure-documentation)
2206                        (cl-pop descs)) forms))
2207     (setq descs (cons '(cl-tag-slot)
2208                       (mapcar #'(lambda (x) (if (consp x) x (list x)))
2209                               descs)))
2210     (while opts
2211       (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
2212             (args (cdr-safe (cl-pop opts))))
2213         (cond ((eq opt ':conc-name)
2214                (if args
2215                    (setq conc-name (if (car args)
2216                                        (symbol-name (car args)) ""))))
2217               ((eq opt ':constructor)
2218                (if (cdr args)
2219                    (cl-push args constrs)
2220                  (if args (setq constructor (car args)))))
2221               ((eq opt ':copier)
2222                (if args (setq copier (car args))))
2223               ((eq opt ':predicate)
2224                (if args (setq predicate (car args))))
2225               ((eq opt ':include)
2226                (setq include (car args)
2227                      include-descs (mapcar #'(lambda (x)
2228                                                (if (consp x) x (list x)))
2229                                            (cdr args))))
2230               ((eq opt ':print-function)
2231                (setq print-func (car args)))
2232               ((eq opt ':type)
2233                (setq type (car args)))
2234               ((eq opt ':named)
2235                (setq named t))
2236               ((eq opt ':initial-offset)
2237                (setq descs (nconc (make-list (car args) '(cl-skip-slot))
2238                                   descs)))
2239               (t
2240                (error "Slot option %s unrecognized" opt)))))
2241     (if print-func
2242         (setq print-func (list 'progn
2243                                (list 'funcall (list 'function print-func)
2244                                      'cl-x 'cl-s 'cl-n) t))
2245       (or type (and include (not (get include 'cl-struct-print)))
2246           (setq print-auto t
2247                 print-func (and (or (not (or include type)) (null print-func))
2248                                 (list 'progn
2249                                       (list 'princ (format "#S(%s" name)
2250                                             'cl-s))))))
2251     (if include
2252         (let ((inc-type (get include 'cl-struct-type))
2253               (old-descs (get include 'cl-struct-slots)))
2254           (or inc-type (error "%s is not a struct name" include))
2255           (and type (not (eq (car inc-type) type))
2256                (error ":type disagrees with :include for %s" name))
2257           (while include-descs
2258             (setcar (memq (or (assq (caar include-descs) old-descs)
2259                               (error "No slot %s in included struct %s"
2260                                      (caar include-descs) include))
2261                           old-descs)
2262                     (cl-pop include-descs)))
2263           (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2264                 type (car inc-type)
2265                 named (assq 'cl-tag-slot descs))
2266           (if (cadr inc-type) (setq tag name named t))
2267           (let ((incl include))
2268             (while incl
2269               (cl-push (list 'pushnew (list 'quote tag)
2270                              (intern (format "cl-struct-%s-tags" incl)))
2271                        forms)
2272               (setq incl (get incl 'cl-struct-include)))))
2273       (if type
2274           (progn
2275             (or (memq type '(vector list))
2276                 (error "Illegal :type specifier: %s" type))
2277             (if named (setq tag name)))
2278         (setq type 'vector named 'true)))
2279     (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
2280     (cl-push (list 'defvar tag-symbol) forms)
2281     (setq pred-form (and named
2282                          (let ((pos (- (length descs)
2283                                        (length (memq (assq 'cl-tag-slot descs)
2284                                                      descs)))))
2285                            (if (eq type 'vector)
2286                                (list 'and '(vectorp cl-x)
2287                                      (list '>= '(length cl-x) (length descs))
2288                                      (list 'memq (list 'aref 'cl-x pos)
2289                                            tag-symbol))
2290                              (if (= pos 0)
2291                                  (list 'memq '(car-safe cl-x) tag-symbol)
2292                                (list 'and '(consp cl-x)
2293                                      (list 'memq (list 'nth pos 'cl-x)
2294                                            tag-symbol))))))
2295           pred-check (and pred-form (> safety 0)
2296                           (if (and (eq (caadr pred-form) 'vectorp)
2297                                    (= safety 1))
2298                               (cons 'and (cdddr pred-form)) pred-form)))
2299     (let ((pos 0) (descp descs))
2300       (while descp
2301         (let* ((desc (cl-pop descp))
2302                (slot (car desc)))
2303           (if (memq slot '(cl-tag-slot cl-skip-slot))
2304               (progn
2305                 (cl-push nil slots)
2306                 (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag))
2307                          defaults))
2308             (if (assq slot descp)
2309                 (error "Duplicate slots named %s in %s" slot name))
2310             (let ((accessor (intern (format "%s%s" conc-name slot))))
2311               (cl-push slot slots)
2312               (cl-push (nth 1 desc) defaults)
2313               (cl-push (list*
2314                         'defsubst* accessor '(cl-x)
2315                         (append
2316                          (and pred-check
2317                               (list (list 'or pred-check
2318                                           (list 'error
2319                                                 (format "%s accessing a non-%s"
2320                                                         accessor name)
2321                                                 'cl-x))))
2322                          (list (if (eq type 'vector) (list 'aref 'cl-x pos)
2323                                  (if (= pos 0) '(car cl-x)
2324                                    (list 'nth pos 'cl-x)))))) forms)
2325               (cl-push (cons accessor t) side-eff)
2326               (cl-push (list 'define-setf-method accessor '(cl-x)
2327                              (if (cadr (memq ':read-only (cddr desc)))
2328                                  (list 'error (format "%s is a read-only slot"
2329                                                       accessor))
2330                                (list 'cl-struct-setf-expander 'cl-x
2331                                      (list 'quote name) (list 'quote accessor)
2332                                      (and pred-check (list 'quote pred-check))
2333                                      pos)))
2334                        forms)
2335               (if print-auto
2336                   (nconc print-func
2337                          (list (list 'princ (format " %s" slot) 'cl-s)
2338                                (list 'prin1 (list accessor 'cl-x) 'cl-s)))))))
2339         (setq pos (1+ pos))))
2340     (setq slots (nreverse slots)
2341           defaults (nreverse defaults))
2342     (and predicate pred-form
2343          (progn (cl-push (list 'defsubst* predicate '(cl-x)
2344                                (if (eq (car pred-form) 'and)
2345                                    (append pred-form '(t))
2346                                  (list 'and pred-form t))) forms)
2347                 (cl-push (cons predicate 'error-free) side-eff)))
2348     (and copier
2349          (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms)
2350                 (cl-push (cons copier t) side-eff)))
2351     (if constructor
2352         (cl-push (list constructor
2353                        (cons '&key (delq nil (copy-sequence slots))))
2354                  constrs))
2355     (while constrs
2356       (let* ((name (caar constrs))
2357              (args (cadr (cl-pop constrs)))
2358              (anames (cl-arglist-args args))
2359              (make (mapcar* #'(lambda (s d) (if (memq s anames) s d))
2360                             slots defaults)))
2361         (cl-push (list 'defsubst* name
2362                        (list* '&cl-defs (list 'quote (cons nil descs)) args)
2363                        (cons type make)) forms)
2364         (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2365             (cl-push (cons name t) side-eff))))
2366     (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2367     (if print-func
2368         (cl-push (list 'push
2369                        (list 'function
2370                              (list 'lambda '(cl-x cl-s cl-n)
2371                                    (list 'and pred-form print-func)))
2372                        'custom-print-functions) forms))
2373     (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
2374     (cl-push (list* 'eval-when '(compile load eval)
2375                     (list 'put (list 'quote name) '(quote cl-struct-slots)
2376                           (list 'quote descs))
2377                     (list 'put (list 'quote name) '(quote cl-struct-type)
2378                           (list 'quote (list type (eq named t))))
2379                     (list 'put (list 'quote name) '(quote cl-struct-include)
2380                           (list 'quote include))
2381                     (list 'put (list 'quote name) '(quote cl-struct-print)
2382                           print-auto)
2383                     (mapcar #'(lambda (x)
2384                                 (list 'put (list 'quote (car x))
2385                                       '(quote side-effect-free)
2386                                       (list 'quote (cdr x))))
2387                             side-eff))
2388              forms)
2389     (cons 'progn (nreverse (cons (list 'quote name) forms)))))
2390
2391 ;;;###autoload
2392 (defun cl-struct-setf-expander (x name accessor pred-form pos)
2393   (let* ((temp (gensym "--x--")) (store (gensym "--store--")))
2394     (list (list temp) (list x) (list store)
2395           (append '(progn)
2396                   (and pred-form
2397                        (list (list 'or (subst temp 'cl-x pred-form)
2398                                    (list 'error
2399                                          (format
2400                                           "%s storing a non-%s" accessor name)
2401                                          temp))))
2402                   (list (if (eq (car (get name 'cl-struct-type)) 'vector)
2403                             (list 'aset temp pos store)
2404                           (list 'setcar
2405                                 (if (<= pos 5)
2406                                     (let ((xx temp))
2407                                       (while (>= (setq pos (1- pos)) 0)
2408                                         (setq xx (list 'cdr xx)))
2409                                       xx)
2410                                   (list 'nthcdr pos temp))
2411                                 store))))
2412           (list accessor temp))))
2413
2414
2415 ;;; Types and assertions.
2416
2417 ;;;###autoload
2418 (defmacro deftype (name args &rest body)
2419   "(deftype NAME ARGLIST BODY...): define NAME as a new data type.
2420 The type name can then be used in `typecase', `check-type', etc."
2421   (list 'eval-when '(compile load eval)
2422         (cl-transform-function-property
2423          name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) args) body))))
2424
2425 (defun cl-make-type-test (val type)
2426   (if (symbolp type)
2427       (cond ((get type 'cl-deftype-handler)
2428              (cl-make-type-test val (funcall (get type 'cl-deftype-handler))))
2429             ((memq type '(nil t)) type)
2430             ((eq type 'string-char) (list 'characterp val))
2431             ((eq type 'null) (list 'null val))
2432             ((eq type 'float) (list 'floatp-safe val))
2433             ((eq type 'real) (list 'numberp val))
2434             ((eq type 'fixnum) (list 'integerp val))
2435             (t
2436              (let* ((name (symbol-name type))
2437                     (namep (intern (concat name "p"))))
2438                (if (fboundp namep) (list namep val)
2439                  (list (intern (concat name "-p")) val)))))
2440     (cond ((get (car type) 'cl-deftype-handler)
2441            (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
2442                                          (cdr type))))
2443           ((memq (car-safe type) '(integer float real number))
2444            (delq t (list 'and (cl-make-type-test val (car type))
2445                          (if (memq (cadr type) '(* nil)) t
2446                            (if (consp (cadr type)) (list '> val (caadr type))
2447                              (list '>= val (cadr type))))
2448                          (if (memq (caddr type) '(* nil)) t
2449                            (if (consp (caddr type)) (list '< val (caaddr type))
2450                              (list '<= val (caddr type)))))))
2451           ((memq (car-safe type) '(and or not))
2452            (cons (car type)
2453                  (mapcar #'(lambda (x) (cl-make-type-test val x))
2454                          (cdr type))))
2455           ((memq (car-safe type) '(member member*))
2456            (list 'and (list 'member* val (list 'quote (cdr type))) t))
2457           ((eq (car-safe type) 'satisfies) (list (cadr type) val))
2458           (t (error "Bad type spec: %s" type)))))
2459
2460 ;;;###autoload
2461 (defun typep (val type)   ; See compiler macro below.
2462   "Check that OBJECT is of type TYPE.
2463 TYPE is a Common Lisp-style type specifier."
2464   (eval (cl-make-type-test 'val type)))
2465
2466 ;;;###autoload
2467 (defmacro check-type (form type &optional string)
2468   "Verify that FORM is of type TYPE; signal an error if not.
2469 STRING is an optional description of the desired type."
2470   (and (or (not (cl-compiling-file))
2471            (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2472        (let* ((temp (if (cl-simple-expr-p form 3) form (gensym)))
2473               (body (list 'or (cl-make-type-test temp type)
2474                           (list 'signal '(quote wrong-type-argument)
2475                                 (list 'list (or string (list 'quote type))
2476                                       temp (list 'quote form))))))
2477          (if (eq temp form) (list 'progn body nil)
2478            (list 'let (list (list temp form)) body nil)))))
2479
2480 ;;;###autoload
2481 (defmacro assert (form &optional show-args string &rest args)
2482   "Verify that FORM returns non-nil; signal an error if not.
2483 Second arg SHOW-ARGS means to include arguments of FORM in message.
2484 Other args STRING and ARGS... are arguments to be passed to `error'.
2485 They are not evaluated unless the assertion fails.  If STRING is
2486 omitted, a default message listing FORM itself is used."
2487   (and (or (not (cl-compiling-file))
2488            (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2489        (let ((sargs (and show-args (delq nil (mapcar
2490                                                #'(lambda (x)
2491                                                    (and (not (cl-const-expr-p x))
2492                                                         x))
2493                                                (cdr form))))))
2494          (list 'progn
2495                (list 'or form
2496                      (if string
2497                          (list* 'error string (append sargs args))
2498                        (list 'signal '(quote cl-assertion-failed)
2499                              (list* 'list (list 'quote form) sargs))))
2500                nil))))
2501
2502 ;;;###autoload
2503 (defmacro ignore-errors (&rest body)
2504   "Execute FORMS; if an error occurs, return nil.
2505 Otherwise, return result of last FORM."
2506   `(condition-case nil (progn ,@body) (error nil)))
2507
2508 ;;;###autoload
2509 (defmacro ignore-file-errors (&rest body)
2510   "Execute FORMS; if an error of type `file-error' occurs, return nil.
2511 Otherwise, return result of last FORM."
2512   `(condition-case nil (progn ,@body) (file-error nil)))
2513
2514 ;;; Some predicates for analyzing Lisp forms.  These are used by various
2515 ;;; macro expanders to optimize the results in certain common cases.
2516
2517 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
2518                             car-safe cdr-safe progn prog1 prog2))
2519 (defconst cl-safe-funcs '(* / % length memq list vector vectorp
2520                           < > <= >= = error))
2521
2522 ;;; Check if no side effects, and executes quickly.
2523 (defun cl-simple-expr-p (x &optional size)
2524   (or size (setq size 10))
2525   (if (and (consp x) (not (memq (car x) '(quote function function*))))
2526       (and (symbolp (car x))
2527            (or (memq (car x) cl-simple-funcs)
2528                (get (car x) 'side-effect-free))
2529            (progn
2530              (setq size (1- size))
2531              (while (and (setq x (cdr x))
2532                          (setq size (cl-simple-expr-p (car x) size))))
2533              (and (null x) (>= size 0) size)))
2534     (and (> size 0) (1- size))))
2535
2536 (defun cl-simple-exprs-p (xs)
2537   (while (and xs (cl-simple-expr-p (car xs)))
2538     (setq xs (cdr xs)))
2539   (not xs))
2540
2541 ;;; Check if no side effects.
2542 (defun cl-safe-expr-p (x)
2543   (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
2544       (and (symbolp (car x))
2545            (or (memq (car x) cl-simple-funcs)
2546                (memq (car x) cl-safe-funcs)
2547                (get (car x) 'side-effect-free))
2548            (progn
2549              (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
2550              (null x)))))
2551
2552 ;;; Check if constant (i.e., no side effects or dependencies).
2553 (defun cl-const-expr-p (x)
2554   (cond ((consp x)
2555          (or (eq (car x) 'quote)
2556              (and (memq (car x) '(function function*))
2557                   (or (symbolp (nth 1 x))
2558                       (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
2559         ((symbolp x) (and (memq x '(nil t)) t))
2560         (t t)))
2561
2562 (defun cl-const-exprs-p (xs)
2563   (while (and xs (cl-const-expr-p (car xs)))
2564     (setq xs (cdr xs)))
2565   (not xs))
2566
2567 (defun cl-const-expr-val (x)
2568   (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
2569
2570 (defun cl-expr-access-order (x v)
2571   (if (cl-const-expr-p x) v
2572     (if (consp x)
2573         (progn
2574           (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
2575           v)
2576       (if (eq x (car v)) (cdr v) '(t)))))
2577
2578 ;;; Count number of times X refers to Y.  Return NIL for 0 times.
2579 (defun cl-expr-contains (x y)
2580   (cond ((equal y x) 1)
2581         ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
2582          (let ((sum 0))
2583            (while x
2584              (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0))))
2585            (and (> sum 0) sum)))
2586         (t nil)))
2587
2588 (defun cl-expr-contains-any (x y)
2589   (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y))
2590   y)
2591
2592 ;;; Check whether X may depend on any of the symbols in Y.
2593 (defun cl-expr-depends-p (x y)
2594   (and (not (cl-const-expr-p x))
2595        (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
2596
2597
2598 ;;; Compiler macros.
2599
2600 ;;;###autoload
2601 (defmacro define-compiler-macro (func args &rest body)
2602   "(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro.
2603 This is like `defmacro', but macro expansion occurs only if the call to
2604 FUNC is compiled (i.e., not interpreted).  Compiler macros should be used
2605 for optimizing the way calls to FUNC are compiled; the form returned by
2606 BODY should do the same thing as a call to the normal function called
2607 FUNC, though possibly more efficiently.  Note that, like regular macros,
2608 compiler macros are expanded repeatedly until no further expansions are
2609 possible.  Unlike regular macros, BODY can decide to \"punt\" and leave the
2610 original function call alone by declaring an initial `&whole foo' parameter
2611 and then returning foo."
2612   (let ((p (if (listp args) args (list '&rest args))) (res nil))
2613     (while (consp p) (cl-push (cl-pop p) res))
2614     (setq args (nreverse res)) (setcdr res (and p (list '&rest p))))
2615   (list 'eval-when '(compile load eval)
2616         (cl-transform-function-property
2617          func 'cl-compiler-macro
2618          (cons (if (memq '&whole args) (delq '&whole args)
2619                  (cons '--cl-whole-arg-- args)) body))
2620         (list 'or (list 'get (list 'quote func) '(quote byte-compile))
2621               (list 'put (list 'quote func) '(quote byte-compile)
2622                     '(quote cl-byte-compile-compiler-macro)))))
2623
2624 ;;;###autoload
2625 (defun compiler-macroexpand (form)
2626   (while
2627       (let ((func (car-safe form)) (handler nil))
2628         (while (and (symbolp func)
2629                     (not (setq handler (get func 'cl-compiler-macro)))
2630                     (fboundp func)
2631                     (or (not (eq (car-safe (symbol-function func)) 'autoload))
2632                         (load (nth 1 (symbol-function func)))))
2633           (setq func (symbol-function func)))
2634         (and handler
2635              (not (eq form (setq form (apply handler form (cdr form))))))))
2636   form)
2637
2638 (defun cl-byte-compile-compiler-macro (form)
2639   (if (eq form (setq form (compiler-macroexpand form)))
2640       (byte-compile-normal-call form)
2641     (byte-compile-form form)))
2642
2643 (defmacro defsubst* (name args &rest body)
2644   "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
2645 Like `defun', except the function is automatically declared `inline',
2646 ARGLIST allows full Common Lisp conventions, and BODY is implicitly
2647 surrounded by (block NAME ...)."
2648   (let* ((argns (cl-arglist-args args)) (p argns)
2649          (pbody (cons 'progn body))
2650          (unsafe (not (cl-safe-expr-p pbody))))
2651     (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p))
2652     (list 'progn
2653           (if p nil   ; give up if defaults refer to earlier args
2654             (list 'define-compiler-macro name
2655                   (list* '&whole 'cl-whole '&cl-quote args)
2656                   (list* 'cl-defsubst-expand (list 'quote argns)
2657                          (list 'quote (list* 'block name body))
2658                          (not (or unsafe (cl-expr-access-order pbody argns)))
2659                          (and (memq '&key args) 'cl-whole) unsafe argns)))
2660           (list* 'defun* name args body))))
2661
2662 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
2663   (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
2664     (if (cl-simple-exprs-p argvs) (setq simple t))
2665     (let ((lets (delq nil
2666                       (mapcar* #'(lambda (argn argv)
2667                                    (if (or simple (cl-const-expr-p argv))
2668                                        (progn (setq body (subst argv argn body))
2669                                               (and unsafe (list argn argv)))
2670                                      (list argn argv)))
2671                                argns argvs))))
2672       (if lets (list 'let lets body) body))))
2673
2674
2675 ;;; Compile-time optimizations for some functions defined in this package.
2676 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
2677 ;;; mainly to make sure these macros will be present.
2678
2679 (put 'eql 'byte-compile nil)
2680 (define-compiler-macro eql (&whole form a b)
2681   (cond ((eq (cl-const-expr-p a) t)
2682          (let ((val (cl-const-expr-val a)))
2683            (if (and (numberp val) (not (integerp val)))
2684                (list 'equal a b)
2685              (list 'eq a b))))
2686         ((eq (cl-const-expr-p b) t)
2687          (let ((val (cl-const-expr-val b)))
2688            (if (and (numberp val) (not (integerp val)))
2689                (list 'equal a b)
2690              (list 'eq a b))))
2691         ((cl-simple-expr-p a 5)
2692          (list 'if (list 'numberp a)
2693                (list 'equal a b)
2694                (list 'eq a b)))
2695         ((and (cl-safe-expr-p a)
2696               (cl-simple-expr-p b 5))
2697          (list 'if (list 'numberp b)
2698                (list 'equal a b)
2699                (list 'eq a b)))
2700         (t form)))
2701
2702 (define-compiler-macro member* (&whole form a list &rest keys)
2703   (let ((test (and (= (length keys) 2) (eq (car keys) ':test)
2704                    (cl-const-expr-val (nth 1 keys)))))
2705     (cond ((eq test 'eq) (list 'memq a list))
2706           ((eq test 'equal) (list 'member a list))
2707           ((or (null keys) (eq test 'eql))
2708            (if (eq (cl-const-expr-p a) t)
2709                (list (if (floatp-safe (cl-const-expr-val a)) 'member 'memq)
2710                      a list)
2711              (if (eq (cl-const-expr-p list) t)
2712                  (let ((p (cl-const-expr-val list)) (mb nil) (mq nil))
2713                    (if (not (cdr p))
2714                        (and p (list 'eql a (list 'quote (car p))))
2715                      (while p
2716                        (if (floatp-safe (car p)) (setq mb t)
2717                          (or (integerp (car p)) (symbolp (car p)) (setq mq t)))
2718                        (setq p (cdr p)))
2719                      (if (not mb) (list 'memq a list)
2720                        (if (not mq) (list 'member a list) form))))
2721                form)))
2722           (t form))))
2723
2724 (define-compiler-macro assoc* (&whole form a list &rest keys)
2725   (let ((test (and (= (length keys) 2) (eq (car keys) ':test)
2726                    (cl-const-expr-val (nth 1 keys)))))
2727     (cond ((eq test 'eq) (list 'assq a list))
2728           ((eq test 'equal) (list 'assoc a list))
2729           ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
2730            (if (floatp-safe (cl-const-expr-val a))
2731                (list 'assoc a list) (list 'assq a list)))
2732           (t form))))
2733
2734 (define-compiler-macro adjoin (&whole form a list &rest keys)
2735   (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
2736            (not (memq ':key keys)))
2737       (list 'if (list* 'member* a list keys) list (list 'cons a list))
2738     form))
2739
2740 (define-compiler-macro list* (arg &rest others)
2741   (let* ((args (reverse (cons arg others)))
2742          (form (car args)))
2743     (while (setq args (cdr args))
2744       (setq form (list 'cons (car args) form)))
2745     form))
2746
2747 (define-compiler-macro get* (sym prop &optional def)
2748   (if def
2749       (list 'getf (list 'symbol-plist sym) prop def)
2750     (list 'get sym prop)))
2751
2752 (define-compiler-macro typep (&whole form val type)
2753   (if (cl-const-expr-p type)
2754       (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2755         (if (or (memq (cl-expr-contains res val) '(nil 1))
2756                 (cl-simple-expr-p val)) res
2757           (let ((temp (gensym)))
2758             (list 'let (list (list temp val)) (subst temp val res)))))
2759     form))
2760
2761
2762 (mapc
2763  #'(lambda (y)
2764      (put (car y) 'side-effect-free t)
2765      (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
2766      (put (car y) 'cl-compiler-macro
2767           (list 'lambda '(w x)
2768                 (if (symbolp (cadr y))
2769                     (list 'list (list 'quote (cadr y))
2770                           (list 'list (list 'quote (caddr y)) 'x))
2771                   (cons 'list (cdr y))))))
2772  '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
2773    (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
2774    (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
2775    (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
2776    (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
2777    (caaar car caar) (caadr car cadr) (cadar car cdar)
2778    (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
2779    (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
2780    (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
2781    (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
2782    (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
2783    (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
2784    (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
2785
2786 ;;; Things that are inline.
2787 (proclaim '(inline floatp-safe acons map concatenate notany notevery
2788 ;; XEmacs change
2789                    cl-set-elt revappend nreconc
2790                    plusp minusp oddp evenp
2791                    ))
2792
2793 ;;; Things that are side-effect-free.  Moved to byte-optimize.el
2794 ;(dolist (fun '(oddp evenp plusp minusp
2795 ;                   abs expt signum last butlast ldiff
2796 ;                   pairlis gcd lcm
2797 ;                   isqrt floor* ceiling* truncate* round* mod* rem* subseq
2798 ;                   list-length get* getf))
2799 ;  (put fun 'side-effect-free t))
2800
2801 ;;; Things that are side-effect-and-error-free.  Moved to byte-optimize.el
2802 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
2803 ;                  copy-tree sublis))
2804 ;  (put fun 'side-effect-free 'error-free))
2805
2806
2807 (run-hooks 'cl-macs-load-hook)
2808
2809 ;;; cl-macs.el ends here