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

   1 ;;; cl.el --- Compatibility aliases for the old CL library.
   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 (dolist (var '(
  86                ;; loop-result-var
  87                ;; loop-result
  88                ;; loop-initially
  89                ;; loop-finally
  90                ;; loop-bindings
  91                ;; loop-args
  92                ;; bind-inits
  93                ;; bind-block
  94                ;; lambda-list-keywords
  95                float-negative-epsilon
  96                float-epsilon
  97                least-negative-normalized-float
  98                least-positive-normalized-float
  99                least-negative-float
 100                least-positive-float
 101                most-negative-float
 102                most-positive-float
 103                ;; custom-print-functions
 104                ))
 105   (defvaralias var (intern (format "cl-%s" var))))
 106
 107 (dolist (fun '(
 108                (get* . cl-get)
 109                (random* . cl-random)
 110                (rem* . cl-rem)
 111                (mod* . cl-mod)
 112                (round* . cl-round)
 113                (truncate* . cl-truncate)
 114                (ceiling* . cl-ceiling)
 115                (floor* . cl-floor)
 116                (rassoc* . cl-rassoc)
 117                (assoc* . cl-assoc)
 118                (member* . cl-member)
 119                (delete* . cl-delete)
 120                (remove* . cl-remove)
 121                (defsubst* . cl-defsubst)
 122                (sort* . cl-sort)
 123                (function* . cl-function)
 124                (defmacro* . cl-defmacro)
 125                (defun* . cl-defun)
 126                (mapcar* . cl-mapcar)
 127
 128                remprop
 129                getf
 130                tailp
 131                list-length
 132                nreconc
 133                revappend
 134                concatenate
 135                subseq
 136                random-state-p
 137                make-random-state
 138                signum
 139                isqrt
 140                lcm
 141                gcd
 142                notevery
 143                notany
 144                every
 145                some
 146                mapcon
 147                mapcan
 148                mapl
 149                maplist
 150                map
 151                equalp
 152                coerce
 153                tree-equal
 154                nsublis
 155                sublis
 156                nsubst-if-not
 157                nsubst-if
 158                nsubst
 159                subst-if-not
 160                subst-if
 161                subsetp
 162                nset-exclusive-or
 163                set-exclusive-or
 164                nset-difference
 165                set-difference
 166                nintersection
 167                intersection
 168                nunion
 169                union
 170                rassoc-if-not
 171                rassoc-if
 172                assoc-if-not
 173                assoc-if
 174                member-if-not
 175                member-if
 176                merge
 177                stable-sort
 178                search
 179                mismatch
 180                count-if-not
 181                count-if
 182                count
 183                position-if-not
 184                position-if
 185                position
 186                find-if-not
 187                find-if
 188                find
 189                nsubstitute-if-not
 190                nsubstitute-if
 191                nsubstitute
 192                substitute-if-not
 193                substitute-if
 194                substitute
 195                delete-duplicates
 196                remove-duplicates
 197                delete-if-not
 198                delete-if
 199                remove-if-not
 200                remove-if
 201                replace
 202                fill
 203                reduce
 204                compiler-macroexpand
 205                define-compiler-macro
 206                assert
 207                check-type
 208                typep
 209                deftype
 210                defstruct
 211                define-modify-macro
 212                callf2
 213                callf
 214                letf*
 215                letf
 216                rotatef
 217                shiftf
 218                remf
 219                psetf
 220                setf
 221                get-setf-method
 222                defsetf
 223                (define-setf-method . cl-define-setf-expander)
 224                define-setf-expander
 225                declare
 226                the
 227                locally
 228                multiple-value-setq
 229                multiple-value-bind
 230                symbol-macrolet
 231                macrolet
 232                flet
 233                progv
 234                psetq
 235                do-all-symbols
 236                do-symbols
 237                dotimes
 238                dolist
 239                do*
 240                do
 241                loop
 242                return-from
 243                return
 244                block
 245                etypecase
 246                typecase
 247                ecase
 248                case
 249                load-time-value
 250                eval-when
 251                destructuring-bind
 252                gentemp
 253                gensym
 254                pairlis
 255                acons
 256                subst
 257                adjoin
 258                copy-list
 259                ldiff
 260                list*
 261                cddddr
 262                cdddar
 263                cddadr
 264                cddaar
 265                cdaddr
 266                cdadar
 267                cdaadr
 268                cdaaar
 269                cadddr
 270                caddar
 271                cadadr
 272                cadaar
 273                caaddr
 274                caadar
 275                caaadr
 276                caaaar
 277                cdddr
 278                cddar
 279                cdadr
 280                cdaar
 281                caddr
 282                cadar
 283                caadr
 284                caaar
 285                tenth
 286                ninth
 287                eighth
 288                seventh
 289                sixth
 290                fifth
 291                fourth
 292                third
 293                endp
 294                rest
 295                second
 296                first
 297                svref
 298                copy-seq
 299                evenp
 300                oddp
 301                minusp
 302                plusp
 303                floatp-safe
 304                declaim
 305                proclaim
 306                nth-value
 307                multiple-value-call
 308                multiple-value-apply
 309                multiple-value-list
 310                values-list
 311                values
 312                pushnew
 313                push
 314                pop
 315                decf
 316                incf
 317                ))
 318   (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
 319                (intern (format "cl-%s" fun)))))
 320     (defalias fun new)
 321     ;; If `cl-foo' is declare inline, then make `foo' inline as well, and
 322     ;; similarly.  Same for edebug specifications, indent rules and
 323     ;; doc-string position.
 324     ;; FIXME: For most of them, we should instead follow aliases
 325     ;; where applicable.
 326     (dolist (prop '(byte-optimizer doc-string-elt edebug-form-spec
 327                     lisp-indent-function))
 328       (if (get new prop)
 329         (put fun prop (get new prop))))))
 330
 331 (defvar cl-closure-vars nil)
 332 (defvar cl--function-convert-cache nil)
 333
 334 (defun cl--function-convert (f)
 335   "Special macro-expander for special cases of (function F).
 336 The two cases that are handled are:
 337 - closure-conversion of lambda expressions for `lexical-let'.
 338 - renaming of F when it's a function defined via `cl-labels' or `labels'."
 339   (require 'cl-macs)
 340   (declare-function cl--expr-contains-any "cl-macs" (x y))
 341   (cond
 342    ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
 343    ;; *after* handling `function', but we want to stop macroexpansion from
 344    ;; being applied infinitely, so we use a cache to return the exact `form'
 345    ;; being expanded even though we don't receive it.
 346    ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
 347    ((eq (car-safe f) 'lambda)
 348     (let ((body (mapcar (lambda (f)
 349                           (macroexpand-all f macroexpand-all-environment))
 350                         (cddr f))))
 351       (if (and cl-closure-vars
 352                (cl--expr-contains-any body cl-closure-vars))
 353           (let* ((new (mapcar 'cl-gensym cl-closure-vars))
 354                  (sub (cl-pairlis cl-closure-vars new)) (decls nil))
 355             (while (or (stringp (car body))
 356                        (eq (car-safe (car body)) 'interactive))
 357               (push (list 'quote (pop body)) decls))
 358             (put (car (last cl-closure-vars)) 'used t)
 359             `(list 'lambda '(&rest --cl-rest--)
 360                    ,@(cl-sublis sub (nreverse decls))
 361                    (list 'apply
 362                          (list 'quote
 363                                #'(lambda ,(append new (cadr f))
 364                                    ,@(cl-sublis sub body)))
 365                          ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
 366                                           cl-closure-vars)
 367                                   '((quote --cl-rest--))))))
 368         (let* ((newf `(lambda ,(cadr f) ,@body))
 369                (res `(function ,newf)))
 370           (setq cl--function-convert-cache (cons newf res))
 371           res))))
 372    (t
 373     (let ((found (assq f macroexpand-all-environment)))
 374       (if (and found (ignore-errors
 375                        (eq (cadr (cl-caddr found)) 'cl-labels-args)))
 376           (cadr (cl-caddr (cl-cadddr found)))
 377         (let ((res `(function ,f)))
 378           (setq cl--function-convert-cache (cons f res))
 379           res))))))
 380
 381 (defmacro lexical-let (bindings &rest body)
 382   "Like `let', but lexically scoped.
 383 The main visible difference is that lambdas inside BODY will create
 384 lexical closures as in Common Lisp.
 385 \n(fn BINDINGS BODY)"
 386   (declare (indent 1) (debug let))
 387   (let* ((cl-closure-vars cl-closure-vars)
 388          (vars (mapcar (function
 389                         (lambda (x)
 390                           (or (consp x) (setq x (list x)))
 391                           (push (make-symbol (format "--cl-%s--" (car x)))
 392                                 cl-closure-vars)
 393                           (set (car cl-closure-vars) [bad-lexical-ref])
 394                           (list (car x) (cadr x) (car cl-closure-vars))))
 395                        bindings))
 396          (ebody
 397           (macroexpand-all
 398            `(cl-symbol-macrolet
 399                 ,(mapcar (lambda (x)
 400                            `(,(car x) (symbol-value ,(cl-caddr x))))
 401                          vars)
 402               ,@body)
 403            (cons (cons 'function #'cl--function-convert)
 404                  macroexpand-all-environment))))
 405     (if (not (get (car (last cl-closure-vars)) 'used))
 406         ;; Turn (let ((foo (cl-gensym)))
 407         ;;        (set foo <val>) ...(symbol-value foo)...)
 408         ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
 409         ;; This is good because it's more efficient but it only works with
 410         ;; dynamic scoping, since with lexical scoping we'd need
 411         ;; (let ((foo <val>)) ...foo...).
 412         `(progn
 413            ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars)
 414            (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars)
 415            ,(cl-sublis (mapcar (lambda (x)
 416                               (cons (cl-caddr x)
 417                                     `',(cl-caddr x)))
 418                             vars)
 419                     ebody)))
 420       `(let ,(mapcar (lambda (x)
 421                        (list (cl-caddr x)
 422                              `(make-symbol ,(format "--%s--" (car x)))))
 423                      vars)
 424          (cl-setf ,@(apply #'append
 425                         (mapcar (lambda (x)
 426                                   (list `(symbol-value ,(cl-caddr x)) (cadr x)))
 427                                 vars)))
 428          ,ebody))))
 429
 430 (defmacro lexical-let* (bindings &rest body)
 431   "Like `let*', but lexically scoped.
 432 The main visible difference is that lambdas inside BODY, and in
 433 successive bindings within BINDINGS, will create lexical closures
 434 as in Common Lisp.  This is similar to the behavior of `let*' in
 435 Common Lisp.
 436 \n(fn BINDINGS BODY)"
 437   (declare (indent 1) (debug let))
 438   (if (null bindings) (cons 'progn body)
 439     (setq bindings (reverse bindings))
 440     (while bindings
 441       (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
 442     (car body)))
 443
 444 ;; This should really have some way to shadow 'byte-compile properties, etc.
 445 ;;;###autoload
 446 (defmacro flet (bindings &rest body)
 447   "Make temporary function definitions.
 448 This is an analogue of `let' that operates on the function cell of FUNC
 449 rather than its value cell.  The FORMs are evaluated with the specified
 450 function definitions in place, then the definitions are undone (the FUNCs
 451 go back to their previous definitions, or lack thereof).
 452
 453 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
 454   (declare (indent 1) (debug cl-flet))
 455   `(cl-letf* ,(mapcar
 456             (lambda (x)
 457               (if (or (and (fboundp (car x))
 458                            (eq (car-safe (symbol-function (car x))) 'macro))
 459                       (cdr (assq (car x) macroexpand-all-environment)))
 460                   (error "Use `labels', not `flet', to rebind macro names"))
 461               (let ((func `(cl-function
 462                             (lambda ,(cadr x)
 463                               (cl-block ,(car x) ,@(cddr x))))))
 464                 (when (cl--compiling-file)
 465                   ;; Bug#411.  It would be nice to fix this.
 466                   (and (get (car x) 'byte-compile)
 467                        (error "Byte-compiling a redefinition of `%s' \
 468 will not work - use `labels' instead" (symbol-name (car x))))
 469                   ;; FIXME This affects the rest of the file, when it
 470                   ;; should be restricted to the flet body.
 471                   (and (boundp 'byte-compile-function-environment)
 472                        (push (cons (car x) (eval func))
 473                              byte-compile-function-environment)))
 474                 (list `(symbol-function ',(car x)) func)))
 475             bindings)
 476      ,@body))
 477
 478 (defmacro labels (bindings &rest body)
 479   "Make temporary function bindings.
 480 This is like `flet', except the bindings are lexical instead of dynamic.
 481 Unlike `flet', this macro is fully compliant with the Common Lisp standard.
 482
 483 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
 484   (declare (indent 1) (debug cl-flet))
 485   (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
 486     (dolist (binding bindings)
 487       ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
 488       ;; because these var's *names* get added to the macro-environment.
 489       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
 490         (push var vars)
 491         (push `(cl-function (lambda . ,(cdr binding))) sets)
 492         (push var sets)
 493         (push (cons (car binding)
 494                     `(lambda (&rest cl-labels-args)
 495                        (cl-list* 'funcall ',var
 496                                  cl-labels-args)))
 497               newenv)))
 498     (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))
 499
 500 ;;; Additional compatibility code
 501 ;; For names that were clean but really aren't needed any more.
 502
 503 (define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2")
 504 (define-obsolete-variable-alias 'cl-macro-environment
 505   'macroexpand-all-environment "24.2")
 506 (define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.2")
 507
 508 ;;; Hash tables.
 509 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
 510
 511 ;; No idea if this might still be needed.
 512 (defun cl-not-hash-table (x &optional y &rest z)
 513   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 514 (make-obsolete 'cl-not-hash-table nil "24.2")
 515
 516 (defvar cl-builtin-gethash (symbol-function 'gethash))
 517 (make-obsolete-variable 'cl-builtin-gethash nil "24.2")
 518 (defvar cl-builtin-remhash (symbol-function 'remhash))
 519 (make-obsolete-variable 'cl-builtin-remhash nil "24.2")
 520 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
 521 (make-obsolete-variable 'cl-builtin-clrhash nil "24.2")
 522 (defvar cl-builtin-maphash (symbol-function 'maphash))
 523
 524 (make-obsolete-variable 'cl-builtin-maphash nil "24.2")
 525 (define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.2")
 526 (define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.2")
 527 (define-obsolete-function-alias 'cl-gethash 'gethash "24.2")
 528 (define-obsolete-function-alias 'cl-puthash 'puthash "24.2")
 529 (define-obsolete-function-alias 'cl-remhash 'remhash "24.2")
 530 (define-obsolete-function-alias 'cl-clrhash 'clrhash "24.2")
 531 (define-obsolete-function-alias 'cl-maphash 'maphash "24.2")
 532 (define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.2")
 533 (define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2")
 534 (define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2")
 535
 536 (defun cl-maclisp-member (item list)
 537   (declare (obsolete member "24.2"))
 538   (while (and list (not (equal item (car list)))) (setq list (cdr list)))
 539   list)
 540
 541 ;; FIXME: More candidates: define-modify-macro, define-setf-expander.
 542
 543 (provide 'cl)
 544 ;;; cl.el ends here