lisp/emacs-lisp/cl.el

   1 ;;; cl.el --- Compatibility aliases for the old CL library.  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2013 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
  33 ;; (defun cl--rename ()
  34 ;;   (let ((vdefs ())
  35 ;;         (fdefs ())
  36 ;;         (case-fold-search nil)
  37 ;;         (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
  38 ;;     (dolist (file files)
  39 ;;       (with-current-buffer (find-file-noselect file)
  40 ;;         (goto-char (point-min))
  41 ;;         (while (re-search-forward
  42 ;;                 "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
  43 ;;           (let ((name (match-string-no-properties 2))
  44 ;;                 (type (match-string-no-properties 1)))
  45 ;;             (unless (string-match-p "\\`cl-" name)
  46 ;;               (cond
  47 ;;                ((member type '("defvar" "defconst"))
  48 ;;                 (unless (member name vdefs) (push name vdefs)))
  49 ;;                ((member type '("defun" "defsubst" "defalias" "defmacro"))
  50 ;;                 (unless (member name fdefs) (push name fdefs)))
  51 ;;                ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
  52 ;;                                "define-compiler-macro"))
  53 ;;                 nil)
  54 ;;                (t (error "Unknown type %S" type))))))))
  55 ;;     (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
  56 ;;           (conflicts ()))
  57 ;;       (dolist (file files)
  58 ;;         (with-current-buffer (find-file-noselect file)
  59 ;;           (goto-char (point-min))
  60 ;;           (while (re-search-forward re nil t)
  61 ;;             (replace-match "cl-\\&"))
  62 ;;           (save-buffer))))
  63 ;;     (with-current-buffer (find-file-noselect "cl-rename.el")
  64 ;;       (dolist (def vdefs)
  65 ;;         (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
  66 ;;       (dolist (def fdefs)
  67 ;;         (insert (format "(defalias '%s 'cl-%s)\n" def def)))
  68 ;;       (save-buffer))))
  69
  70 ;; (defun cl--unrename ()
  71 ;;   ;; Taken from "Naming Conventions" node of the doc.
  72 ;;   (let* ((names '(defun* defsubst* defmacro* function* member*
  73 ;;                          assoc* rassoc* get* remove* delete*
  74 ;;                          mapcar* sort* floor* ceiling* truncate*
  75 ;;                          round* mod* rem* random*))
  76 ;;          (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
  77 ;;          (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
  78 ;;                      "\\_>")))
  79 ;;     (dolist (file files)
  80 ;;       (with-current-buffer (find-file-noselect file)
  81 ;;         (goto-char (point-min))
  82 ;;         (while (re-search-forward re nil t)
  83 ;;           (delete-region (1- (point)) (point)))
  84 ;;         (save-buffer)))))
  85
  86 (defun cl-unload-function ()
  87   "Stop unloading of the Common Lisp extensions."
  88   (message "Cannot unload the feature `cl'")
  89   ;; Stop standard unloading!
  90   t)
  91
  92 ;;; Aliases to cl-lib's features.
  93
  94 (dolist (var '(
  95                ;; loop-result-var
  96                ;; loop-result
  97                ;; loop-initially
  98                ;; loop-finally
  99                ;; loop-bindings
 100                ;; loop-args
 101                ;; bind-inits
 102                ;; bind-block
 103                ;; lambda-list-keywords
 104                float-negative-epsilon
 105                float-epsilon
 106                least-negative-normalized-float
 107                least-positive-normalized-float
 108                least-negative-float
 109                least-positive-float
 110                most-negative-float
 111                most-positive-float
 112                ;; custom-print-functions
 113                ))
 114   (defvaralias var (intern (format "cl-%s" var))))
 115
 116 (dolist (fun '(
 117                (get* . cl-get)
 118                (random* . cl-random)
 119                (rem* . cl-rem)
 120                (mod* . cl-mod)
 121                (round* . cl-round)
 122                (truncate* . cl-truncate)
 123                (ceiling* . cl-ceiling)
 124                (floor* . cl-floor)
 125                (rassoc* . cl-rassoc)
 126                (assoc* . cl-assoc)
 127                (member* . cl-member)
 128                (delete* . cl-delete)
 129                (remove* . cl-remove)
 130                (defsubst* . cl-defsubst)
 131                (sort* . cl-sort)
 132                (function* . cl-function)
 133                (defmacro* . cl-defmacro)
 134                (defun* . cl-defun)
 135                (mapcar* . cl-mapcar)
 136
 137                remprop
 138                getf
 139                tailp
 140                list-length
 141                nreconc
 142                revappend
 143                concatenate
 144                subseq
 145                random-state-p
 146                make-random-state
 147                signum
 148                isqrt
 149                lcm
 150                gcd
 151                notevery
 152                notany
 153                every
 154                some
 155                mapcon
 156                mapcan
 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                gensym
 254                pairlis
 255                acons
 256                subst
 257                adjoin
 258                copy-list
 259                ldiff
 260                list*
 261                cddddr
 262                cdddar
 263                cddadr
 264                cddaar
 265                cdaddr
 266                cdadar
 267                cdaadr
 268                cdaaar
 269                cadddr
 270                caddar
 271                cadadr
 272                cadaar
 273                caaddr
 274                caadar
 275                caaadr
 276                caaaar
 277                cdddr
 278                cddar
 279                cdadr
 280                cdaar
 281                caddr
 282                cadar
 283                caadr
 284                caaar
 285                tenth
 286                ninth
 287                eighth
 288                seventh
 289                sixth
 290                fifth
 291                fourth
 292                third
 293                endp
 294                rest
 295                second
 296                first
 297                svref
 298                copy-seq
 299                evenp
 300                oddp
 301                minusp
 302                plusp
 303                floatp-safe
 304                declaim
 305                proclaim
 306                nth-value
 307                multiple-value-call
 308                multiple-value-apply
 309                multiple-value-list
 310                values-list
 311                values
 312                pushnew
 313                decf
 314                incf
 315                ))
 316   (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
 317                (intern (format "cl-%s" fun)))))
 318     (defalias fun new)))
 319
 320 (defun cl--wrap-in-nil-block (fun &rest args)
 321   `(cl-block nil ,(apply fun args)))
 322 (advice-add 'dolist :around #'cl--wrap-in-nil-block)
 323 (advice-add 'dotimes :around #'cl--wrap-in-nil-block)
 324
 325 (defun cl--pass-args-to-cl-declare (&rest specs)
 326    (macroexpand `(cl-declare ,@specs)))
 327 (advice-add 'declare :after #'cl--pass-args-to-cl-declare)
 328
 329 ;;; Features provided a bit differently in Elisp.
 330
 331 ;; First, the old lexical-let is now better served by `lexical-binding', tho
 332 ;; it's not 100% compatible.
 333
 334 (defvar cl-closure-vars nil)
 335 (defvar cl--function-convert-cache nil)
 336
 337 (defun cl--function-convert (f)
 338   "Special macro-expander for special cases of (function F).
 339 The two cases that are handled are:
 340 - closure-conversion of lambda expressions for `lexical-let'.
 341 - renaming of F when it's a function defined via `cl-labels' or `labels'."
 342   (require 'cl-macs)
 343   (declare-function cl--expr-contains-any "cl-macs" (x y))
 344   (cond
 345    ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
 346    ;; *after* handling `function', but we want to stop macroexpansion from
 347    ;; being applied infinitely, so we use a cache to return the exact `form'
 348    ;; being expanded even though we don't receive it.
 349    ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
 350    ((eq (car-safe f) 'lambda)
 351     (let ((body (mapcar (lambda (f)
 352                           (macroexpand-all f macroexpand-all-environment))
 353                         (cddr f))))
 354       (if (and cl-closure-vars
 355                (cl--expr-contains-any body cl-closure-vars))
 356           (let* ((new (mapcar 'cl-gensym cl-closure-vars))
 357                  (sub (cl-pairlis cl-closure-vars new)) (decls nil))
 358             (while (or (stringp (car body))
 359                        (eq (car-safe (car body)) 'interactive))
 360               (push (list 'quote (pop body)) decls))
 361             (put (car (last cl-closure-vars)) 'used t)
 362             `(list 'lambda '(&rest --cl-rest--)
 363                    ,@(cl-sublis sub (nreverse decls))
 364                    (list 'apply
 365                          (list 'quote
 366                                #'(lambda ,(append new (cadr f))
 367                                    ,@(cl-sublis sub body)))
 368                          ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
 369                                           cl-closure-vars)
 370                                   '((quote --cl-rest--))))))
 371         (let* ((newf `(lambda ,(cadr f) ,@body))
 372                (res `(function ,newf)))
 373           (setq cl--function-convert-cache (cons newf res))
 374           res))))
 375    (t
 376     (let ((found (assq f macroexpand-all-environment)))
 377       (if (and found (ignore-errors
 378                        (eq (cadr (cl-caddr found)) 'cl-labels-args)))
 379           (cadr (cl-caddr (cl-cadddr found)))
 380         (let ((res `(function ,f)))
 381           (setq cl--function-convert-cache (cons f res))
 382           res))))))
 383
 384 (defmacro lexical-let (bindings &rest body)
 385   "Like `let', but lexically scoped.
 386 The main visible difference is that lambdas inside BODY will create
 387 lexical closures as in Common Lisp.
 388 \n(fn BINDINGS BODY)"
 389   (declare (indent 1) (debug let))
 390   (let* ((cl-closure-vars cl-closure-vars)
 391          (vars (mapcar (function
 392                         (lambda (x)
 393                           (or (consp x) (setq x (list x)))
 394                           (push (make-symbol (format "--cl-%s--" (car x)))
 395                                 cl-closure-vars)
 396                           (set (car cl-closure-vars) [bad-lexical-ref])
 397                           (list (car x) (cadr x) (car cl-closure-vars))))
 398                        bindings))
 399          (ebody
 400           (macroexpand-all
 401            `(cl-symbol-macrolet
 402                 ,(mapcar (lambda (x)
 403                            `(,(car x) (symbol-value ,(cl-caddr x))))
 404                          vars)
 405               ,@body)
 406            (cons (cons 'function #'cl--function-convert)
 407                  macroexpand-all-environment))))
 408     (if (not (get (car (last cl-closure-vars)) 'used))
 409         ;; Turn (let ((foo (cl-gensym)))
 410         ;;        (set foo <val>) ...(symbol-value foo)...)
 411         ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
 412         ;; This is good because it's more efficient but it only works with
 413         ;; dynamic scoping, since with lexical scoping we'd need
 414         ;; (let ((foo <val>)) ...foo...).
 415         `(progn
 416            ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars)
 417            (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars)
 418            ,(cl-sublis (mapcar (lambda (x)
 419                               (cons (cl-caddr x)
 420                                     `',(cl-caddr x)))
 421                             vars)
 422                     ebody)))
 423       `(let ,(mapcar (lambda (x)
 424                        (list (cl-caddr x)
 425                              `(make-symbol ,(format "--%s--" (car x)))))
 426                      vars)
 427          (setf ,@(apply #'append
 428                         (mapcar (lambda (x)
 429                                   (list `(symbol-value ,(cl-caddr x)) (cadr x)))
 430                                 vars)))
 431          ,ebody))))
 432
 433 (defmacro lexical-let* (bindings &rest body)
 434   "Like `let*', but lexically scoped.
 435 The main visible difference is that lambdas inside BODY, and in
 436 successive bindings within BINDINGS, will create lexical closures
 437 as in Common Lisp.  This is similar to the behavior of `let*' in
 438 Common Lisp.
 439 \n(fn BINDINGS BODY)"
 440   (declare (indent 1) (debug let))
 441   (if (null bindings) (cons 'progn body)
 442     (setq bindings (reverse bindings))
 443     (while bindings
 444       (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
 445     (car body)))
 446
 447 ;; This should really have some way to shadow 'byte-compile properties, etc.
 448 (defmacro flet (bindings &rest body)
 449   "Make temporary overriding function definitions.
 450 This is an analogue of a dynamically scoped `let' that operates on the function
 451 cell of FUNCs rather than their value cell.
 452 If you want the Common-Lisp style of `flet', you should use `cl-flet'.
 453 The FORMs are evaluated with the specified function definitions in place,
 454 then the definitions are undone (the FUNCs go back to their previous
 455 definitions, or lack thereof).
 456
 457 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
 458   (declare (indent 1) (debug cl-flet)
 459            (obsolete "use either `cl-flet' or `cl-letf'."  "24.3"))
 460   `(letf ,(mapcar
 461            (lambda (x)
 462              (if (or (and (fboundp (car x))
 463                           (eq (car-safe (symbol-function (car x))) 'macro))
 464                      (cdr (assq (car x) macroexpand-all-environment)))
 465                  (error "Use `labels', not `flet', to rebind macro names"))
 466              (let ((func `(cl-function
 467                            (lambda ,(cadr x)
 468                              (cl-block ,(car x) ,@(cddr x))))))
 469                (when (cl--compiling-file)
 470                  ;; Bug#411.  It would be nice to fix this.
 471                  (and (get (car x) 'byte-compile)
 472                       (error "Byte-compiling a redefinition of `%s' \
 473 will not work - use `labels' instead" (symbol-name (car x))))
 474                  ;; FIXME This affects the rest of the file, when it
 475                  ;; should be restricted to the flet body.
 476                  (and (boundp 'byte-compile-function-environment)
 477                       (push (cons (car x) (eval func))
 478                             byte-compile-function-environment)))
 479                (list `(symbol-function ',(car x)) func)))
 480            bindings)
 481      ,@body))
 482
 483 (defmacro labels (bindings &rest body)
 484   "Make temporary function bindings.
 485 Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
 486 rather than relying on `lexical-binding'."
 487   (declare (indent 1) (debug cl-flet) (obsolete cl-labels "24.3"))
 488   (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
 489     (dolist (binding bindings)
 490       ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
 491       ;; because these var's *names* get added to the macro-environment.
 492       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
 493         (push var vars)
 494         (push `(cl-function (lambda . ,(cdr binding))) sets)
 495         (push var sets)
 496         (push (cons (car binding)
 497                     `(lambda (&rest cl-labels-args)
 498                        (cl-list* 'funcall ',var
 499                                  cl-labels-args)))
 500               newenv)))
 501     (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))
 502
 503 ;; Generalized variables are provided by gv.el, but some details are
 504 ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
 505 ;; still need to support old users of cl.el.
 506
 507 (defun cl--gv-adapt (cl-gv do)
 508   ;; This function is used by all .elc files that use define-setf-expander and
 509   ;; were compiled with Emacs>=24.3.
 510   (let ((vars (nth 0 cl-gv))
 511         (vals (nth 1 cl-gv))
 512         (binds ())
 513         (substs ()))
 514     ;; Use cl-sublis as was done in cl-setf-do-modify.
 515     (while vars
 516       (if (macroexp-copyable-p (car vals))
 517           (push (cons (pop vars) (pop vals)) substs)
 518         (push (list (pop vars) (pop vals)) binds)))
 519     (macroexp-let*
 520      binds
 521      (funcall do (cl-sublis substs (nth 4 cl-gv))
 522               ;; We'd like to do something like
 523               ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
 524               (lambda (exp)
 525                 (macroexp-let2 macroexp-copyable-p v exp
 526                   (cl-sublis (cons (cons (car (nth 2 cl-gv)) v)
 527                                    substs)
 528                              (nth 3 cl-gv))))))))
 529
 530 (defmacro define-setf-expander (name arglist &rest body)
 531   "Define a `setf' method.
 532 This method shows how to handle `setf's to places of the form
 533 \(NAME ARGS...).  The argument forms ARGS are bound according to
 534 ARGLIST, as if NAME were going to be expanded as a macro, then
 535 the BODY forms are executed and must return a list of five elements:
 536 a temporary-variables list, a value-forms list, a store-variables list
 537 \(of length one), a store-form, and an access- form.
 538
 539 See `gv-define-expander', and `gv-define-setter' for better and
 540 simpler ways to define setf-methods."
 541   (declare (debug
 542             (&define name cl-lambda-list cl-declarations-or-string def-body)))
 543   `(progn
 544      ,@(if (stringp (car body))
 545            (list `(put ',name 'setf-documentation ,(pop body))))
 546      (gv-define-expander ,name
 547        (cl-function
 548         (lambda (do ,@arglist)
 549           (cl--gv-adapt (progn ,@body) do))))))
 550
 551 (defmacro defsetf (name arg1 &rest args)
 552   "Define a `setf' method.
 553 This macro is an easy-to-use substitute for `define-setf-expander'
 554 that works well for simple place forms.
 555
 556 In the simple `defsetf' form, `setf's of the form (setf (NAME
 557 ARGS...) VAL) are transformed to function or macro calls of the
 558 form (FUNC ARGS... VAL).  For example:
 559
 560   (defsetf aref aset)
 561
 562 You can replace this form with `gv-define-simple-setter'.
 563
 564 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
 565
 566 Here, the above `setf' call is expanded by binding the argument
 567 forms ARGS according to ARGLIST, binding the value form VAL to
 568 STORE, then executing BODY, which must return a Lisp form that
 569 does the necessary `setf' operation.  Actually, ARGLIST and STORE
 570 may be bound to temporary variables which are introduced
 571 automatically to preserve proper execution order of the arguments.
 572 For example:
 573
 574   (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
 575
 576 You can replace this form with `gv-define-setter'.
 577
 578 \(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
 579   (declare (debug
 580             (&define name
 581                      [&or [symbolp &optional stringp]
 582                           [cl-lambda-list (symbolp)]]
 583                      cl-declarations-or-string def-body)))
 584   (if (and (listp arg1) (consp args))
 585       ;; Like `gv-define-setter' but with `cl-function'.
 586       `(gv-define-expander ,name
 587          (lambda (do &rest args)
 588            (gv--defsetter ',name
 589                           (cl-function
 590                            (lambda (,@(car args) ,@arg1) ,@(cdr args)))
 591                           do args)))
 592     `(gv-define-simple-setter ,name ,arg1 ,(car args))))
 593
 594 ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
 595 ;; to find a case where it worked.  The code below tries to handle it as well.
 596 ;; (defun cl--setf-apply (form last-witness last)
 597 ;;   (cond
 598 ;;    ((not (consp form)) form)
 599 ;;    ((eq (ignore-errors (car (last form))) last-witness)
 600 ;;     `(apply #',(car form) ,@(butlast (cdr form)) ,last))
 601 ;;    ((and (memq (car form) '(let let*))
 602 ;;          (rassoc (list last-witness) (cadr form)))
 603 ;;     (let ((rebind (rassoc (list last-witness) (cadr form))))
 604 ;;     `(,(car form) ,(remq rebind (cadr form))
 605 ;;       ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
 606 ;;                 (cddr form)))))
 607 ;;    (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
 608 ;; (gv-define-setter apply (val fun &rest args)
 609 ;;   (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
 610 ;;          (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
 611 ;;   (let* ((butlast (butlast args))
 612 ;;          (last (car (last args)))
 613 ;;          (last-witness (make-symbol "--cl-tailarg--"))
 614 ;;          (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
 615 ;;                               macroexpand-all-environment)))
 616 ;;     (cl--setf-apply setter last-witness last)))
 617
 618
 619 ;; FIXME: CL used to provide get-setf-method, which was used by some
 620 ;; setf-expanders, but now that we use gv.el, it is a lot more difficult
 621 ;; and in general impossible to provide get-setf-method.  Hopefully, it
 622 ;; won't be needed.  If needed, we'll have to do something nasty along the
 623 ;; lines of
 624 ;; (defun get-setf-method (place &optional env)
 625 ;;   (let* ((witness (list 'cl-gsm))
 626 ;;          (expansion (gv-letplace (getter setter) place
 627 ;;                      `(,witness ,getter ,(funcall setter witness)))))
 628 ;;     ...find "let prefix" of expansion, extract getter and setter from
 629 ;;     ...the rest, and build the 5-tuple))
 630 (make-obsolete 'get-setf-method 'gv-letplace "24.3")
 631
 632 (defmacro define-modify-macro (name arglist func &optional doc)
 633   "Define a `setf'-like modify macro.
 634 If NAME is called, it combines its PLACE argument with the other
 635 arguments from ARGLIST using FUNC.  For example:
 636
 637   (define-modify-macro incf (&optional (n 1)) +)
 638
 639 You can replace this macro with `gv-letplace'."
 640   (declare (debug
 641             (&define name cl-lambda-list ;; should exclude &key
 642                      symbolp &optional stringp)))
 643   (if (memq '&key arglist)
 644       (error "&key not allowed in define-modify-macro"))
 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