lisp/emacs-lisp/cl.el

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