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