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