lisp/emacs-lisp/cl.el

   1 ;;; cl.el --- Compatibility aliases for the old CL library.  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords: extensions
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is a compatibility file which provides the old names provided by CL
  26 ;; before we cleaned up its namespace usage.
  27
  28 ;;; Code:
  29
  30 (require 'cl-lib)
  31 (require 'macroexp)
  32 (require 'gv)
  33
  34 ;; (defun cl--rename ()
  35 ;;   (let ((vdefs ())
  36 ;;         (fdefs ())
  37 ;;         (case-fold-search nil)
  38 ;;         (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
  39 ;;     (dolist (file files)
  40 ;;       (with-current-buffer (find-file-noselect file)
  41 ;;         (goto-char (point-min))
  42 ;;         (while (re-search-forward
  43 ;;                 "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
  44 ;;           (let ((name (match-string-no-properties 2))
  45 ;;                 (type (match-string-no-properties 1)))
  46 ;;             (unless (string-match-p "\\`cl-" name)
  47 ;;               (cond
  48 ;;                ((member type '("defvar" "defconst"))
  49 ;;                 (unless (member name vdefs) (push name vdefs)))
  50 ;;                ((member type '("defun" "defsubst" "defalias" "defmacro"))
  51 ;;                 (unless (member name fdefs) (push name fdefs)))
  52 ;;                ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
  53 ;;                                "define-compiler-macro"))
  54 ;;                 nil)
  55 ;;                (t (error "Unknown type %S" type))))))))
  56 ;;     (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
  57 ;;           (conflicts ()))
  58 ;;       (dolist (file files)
  59 ;;         (with-current-buffer (find-file-noselect file)
  60 ;;           (goto-char (point-min))
  61 ;;           (while (re-search-forward re nil t)
  62 ;;             (replace-match "cl-\\&"))
  63 ;;           (save-buffer))))
  64 ;;     (with-current-buffer (find-file-noselect "cl-rename.el")
  65 ;;       (dolist (def vdefs)
  66 ;;         (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
  67 ;;       (dolist (def fdefs)
  68 ;;         (insert (format "(defalias '%s 'cl-%s)\n" def def)))
  69 ;;       (save-buffer))))
  70
  71 ;; (defun cl--unrename ()
  72 ;;   ;; Taken from "Naming Conventions" node of the doc.
  73 ;;   (let* ((names '(defun* defsubst* defmacro* function* member*
  74 ;;                          assoc* rassoc* get* remove* delete*
  75 ;;                          mapcar* sort* floor* ceiling* truncate*
  76 ;;                          round* mod* rem* random*))
  77 ;;          (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
  78 ;;          (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
  79 ;;                      "\\_>")))
  80 ;;     (dolist (file files)
  81 ;;       (with-current-buffer (find-file-noselect file)
  82 ;;         (goto-char (point-min))
  83 ;;         (while (re-search-forward re nil t)
  84 ;;           (delete-region (1- (point)) (point)))
  85 ;;         (save-buffer)))))
  86
  87 (defun cl-unload-function ()
  88   "Stop unloading of the Common Lisp extensions."
  89   (message "Cannot unload the feature `cl'")
  90   ;; Stop standard unloading!
  91   t)
  92
  93 ;;; Aliases to cl-lib's features.
  94
  95 (dolist (var '(
  96                ;; loop-result-var
  97                ;; loop-result
  98                ;; loop-initially
  99                ;; loop-finally
 100                ;; loop-bindings
 101                ;; loop-args
 102                ;; bind-inits
 103                ;; bind-block
 104                ;; lambda-list-keywords
 105                float-negative-epsilon
 106                float-epsilon
 107                least-negative-normalized-float
 108                least-positive-normalized-float
 109                least-negative-float
 110                least-positive-float
 111                most-negative-float
 112                most-positive-float
 113                ;; custom-print-functions
 114                ))
 115   (defvaralias var (intern (format "cl-%s" var))))
 116
 117 (dolist (fun '(
 118                (get* . cl-get)
 119                (random* . cl-random)
 120                (rem* . cl-rem)
 121                (mod* . cl-mod)
 122                (round* . cl-round)
 123                (truncate* . cl-truncate)
 124                (ceiling* . cl-ceiling)
 125                (floor* . cl-floor)
 126                (rassoc* . cl-rassoc)
 127                (assoc* . cl-assoc)
 128                (member* . cl-member)
 129                (delete* . cl-delete)
 130                (remove* . cl-remove)
 131                (defsubst* . cl-defsubst)
 132                (sort* . cl-sort)
 133                (function* . cl-function)
 134                (defmacro* . cl-defmacro)
 135                (defun* . cl-defun)
 136                (mapcar* . cl-mapcar)
 137
 138                remprop
 139                getf
 140                tailp
 141                list-length
 142                nreconc
 143                revappend
 144                concatenate
 145                subseq
 146                random-state-p
 147                make-random-state
 148                signum
 149                isqrt
 150                lcm
 151                gcd
 152                notevery
 153                notany
 154                every
 155                some
 156                mapcon
 157                mapl
 158                maplist
 159                map
 160                equalp
 161                coerce
 162                tree-equal
 163                nsublis
 164                sublis
 165                nsubst-if-not
 166                nsubst-if
 167                nsubst
 168                subst-if-not
 169                subst-if
 170                subsetp
 171                nset-exclusive-or
 172                set-exclusive-or
 173                nset-difference
 174                set-difference
 175                nintersection
 176                intersection
 177                nunion
 178                union
 179                rassoc-if-not
 180                rassoc-if
 181                assoc-if-not
 182                assoc-if
 183                member-if-not
 184                member-if
 185                merge
 186                stable-sort
 187                search
 188                mismatch
 189                count-if-not
 190                count-if
 191                count
 192                position-if-not
 193                position-if
 194                position
 195                find-if-not
 196                find-if
 197                find
 198                nsubstitute-if-not
 199                nsubstitute-if
 200                nsubstitute
 201                substitute-if-not
 202                substitute-if
 203                substitute
 204                delete-duplicates
 205                remove-duplicates
 206                delete-if-not
 207                delete-if
 208                remove-if-not
 209                remove-if
 210                replace
 211                fill
 212                reduce
 213                compiler-macroexpand
 214                define-compiler-macro
 215                assert
 216                check-type
 217                typep
 218                deftype
 219                defstruct
 220                callf2
 221                callf
 222                letf*
 223                letf
 224                rotatef
 225                shiftf
 226                remf
 227                psetf
 228                (define-setf-method . define-setf-expander)
 229                the
 230                locally
 231                multiple-value-setq
 232                multiple-value-bind
 233                symbol-macrolet
 234                macrolet
 235                progv
 236                psetq
 237                do-all-symbols
 238                do-symbols
 239                do*
 240                do
 241                loop
 242                return-from
 243                return
 244                block
 245                etypecase
 246                typecase
 247                ecase
 248                case
 249                load-time-value
 250                eval-when
 251                destructuring-bind
 252                gentemp
 253                pairlis
 254                acons
 255                subst
 256                adjoin
 257                copy-list
 258                ldiff
 259                list*
 260                tenth
 261                ninth
 262                eighth
 263                seventh
 264                sixth
 265                fifth
 266                fourth
 267                third
 268                endp
 269                rest
 270                second
 271                first
 272                svref
 273                copy-seq
 274                evenp
 275                oddp
 276                minusp
 277                plusp
 278                floatp-safe
 279                declaim
 280                proclaim
 281                nth-value
 282                multiple-value-call
 283                multiple-value-apply
 284                multiple-value-list
 285                values-list
 286                values
 287                pushnew
 288                decf
 289                incf
 290                ))
 291   (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
 292                (intern (format "cl-%s" fun)))))
 293     (defalias fun new)))
 294
 295 (defun cl--wrap-in-nil-block (fun &rest args)
 296   `(cl-block nil ,(apply fun args)))
 297 (advice-add 'dolist :around #'cl--wrap-in-nil-block)
 298 (advice-add 'dotimes :around #'cl--wrap-in-nil-block)
 299
 300 (defun cl--pass-args-to-cl-declare (&rest specs)
 301    (macroexpand `(cl-declare ,@specs)))
 302 (advice-add 'declare :after #'cl--pass-args-to-cl-declare)
 303
 304 ;;; Features provided a bit differently in Elisp.
 305
 306 ;; First, the old lexical-let is now better served by `lexical-binding', tho
 307 ;; it's not 100% compatible.
 308
 309 (defvar cl-closure-vars nil)
 310 (defvar cl--function-convert-cache nil)
 311
 312 (defun cl--function-convert (f)
 313   "Special macro-expander for special cases of (function F).
 314 The two cases that are handled are:
 315 - closure-conversion of lambda expressions for `lexical-let'.
 316 - renaming of F when it's a function defined via `cl-labels' or `labels'."
 317   (require 'cl-macs)
 318   (declare-function cl--expr-contains-any "cl-macs" (x y))
 319   (declare-function cl--labels-convert "cl-macs" (f))
 320   (defvar cl--labels-convert-cache)
 321   (cond
 322    ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
 323    ;; *after* handling `function', but we want to stop macroexpansion from
 324    ;; being applied infinitely, so we use a cache to return the exact `form'
 325    ;; being expanded even though we don't receive it.
 326    ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
 327    ((eq (car-safe f) 'lambda)
 328     (let ((body (mapcar (lambda (f)
 329                           (macroexpand-all f macroexpand-all-environment))
 330                         (cddr f))))
 331       (if (and cl-closure-vars
 332                (cl--expr-contains-any body cl-closure-vars))
 333           (let* ((new (mapcar 'cl-gensym cl-closure-vars))
 334                  (sub (cl-pairlis cl-closure-vars new)) (decls nil))
 335             (while (or (stringp (car body))
 336                        (eq (car-safe (car body)) 'interactive))
 337               (push (list 'quote (pop body)) decls))
 338             (put (car (last cl-closure-vars)) 'used t)
 339             `(list 'lambda '(&rest --cl-rest--)
 340                    ,@(cl-sublis sub (nreverse decls))
 341                    (list 'apply
 342                          (list 'function
 343                                #'(lambda ,(append new (cadr f))
 344                                    ,@(cl-sublis sub body)))
 345                          ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
 346                                           cl-closure-vars)
 347                                   '((quote --cl-rest--))))))
 348         (let* ((newf `(lambda ,(cadr f) ,@body))
 349                (res `(function ,newf)))
 350           (setq cl--function-convert-cache (cons newf res))
 351           res))))
 352    (t
 353     (cl--labels-convert f))))
 354
 355 (defmacro lexical-let (bindings &rest body)
 356   "Like `let', but lexically scoped.
 357 The main visible difference is that lambdas inside BODY will create
 358 lexical closures as in Common Lisp.
 359 \n(fn BINDINGS BODY)"
 360   (declare (indent 1) (debug let))
 361   (let* ((cl-closure-vars cl-closure-vars)
 362          (vars (mapcar (function
 363                         (lambda (x)
 364                           (or (consp x) (setq x (list x)))
 365                           (push (make-symbol (format "--cl-%s--" (car x)))
 366                                 cl-closure-vars)
 367                           (set (car cl-closure-vars) [bad-lexical-ref])
 368                           (list (car x) (cadr x) (car cl-closure-vars))))
 369                        bindings))
 370          (ebody
 371           (macroexpand-all
 372            `(cl-symbol-macrolet
 373                 ,(mapcar (lambda (x)
 374                            `(,(car x) (symbol-value ,(nth 2 x))))
 375                          vars)
 376               ,@body)
 377            (cons (cons 'function #'cl--function-convert)
 378                  macroexpand-all-environment))))
 379     (if (not (get (car (last cl-closure-vars)) 'used))
 380         ;; Turn (let ((foo (cl-gensym)))
 381         ;;        (set foo <val>) ...(symbol-value foo)...)
 382         ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
 383         ;; This is good because it's more efficient but it only works with
 384         ;; dynamic scoping, since with lexical scoping we'd need
 385         ;; (let ((foo <val>)) ...foo...).
 386         `(progn
 387            ,@(mapcar (lambda (x) `(defvar ,(nth 2 x))) vars)
 388            (let ,(mapcar (lambda (x) (list (nth 2 x) (nth 1 x))) vars)
 389            ,(cl-sublis (mapcar (lambda (x)
 390                               (cons (nth 2 x)
 391                                     `',(nth 2 x)))
 392                             vars)
 393                     ebody)))
 394       `(let ,(mapcar (lambda (x)
 395                        (list (nth 2 x)
 396                              `(make-symbol ,(format "--%s--" (car x)))))
 397                      vars)
 398          (setf ,@(apply #'append
 399                         (mapcar (lambda (x)
 400                                   (list `(symbol-value ,(nth 2 x)) (nth 1 x)))
 401                                 vars)))
 402          ,ebody))))
 403
 404 (defmacro lexical-let* (bindings &rest body)
 405   "Like `let*', but lexically scoped.
 406 The main visible difference is that lambdas inside BODY, and in
 407 successive bindings within BINDINGS, will create lexical closures
 408 as in Common Lisp.  This is similar to the behavior of `let*' in
 409 Common Lisp.
 410 \n(fn BINDINGS BODY)"
 411   (declare (indent 1) (debug let))
 412   (if (null bindings) (cons 'progn body)
 413     (setq bindings (reverse bindings))
 414     (while bindings
 415       (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
 416     (car body)))
 417
 418 ;; This should really have some way to shadow 'byte-compile properties, etc.
 419 (defmacro flet (bindings &rest body)
 420   "Make temporary overriding function definitions.
 421 This is an analogue of a dynamically scoped `let' that operates on the function
 422 cell of FUNCs rather than their value cell.
 423 If you want the Common-Lisp style of `flet', you should use `cl-flet'.
 424 The FORMs are evaluated with the specified function definitions in place,
 425 then the definitions are undone (the FUNCs go back to their previous
 426 definitions, or lack thereof).
 427
 428 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
 429   (declare (indent 1) (debug cl-flet)
 430            (obsolete "use either `cl-flet' or `cl-letf'."  "24.3"))
 431   `(letf ,(mapcar
 432            (lambda (x)
 433              (if (or (and (fboundp (car x))
 434                           (eq (car-safe (symbol-function (car x))) 'macro))
 435                      (cdr (assq (car x) macroexpand-all-environment)))
 436                  (error "Use `labels', not `flet', to rebind macro names"))
 437              (let ((func `(cl-function
 438                            (lambda ,(cadr x)
 439                              (cl-block ,(car x) ,@(cddr x))))))
 440                (when (cl--compiling-file)
 441                  ;; Bug#411.  It would be nice to fix this.
 442                  (and (get (car x) 'byte-compile)
 443                       (error "Byte-compiling a redefinition of `%s' \
 444 will not work - use `labels' instead" (symbol-name (car x))))
 445                  ;; FIXME This affects the rest of the file, when it
 446                  ;; should be restricted to the flet body.
 447                  (and (boundp 'byte-compile-function-environment)
 448                       (push (cons (car x) (eval func))
 449                             byte-compile-function-environment)))
 450                (list `(symbol-function ',(car x)) func)))
 451            bindings)
 452      ,@body))
 453
 454 (defmacro labels (bindings &rest body)
 455   "Make temporary function bindings.
 456 Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
 457 rather than relying on `lexical-binding'."
 458   (declare (indent 1) (debug cl-flet) (obsolete cl-labels "24.3"))
 459   (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
 460     (dolist (binding bindings)
 461       ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
 462       ;; because these var's *names* get added to the macro-environment.
 463       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
 464         (push var vars)
 465         (push `(cl-function (lambda . ,(cdr binding))) sets)
 466         (push var sets)
 467         (push (cons (car binding)
 468                     `(lambda (&rest cl-labels-args)
 469                        (cl-list* 'funcall ',var
 470                                  cl-labels-args)))
 471               newenv)))
 472     (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))
 473
 474 ;; Generalized variables are provided by gv.el, but some details are
 475 ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
 476 ;; still need to support old users of cl.el.
 477
 478 (defun cl--gv-adapt (cl-gv do)
 479   ;; This function is used by all .elc files that use define-setf-expander and
 480   ;; were compiled with Emacs>=24.3.
 481   (let ((vars (nth 0 cl-gv))
 482         (vals (nth 1 cl-gv))
 483         (binds ())
 484         (substs ()))
 485     ;; Use cl-sublis as was done in cl-setf-do-modify.
 486     (while vars
 487       (if (macroexp-copyable-p (car vals))
 488           (push (cons (pop vars) (pop vals)) substs)
 489         (push (list (pop vars) (pop vals)) binds)))
 490     (macroexp-let*
 491      binds
 492      (funcall do (cl-sublis substs (nth 4 cl-gv))
 493               ;; We'd like to do something like
 494               ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
 495               (lambda (exp)
 496                 (macroexp-let2 macroexp-copyable-p v exp
 497                   (cl-sublis (cons (cons (car (nth 2 cl-gv)) v)
 498                                    substs)
 499                              (nth 3 cl-gv))))))))
 500
 501 (defmacro define-setf-expander (name arglist &rest body)
 502   "Define a `setf' method.
 503 This method shows how to handle `setf's to places of the form
 504 \(NAME ARGS...).  The argument forms ARGS are bound according to
 505 ARGLIST, as if NAME were going to be expanded as a macro, then
 506 the BODY forms are executed and must return a list of five elements:
 507 a temporary-variables list, a value-forms list, a store-variables list
 508 \(of length one), a store-form, and an access- form.
 509
 510 See `gv-define-expander', and `gv-define-setter' for better and
 511 simpler ways to define setf-methods."
 512   (declare (debug
 513             (&define name cl-lambda-list cl-declarations-or-string def-body)))
 514   `(progn
 515      ,@(if (stringp (car body))
 516            (list `(put ',name 'setf-documentation ,(pop body))))
 517      (gv-define-expander ,name
 518        (cl-function
 519         (lambda (do ,@arglist)
 520           (cl--gv-adapt (progn ,@body) do))))))
 521
 522 (defmacro defsetf (name arg1 &rest args)
 523   "Define a `setf' method.
 524 This macro is an easy-to-use substitute for `define-setf-expander'
 525 that works well for simple place forms.
 526
 527 In the simple `defsetf' form, `setf's of the form (setf (NAME
 528 ARGS...) VAL) are transformed to function or macro calls of the
 529 form (FUNC ARGS... VAL).  For example:
 530
 531   (defsetf aref aset)
 532
 533 You can replace this form with `gv-define-simple-setter'.
 534
 535 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
 536
 537 Here, the above `setf' call is expanded by binding the argument
 538 forms ARGS according to ARGLIST, binding the value form VAL to
 539 STORE, then executing BODY, which must return a Lisp form that
 540 does the necessary `setf' operation.  Actually, ARGLIST and STORE
 541 may be bound to temporary variables which are introduced
 542 automatically to preserve proper execution order of the arguments.
 543 For example:
 544
 545   (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v))
 546
 547 You can replace this form with `gv-define-setter'.
 548
 549 \(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
 550   (declare (debug
 551             (&define name
 552                      [&or [symbolp &optional stringp]
 553                           [cl-lambda-list (symbolp)]]
 554                      cl-declarations-or-string def-body)))
 555   (if (and (listp arg1) (consp args))
 556       ;; Like `gv-define-setter' but with `cl-function'.
 557       `(gv-define-expander ,name
 558          (lambda (do &rest args)
 559            (gv--defsetter ',name
 560                           (cl-function
 561                            (lambda (,@(car args) ,@arg1) ,@(cdr args)))
 562                           do args)))
 563     `(gv-define-simple-setter ,name ,arg1 ,(car args))))
 564
 565 ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
 566 ;; to find a case where it worked.  The code below tries to handle it as well.
 567 ;; (defun cl--setf-apply (form last-witness last)
 568 ;;   (cond
 569 ;;    ((not (consp form)) form)
 570 ;;    ((eq (ignore-errors (car (last form))) last-witness)
 571 ;;     `(apply #',(car form) ,@(butlast (cdr form)) ,last))
 572 ;;    ((and (memq (car form) '(let let*))
 573 ;;          (rassoc (list last-witness) (cadr form)))
 574 ;;     (let ((rebind (rassoc (list last-witness) (cadr form))))
 575 ;;     `(,(car form) ,(remq rebind (cadr form))
 576 ;;       ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
 577 ;;                 (cddr form)))))
 578 ;;    (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
 579 ;; (gv-define-setter apply (val fun &rest args)
 580 ;;   (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
 581 ;;          (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
 582 ;;   (let* ((butlast (butlast args))
 583 ;;          (last (car (last args)))
 584 ;;          (last-witness (make-symbol "--cl-tailarg--"))
 585 ;;          (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
 586 ;;                               macroexpand-all-environment)))
 587 ;;     (cl--setf-apply setter last-witness last)))
 588
 589
 590 ;; FIXME: CL used to provide get-setf-method, which was used by some
 591 ;; setf-expanders, but now that we use gv.el, it is a lot more difficult
 592 ;; and in general impossible to provide get-setf-method.  Hopefully, it
 593 ;; won't be needed.  If needed, we'll have to do something nasty along the
 594 ;; lines of
 595 ;; (defun get-setf-method (place &optional env)
 596 ;;   (let* ((witness (list 'cl-gsm))
 597 ;;          (expansion (gv-letplace (getter setter) place
 598 ;;                      `(,witness ,getter ,(funcall setter witness)))))
 599 ;;     ...find "let prefix" of expansion, extract getter and setter from
 600 ;;     ...the rest, and build the 5-tuple))
 601 (make-obsolete 'get-setf-method 'gv-letplace "24.3")
 602
 603 (declare-function cl--arglist-args "cl-macs" (args))
 604
 605 (defmacro define-modify-macro (name arglist func &optional doc)
 606   "Define a `setf'-like modify macro.
 607 If NAME is called, it combines its PLACE argument with the other
 608 arguments from ARGLIST using FUNC.  For example:
 609
 610   (define-modify-macro incf (&optional (n 1)) +)
 611
 612 You can replace this macro with `gv-letplace'."
 613   (declare (debug
 614             (&define name cl-lambda-list ;; should exclude &key
 615                      symbolp &optional stringp)))
 616   (if (memq '&key arglist)
 617       (error "&key not allowed in define-modify-macro"))
 618   (require 'cl-macs)                    ;For cl--arglist-args.
 619   (let ((place (make-symbol "--cl-place--")))
 620     `(cl-defmacro ,name (,place ,@arglist)
 621        ,doc
 622        (,(if (memq '&rest arglist) #'cl-list* #'list)
 623         #'cl-callf ',func ,place
 624         ,@(cl--arglist-args arglist)))))
 625
 626 ;;; Additional compatibility code.
 627 ;; For names that were clean but really aren't needed any more.
 628
 629 (define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3")
 630 (define-obsolete-variable-alias 'cl-macro-environment
 631   'macroexpand-all-environment "24.3")
 632 (define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3")
 633
 634 ;;; Hash tables.
 635 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
 636
 637 ;; No idea if this might still be needed.
 638 (defun cl-not-hash-table (x &optional y &rest _z)
 639   (declare (obsolete nil "24.3"))
 640   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 641
 642 (defvar cl-builtin-gethash (symbol-function 'gethash))
 643 (make-obsolete-variable 'cl-builtin-gethash nil "24.3")
 644 (defvar cl-builtin-remhash (symbol-function 'remhash))
 645 (make-obsolete-variable 'cl-builtin-remhash nil "24.3")
 646 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
 647 (make-obsolete-variable 'cl-builtin-clrhash nil "24.3")
 648 (defvar cl-builtin-maphash (symbol-function 'maphash))
 649
 650 (make-obsolete-variable 'cl-builtin-maphash nil "24.3")
 651 (define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3")
 652 (define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3")
 653 (define-obsolete-function-alias 'cl-gethash 'gethash "24.3")
 654 (define-obsolete-function-alias 'cl-puthash 'puthash "24.3")
 655 (define-obsolete-function-alias 'cl-remhash 'remhash "24.3")
 656 (define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3")
 657 (define-obsolete-function-alias 'cl-maphash 'maphash "24.3")
 658 (define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3")
 659 (define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3")
 660 (define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3")
 661
 662 (define-obsolete-function-alias 'cl-map-keymap-recursively
 663   'cl--map-keymap-recursively "24.3")
 664 (define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3")
 665 (define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3")
 666 (define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3")
 667
 668 (defun cl-maclisp-member (item list)
 669   (declare (obsolete member "24.3"))
 670   (while (and list (not (equal item (car list)))) (setq list (cdr list)))
 671   list)
 672
 673 ;; Used in the expansion of the old `defstruct'.
 674 (defun cl-struct-setf-expander (x name accessor pred-form pos)
 675   (declare (obsolete nil "24.3"))
 676   (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
 677     (list (list temp) (list x) (list store)
 678           `(progn
 679              ,@(and pred-form
 680                     (list `(or ,(cl-subst temp 'cl-x pred-form)
 681                                (error ,(format
 682                                         "%s storing a non-%s"
 683                                         accessor name)))))
 684              ,(if (eq (car (get name 'cl-struct-type)) 'vector)
 685                   `(aset ,temp ,pos ,store)
 686                 `(setcar
 687                   ,(if (<= pos 5)
 688                        (let ((xx temp))
 689                          (while (>= (setq pos (1- pos)) 0)
 690                            (setq xx `(cdr ,xx)))
 691                          xx)
 692                      `(nthcdr ,pos ,temp))
 693                   ,store)))
 694           (list accessor temp))))
 695
 696 (provide 'cl)
 697
 698 (run-hooks 'cl-load-hook)
 699
 700 ;;; cl.el ends here