code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/cl.el

   1 ;;; cl.el --- Compatibility aliases for the old CL library.  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2016 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 <http://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                mapcan
 158                mapl
 159                maplist
 160                map
 161                equalp
 162                coerce
 163                tree-equal
 164                nsublis
 165                sublis
 166                nsubst-if-not
 167                nsubst-if
 168                nsubst
 169                subst-if-not
 170                subst-if
 171                subsetp
 172                nset-exclusive-or
 173                set-exclusive-or
 174                nset-difference
 175                set-difference
 176                nintersection
 177                intersection
 178                nunion
 179                union
 180                rassoc-if-not
 181                rassoc-if
 182                assoc-if-not
 183                assoc-if
 184                member-if-not
 185                member-if
 186                merge
 187                stable-sort
 188                search
 189                mismatch
 190                count-if-not
 191                count-if
 192                count
 193                position-if-not
 194                position-if
 195                position
 196                find-if-not
 197                find-if
 198                find
 199                nsubstitute-if-not
 200                nsubstitute-if
 201                nsubstitute
 202                substitute-if-not
 203                substitute-if
 204                substitute
 205                delete-duplicates
 206                remove-duplicates
 207                delete-if-not
 208                delete-if
 209                remove-if-not
 210                remove-if
 211                replace
 212                fill
 213                reduce
 214                compiler-macroexpand
 215                define-compiler-macro
 216                assert
 217                check-type
 218                typep
 219                deftype
 220                defstruct
 221                callf2
 222                callf
 223                letf*
 224                letf
 225                rotatef
 226                shiftf
 227                remf
 228                psetf
 229                (define-setf-method . define-setf-expander)
 230                the
 231                locally
 232                multiple-value-setq
 233                multiple-value-bind
 234                symbol-macrolet
 235                macrolet
 236                progv
 237                psetq
 238                do-all-symbols
 239                do-symbols
 240                do*
 241                do
 242                loop
 243                return-from
 244                return
 245                block
 246                etypecase
 247                typecase
 248                ecase
 249                case
 250                load-time-value
 251                eval-when
 252                destructuring-bind
 253                gentemp
 254                gensym
 255                pairlis
 256                acons
 257                subst
 258                adjoin
 259                copy-list
 260                ldiff
 261                list*
 262                cddddr
 263                cdddar
 264                cddadr
 265                cddaar
 266                cdaddr
 267                cdadar
 268                cdaadr
 269                cdaaar
 270                cadddr
 271                caddar
 272                cadadr
 273                cadaar
 274                caaddr
 275                caadar
 276                caaadr
 277                caaaar
 278                cdddr
 279                cddar
 280                cdadr
 281                cdaar
 282                caddr
 283                cadar
 284                caadr
 285                caaar
 286                tenth
 287                ninth
 288                eighth
 289                seventh
 290                sixth
 291                fifth
 292                fourth
 293                third
 294                endp
 295                rest
 296                second
 297                first
 298                svref
 299                copy-seq
 300                evenp
 301                oddp
 302                minusp
 303                plusp
 304                floatp-safe
 305                declaim
 306                proclaim
 307                nth-value
 308                multiple-value-call
 309                multiple-value-apply
 310                multiple-value-list
 311                values-list
 312                values
 313                pushnew
 314                decf
 315                incf
 316                ))
 317   (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
 318                (intern (format "cl-%s" fun)))))
 319     (defalias fun new)))
 320
 321 (defun cl--wrap-in-nil-block (fun &rest args)
 322   `(cl-block nil ,(apply fun args)))
 323 (advice-add 'dolist :around #'cl--wrap-in-nil-block)
 324 (advice-add 'dotimes :around #'cl--wrap-in-nil-block)
 325
 326 (defun cl--pass-args-to-cl-declare (&rest specs)
 327    (macroexpand `(cl-declare ,@specs)))
 328 (advice-add 'declare :after #'cl--pass-args-to-cl-declare)
 329
 330 ;;; Features provided a bit differently in Elisp.
 331
 332 ;; First, the old lexical-let is now better served by `lexical-binding', tho
 333 ;; it's not 100% compatible.
 334
 335 (defvar cl-closure-vars nil)
 336 (defvar cl--function-convert-cache nil)
 337
 338 (defun cl--function-convert (f)
 339   "Special macro-expander for special cases of (function F).
 340 The two cases that are handled are:
 341 - closure-conversion of lambda expressions for `lexical-let'.
 342 - renaming of F when it's a function defined via `cl-labels' or `labels'."
 343   (require 'cl-macs)
 344   (declare-function cl--expr-contains-any "cl-macs" (x y))
 345   (declare-function cl--labels-convert "cl-macs" (f))
 346   (defvar cl--labels-convert-cache)
 347   (cond
 348    ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
 349    ;; *after* handling `function', but we want to stop macroexpansion from
 350    ;; being applied infinitely, so we use a cache to return the exact `form'
 351    ;; being expanded even though we don't receive it.
 352    ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
 353    ((eq (car-safe f) 'lambda)
 354     (let ((body (mapcar (lambda (f)
 355                           (macroexpand-all f macroexpand-all-environment))
 356                         (cddr f))))
 357       (if (and cl-closure-vars
 358                (cl--expr-contains-any body cl-closure-vars))
 359           (let* ((new (mapcar 'cl-gensym cl-closure-vars))
 360                  (sub (cl-pairlis cl-closure-vars new)) (decls nil))
 361             (while (or (stringp (car body))
 362                        (eq (car-safe (car body)) 'interactive))
 363               (push (list 'quote (pop body)) decls))
 364             (put (car (last cl-closure-vars)) 'used t)
 365             `(list 'lambda '(&rest --cl-rest--)
 366                    ,@(cl-sublis sub (nreverse decls))
 367                    (list 'apply
 368                          (list 'quote
 369                                #'(lambda ,(append new (cadr f))
 370                                    ,@(cl-sublis sub body)))
 371                          ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
 372                                           cl-closure-vars)
 373                                   '((quote --cl-rest--))))))
 374         (let* ((newf `(lambda ,(cadr f) ,@body))
 375                (res `(function ,newf)))
 376           (setq cl--function-convert-cache (cons newf res))
 377           res))))
 378    (t
 379     (cl--labels-convert f))))
 380
 381 (defmacro lexical-let (bindings &rest body)
 382   "Like `let', but lexically scoped.
 383 The main visible difference is that lambdas inside BODY will create
 384 lexical closures as in Common Lisp.
 385 \n(fn BINDINGS BODY)"
 386   (declare (indent 1) (debug let))
 387   (let* ((cl-closure-vars cl-closure-vars)
 388          (vars (mapcar (function
 389                         (lambda (x)
 390                           (or (consp x) (setq x (list x)))
 391                           (push (make-symbol (format "--cl-%s--" (car x)))
 392                                 cl-closure-vars)
 393                           (set (car cl-closure-vars) [bad-lexical-ref])
 394                           (list (car x) (cadr x) (car cl-closure-vars))))
 395                        bindings))
 396          (ebody
 397           (macroexpand-all
 398            `(cl-symbol-macrolet
 399                 ,(mapcar (lambda (x)
 400                            `(,(car x) (symbol-value ,(nth 2 x))))
 401                          vars)
 402               ,@body)
 403            (cons (cons 'function #'cl--function-convert)
 404                  macroexpand-all-environment))))
 405     (if (not (get (car (last cl-closure-vars)) 'used))
 406         ;; Turn (let ((foo (cl-gensym)))
 407         ;;        (set foo <val>) ...(symbol-value foo)...)
 408         ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
 409         ;; This is good because it's more efficient but it only works with
 410         ;; dynamic scoping, since with lexical scoping we'd need
 411         ;; (let ((foo <val>)) ...foo...).
 412         `(progn
 413            ,@(mapcar (lambda (x) `(defvar ,(nth 2 x))) vars)
 414            (let ,(mapcar (lambda (x) (list (nth 2 x) (nth 1 x))) vars)
 415            ,(cl-sublis (mapcar (lambda (x)
 416                               (cons (nth 2 x)
 417                                     `',(nth 2 x)))
 418                             vars)
 419                     ebody)))
 420       `(let ,(mapcar (lambda (x)
 421                        (list (nth 2 x)
 422                              `(make-symbol ,(format "--%s--" (car x)))))
 423                      vars)
 424          (setf ,@(apply #'append
 425                         (mapcar (lambda (x)
 426                                   (list `(symbol-value ,(nth 2 x)) (nth 1 x)))
 427                                 vars)))
 428          ,ebody))))
 429
 430 (defmacro lexical-let* (bindings &rest body)
 431   "Like `let*', but lexically scoped.
 432 The main visible difference is that lambdas inside BODY, and in
 433 successive bindings within BINDINGS, will create lexical closures
 434 as in Common Lisp.  This is similar to the behavior of `let*' in
 435 Common Lisp.
 436 \n(fn BINDINGS BODY)"
 437   (declare (indent 1) (debug let))
 438   (if (null bindings) (cons 'progn body)
 439     (setq bindings (reverse bindings))
 440     (while bindings
 441       (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
 442     (car body)))
 443
 444 ;; This should really have some way to shadow 'byte-compile properties, etc.
 445 (defmacro flet (bindings &rest body)
 446   "Make temporary overriding function definitions.
 447 This is an analogue of a dynamically scoped `let' that operates on the function
 448 cell of FUNCs rather than their value cell.
 449 If you want the Common-Lisp style of `flet', you should use `cl-flet'.
 450 The FORMs are evaluated with the specified function definitions in place,
 451 then the definitions are undone (the FUNCs go back to their previous
 452 definitions, or lack thereof).
 453
 454 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
 455   (declare (indent 1) (debug cl-flet)
 456            (obsolete "use either `cl-flet' or `cl-letf'."  "24.3"))
 457   `(letf ,(mapcar
 458            (lambda (x)
 459              (if (or (and (fboundp (car x))
 460                           (eq (car-safe (symbol-function (car x))) 'macro))
 461                      (cdr (assq (car x) macroexpand-all-environment)))
 462                  (error "Use `labels', not `flet', to rebind macro names"))
 463              (let ((func `(cl-function
 464                            (lambda ,(cadr x)
 465                              (cl-block ,(car x) ,@(cddr x))))))
 466                (when (cl--compiling-file)
 467                  ;; Bug#411.  It would be nice to fix this.
 468                  (and (get (car x) 'byte-compile)
 469                       (error "Byte-compiling a redefinition of `%s' \
 470 will not work - use `labels' instead" (symbol-name (car x))))
 471                  ;; FIXME This affects the rest of the file, when it
 472                  ;; should be restricted to the flet body.
 473                  (and (boundp 'byte-compile-function-environment)
 474                       (push (cons (car x) (eval func))
 475                             byte-compile-function-environment)))
 476                (list `(symbol-function ',(car x)) func)))
 477            bindings)
 478      ,@body))
 479
 480 (defmacro labels (bindings &rest body)
 481   "Make temporary function bindings.
 482 Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
 483 rather than relying on `lexical-binding'."
 484   (declare (indent 1) (debug cl-flet) (obsolete cl-labels "24.3"))
 485   (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
 486     (dolist (binding bindings)
 487       ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
 488       ;; because these var's *names* get added to the macro-environment.
 489       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
 490         (push var vars)
 491         (push `(cl-function (lambda . ,(cdr binding))) sets)
 492         (push var sets)
 493         (push (cons (car binding)
 494                     `(lambda (&rest cl-labels-args)
 495                        (cl-list* 'funcall ',var
 496                                  cl-labels-args)))
 497               newenv)))
 498     (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))
 499
 500 ;; Generalized variables are provided by gv.el, but some details are
 501 ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
 502 ;; still need to support old users of cl.el.
 503
 504 (defun cl--gv-adapt (cl-gv do)
 505   ;; This function is used by all .elc files that use define-setf-expander and
 506   ;; were compiled with Emacs>=24.3.
 507   (let ((vars (nth 0 cl-gv))
 508         (vals (nth 1 cl-gv))
 509         (binds ())
 510         (substs ()))
 511     ;; Use cl-sublis as was done in cl-setf-do-modify.
 512     (while vars
 513       (if (macroexp-copyable-p (car vals))
 514           (push (cons (pop vars) (pop vals)) substs)
 515         (push (list (pop vars) (pop vals)) binds)))
 516     (macroexp-let*
 517      binds
 518      (funcall do (cl-sublis substs (nth 4 cl-gv))
 519               ;; We'd like to do something like
 520               ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
 521               (lambda (exp)
 522                 (macroexp-let2 macroexp-copyable-p v exp
 523                   (cl-sublis (cons (cons (car (nth 2 cl-gv)) v)
 524                                    substs)
 525                              (nth 3 cl-gv))))))))
 526
 527 (defmacro define-setf-expander (name arglist &rest body)
 528   "Define a `setf' method.
 529 This method shows how to handle `setf's to places of the form
 530 \(NAME ARGS...).  The argument forms ARGS are bound according to
 531 ARGLIST, as if NAME were going to be expanded as a macro, then
 532 the BODY forms are executed and must return a list of five elements:
 533 a temporary-variables list, a value-forms list, a store-variables list
 534 \(of length one), a store-form, and an access- form.
 535
 536 See `gv-define-expander', and `gv-define-setter' for better and
 537 simpler ways to define setf-methods."
 538   (declare (debug
 539             (&define name cl-lambda-list cl-declarations-or-string def-body)))
 540   `(progn
 541      ,@(if (stringp (car body))
 542            (list `(put ',name 'setf-documentation ,(pop body))))
 543      (gv-define-expander ,name
 544        (cl-function
 545         (lambda (do ,@arglist)
 546           (cl--gv-adapt (progn ,@body) do))))))
 547
 548 (defmacro defsetf (name arg1 &rest args)
 549   "Define a `setf' method.
 550 This macro is an easy-to-use substitute for `define-setf-expander'
 551 that works well for simple place forms.
 552
 553 In the simple `defsetf' form, `setf's of the form (setf (NAME
 554 ARGS...) VAL) are transformed to function or macro calls of the
 555 form (FUNC ARGS... VAL).  For example:
 556
 557   (defsetf aref aset)
 558
 559 You can replace this form with `gv-define-simple-setter'.
 560
 561 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
 562
 563 Here, the above `setf' call is expanded by binding the argument
 564 forms ARGS according to ARGLIST, binding the value form VAL to
 565 STORE, then executing BODY, which must return a Lisp form that
 566 does the necessary `setf' operation.  Actually, ARGLIST and STORE
 567 may be bound to temporary variables which are introduced
 568 automatically to preserve proper execution order of the arguments.
 569 For example:
 570
 571   (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v))
 572
 573 You can replace this form with `gv-define-setter'.
 574
 575 \(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
 576   (declare (debug
 577             (&define name
 578                      [&or [symbolp &optional stringp]
 579                           [cl-lambda-list (symbolp)]]
 580                      cl-declarations-or-string def-body)))
 581   (if (and (listp arg1) (consp args))
 582       ;; Like `gv-define-setter' but with `cl-function'.
 583       `(gv-define-expander ,name
 584          (lambda (do &rest args)
 585            (gv--defsetter ',name
 586                           (cl-function
 587                            (lambda (,@(car args) ,@arg1) ,@(cdr args)))
 588                           do args)))
 589     `(gv-define-simple-setter ,name ,arg1 ,(car args))))
 590
 591 ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
 592 ;; to find a case where it worked.  The code below tries to handle it as well.
 593 ;; (defun cl--setf-apply (form last-witness last)
 594 ;;   (cond
 595 ;;    ((not (consp form)) form)
 596 ;;    ((eq (ignore-errors (car (last form))) last-witness)
 597 ;;     `(apply #',(car form) ,@(butlast (cdr form)) ,last))
 598 ;;    ((and (memq (car form) '(let let*))
 599 ;;          (rassoc (list last-witness) (cadr form)))
 600 ;;     (let ((rebind (rassoc (list last-witness) (cadr form))))
 601 ;;     `(,(car form) ,(remq rebind (cadr form))
 602 ;;       ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
 603 ;;                 (cddr form)))))
 604 ;;    (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
 605 ;; (gv-define-setter apply (val fun &rest args)
 606 ;;   (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
 607 ;;          (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
 608 ;;   (let* ((butlast (butlast args))
 609 ;;          (last (car (last args)))
 610 ;;          (last-witness (make-symbol "--cl-tailarg--"))
 611 ;;          (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
 612 ;;                               macroexpand-all-environment)))
 613 ;;     (cl--setf-apply setter last-witness last)))
 614
 615
 616 ;; FIXME: CL used to provide get-setf-method, which was used by some
 617 ;; setf-expanders, but now that we use gv.el, it is a lot more difficult
 618 ;; and in general impossible to provide get-setf-method.  Hopefully, it
 619 ;; won't be needed.  If needed, we'll have to do something nasty along the
 620 ;; lines of
 621 ;; (defun get-setf-method (place &optional env)
 622 ;;   (let* ((witness (list 'cl-gsm))
 623 ;;          (expansion (gv-letplace (getter setter) place
 624 ;;                      `(,witness ,getter ,(funcall setter witness)))))
 625 ;;     ...find "let prefix" of expansion, extract getter and setter from
 626 ;;     ...the rest, and build the 5-tuple))
 627 (make-obsolete 'get-setf-method 'gv-letplace "24.3")
 628
 629 (declare-function cl--arglist-args "cl-macs" (args))
 630
 631 (defmacro define-modify-macro (name arglist func &optional doc)
 632   "Define a `setf'-like modify macro.
 633 If NAME is called, it combines its PLACE argument with the other
 634 arguments from ARGLIST using FUNC.  For example:
 635
 636   (define-modify-macro incf (&optional (n 1)) +)
 637
 638 You can replace this macro with `gv-letplace'."
 639   (declare (debug
 640             (&define name cl-lambda-list ;; should exclude &key
 641                      symbolp &optional stringp)))
 642   (if (memq '&key arglist)
 643       (error "&key not allowed in define-modify-macro"))
 644   (require 'cl-macs)                    ;For cl--arglist-args.
 645   (let ((place (make-symbol "--cl-place--")))
 646     `(cl-defmacro ,name (,place ,@arglist)
 647        ,doc
 648        (,(if (memq '&rest arglist) #'cl-list* #'list)
 649         #'cl-callf ',func ,place
 650         ,@(cl--arglist-args arglist)))))
 651
 652 ;;; Additional compatibility code.
 653 ;; For names that were clean but really aren't needed any more.
 654
 655 (define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3")
 656 (define-obsolete-variable-alias 'cl-macro-environment
 657   'macroexpand-all-environment "24.3")
 658 (define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3")
 659
 660 ;;; Hash tables.
 661 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
 662
 663 ;; No idea if this might still be needed.
 664 (defun cl-not-hash-table (x &optional y &rest _z)
 665   (declare (obsolete nil "24.3"))
 666   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 667
 668 (defvar cl-builtin-gethash (symbol-function 'gethash))
 669 (make-obsolete-variable 'cl-builtin-gethash nil "24.3")
 670 (defvar cl-builtin-remhash (symbol-function 'remhash))
 671 (make-obsolete-variable 'cl-builtin-remhash nil "24.3")
 672 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
 673 (make-obsolete-variable 'cl-builtin-clrhash nil "24.3")
 674 (defvar cl-builtin-maphash (symbol-function 'maphash))
 675
 676 (make-obsolete-variable 'cl-builtin-maphash nil "24.3")
 677 (define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3")
 678 (define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3")
 679 (define-obsolete-function-alias 'cl-gethash 'gethash "24.3")
 680 (define-obsolete-function-alias 'cl-puthash 'puthash "24.3")
 681 (define-obsolete-function-alias 'cl-remhash 'remhash "24.3")
 682 (define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3")
 683 (define-obsolete-function-alias 'cl-maphash 'maphash "24.3")
 684 (define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3")
 685 (define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3")
 686 (define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3")
 687
 688 (define-obsolete-function-alias 'cl-map-keymap-recursively
 689   'cl--map-keymap-recursively "24.3")
 690 (define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3")
 691 (define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3")
 692 (define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3")
 693
 694 (defun cl-maclisp-member (item list)
 695   (declare (obsolete member "24.3"))
 696   (while (and list (not (equal item (car list)))) (setq list (cdr list)))
 697   list)
 698
 699 ;; Used in the expansion of the old `defstruct'.
 700 (defun cl-struct-setf-expander (x name accessor pred-form pos)
 701   (declare (obsolete nil "24.3"))
 702   (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
 703     (list (list temp) (list x) (list store)
 704           `(progn
 705              ,@(and pred-form
 706                     (list `(or ,(cl-subst temp 'cl-x pred-form)
 707                                (error ,(format
 708                                         "%s storing a non-%s"
 709                                         accessor name)))))
 710              ,(if (eq (car (get name 'cl-struct-type)) 'vector)
 711                   `(aset ,temp ,pos ,store)
 712                 `(setcar
 713                   ,(if (<= pos 5)
 714                        (let ((xx temp))
 715                          (while (>= (setq pos (1- pos)) 0)
 716                            (setq xx `(cdr ,xx)))
 717                          xx)
 718                      `(nthcdr ,pos ,temp))
 719                   ,store)))
 720           (list accessor temp))))
 721
 722 (provide 'cl)
 723
 724 (run-hooks 'cl-load-hook)
 725
 726 ;;; cl.el ends here