code.delx.au - gnu-emacs-elpa/blob - packages/cl-lib/cl-lib.el

   1 ;;; cl-lib.el --- Properly prefixed CL functions and macros  -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 2012, 2013, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; vcomment: Emacs-24.3's version is 1.0 so this has to stay below.
   7 ;; Version: 0.5
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; This is a forward compatibility package, which provides (a subset of) the
  25 ;; features of the cl-lib package introduced in Emacs-24.3, for use on
  26 ;; previous emacsen.
  27
  28 ;; Make sure this is installed *late* in your `load-path`, i.e. after Emacs's
  29 ;; built-in .../lisp/emacs-lisp directory, so that if/when you upgrade to
  30 ;; Emacs-24.3, the built-in version of the file will take precedence, otherwise
  31 ;; you could get into trouble (although we try to hack our way around the
  32 ;; problem in case it happens).
  33
  34 ;; This code is largely copied from Emacs-24.3's cl.el, with the alias bindings
  35 ;; simply reversed.
  36
  37 ;;; Code:
  38
  39 ;; We need to handle the situation where this package is used with an Emacs
  40 ;; that comes with a real cl-lib (i.e. ≥24.3).
  41
  42 ;; First line of defense: try to make sure the built-in cl-lib comes earlier in
  43 ;; load-path so we never get loaded:
  44 ;;;###autoload (let ((d (file-name-directory #$)))
  45 ;;;###autoload   (when (member d load-path)
  46 ;;;###autoload     (setq load-path (append (remove d load-path) (list d)))))
  47
  48 (when (functionp 'macroexp--compiler-macro)
  49   ;; `macroexp--compiler-macro' was introduced as part of the big CL
  50   ;; reorganization which moved/reimplemented some of CL into core (mostly the
  51   ;; setf and compiler-macro support), so its presence indicates we're running
  52   ;; in an Emacs that comes with the new cl-lib.el, where this file should
  53   ;; never be loaded!
  54   (message "Real cl-lib shadowed by compatibility cl-lib? (%s)" load-file-name)
  55   (when load-file-name
  56     ;; (message "Let's try to patch things up")
  57     (let ((loaddir (file-name-directory load-file-name))
  58           load-path-dir)
  59       ;; Find the problematic directory from load-path.
  60       (dolist (dir load-path)
  61         (if (equal loaddir (expand-file-name (file-name-as-directory dir)))
  62             (setq load-path-dir dir)))
  63       (when load-path-dir
  64         ;; (message "Let's move the offending dir to the end")
  65         (setq load-path (append (remove load-path-dir load-path)
  66                                 (list load-path-dir)))
  67         ;; Here we could manually load cl-lib and then return immediately.
  68         ;; But Emacs currently doesn't provide any way for a file to "return
  69         ;; immediately", so instead we make sure the rest of the file does not
  70         ;; throw away any pre-existing definition.
  71         ))))
  72
  73 (require 'cl)
  74
  75 ;; Some of Emacs-24.3's cl.el definition are not just aliases, because either
  76 ;; the feature was dropped from cl-lib.el or because the cl-lib version is
  77 ;; not fully compatible.
  78 ;; Let's just not include them here, since it is very important that if code
  79 ;; works with this cl-lib.el it should also work with Emacs-24.3's cl-lib.el,
  80 ;; whereas the reverse is much less important.
  81
  82 (dolist (var '(
  83                ;; loop-result-var
  84                ;; loop-result
  85                ;; loop-initially
  86                ;; loop-finally
  87                ;; loop-bindings
  88                ;; loop-args
  89                ;; bind-inits
  90                ;; bind-block
  91                ;; lambda-list-keywords
  92                float-negative-epsilon
  93                float-epsilon
  94                least-negative-normalized-float
  95                least-positive-normalized-float
  96                least-negative-float
  97                least-positive-float
  98                most-negative-float
  99                most-positive-float
 100                ;; custom-print-functions
 101                ))
 102   (let ((new (intern (format "cl-%s" var))))
 103     (unless (boundp new) (defvaralias new var))))
 104
 105 ;; The following cl-lib functions were already defined in the old cl.el,
 106 ;; with a different meaning:
 107 ;; - cl-position and cl-delete-duplicates
 108 ;;   the two meanings are clearly different, but we can distinguish which was
 109 ;;   meant by looking at the arguments.
 110 ;; - cl-member
 111 ;;   the old meaning hasn't been used for a long time and is a subset of the
 112 ;;   new, so we can simply override it.
 113 ;; - cl-adjoin
 114 ;;   the old meaning is actually the same as the new except for optimizations.
 115
 116 (dolist (fun '(
 117                (get* . cl-get)
 118                (random* . cl-random)
 119                (rem* . cl-rem)
 120                (mod* . cl-mod)
 121                (round* . cl-round)
 122                (truncate* . cl-truncate)
 123                (ceiling* . cl-ceiling)
 124                (floor* . cl-floor)
 125                (rassoc* . cl-rassoc)
 126                (assoc* . cl-assoc)
 127                ;; (member* . cl-member) ;Handle specially below.
 128                (delete* . cl-delete)
 129                (remove* . cl-remove)
 130                (defsubst* . cl-defsubst)
 131                (sort* . cl-sort)
 132                (function* . cl-function)
 133                (defmacro* . cl-defmacro)
 134                (defun* . cl-defun)
 135                (mapcar* . cl-mapcar)
 136
 137                remprop
 138                getf
 139                tailp
 140                list-length
 141                nreconc
 142                revappend
 143                concatenate
 144                subseq
 145                random-state-p
 146                make-random-state
 147                signum
 148                isqrt
 149                lcm
 150                gcd
 151                notevery
 152                notany
 153                every
 154                some
 155                mapcon
 156                mapcan
 157                mapl
 158                maplist
 159                map
 160                equalp
 161                coerce
 162                tree-equal
 163                nsublis
 164                sublis
 165                nsubst-if-not
 166                nsubst-if
 167                nsubst
 168                subst-if-not
 169                subst-if
 170                subsetp
 171                nset-exclusive-or
 172                set-exclusive-or
 173                nset-difference
 174                set-difference
 175                nintersection
 176                intersection
 177                nunion
 178                union
 179                rassoc-if-not
 180                rassoc-if
 181                assoc-if-not
 182                assoc-if
 183                member-if-not
 184                member-if
 185                merge
 186                stable-sort
 187                search
 188                mismatch
 189                count-if-not
 190                count-if
 191                count
 192                position-if-not
 193                position-if
 194                ;; position ;Handle specially via defadvice below.
 195                find-if-not
 196                find-if
 197                find
 198                nsubstitute-if-not
 199                nsubstitute-if
 200                nsubstitute
 201                substitute-if-not
 202                substitute-if
 203                substitute
 204                ;; delete-duplicates ;Handle specially via defadvice below.
 205                remove-duplicates
 206                delete-if-not
 207                delete-if
 208                remove-if-not
 209                remove-if
 210                replace
 211                fill
 212                reduce
 213                compiler-macroexpand
 214                define-compiler-macro
 215                assert
 216                check-type
 217                typep
 218                deftype
 219                defstruct
 220                callf2
 221                callf
 222                letf*
 223                letf
 224                rotatef
 225                shiftf
 226                remf
 227                psetf
 228                declare
 229                the
 230                locally
 231                multiple-value-setq
 232                multiple-value-bind
 233                symbol-macrolet
 234                macrolet
 235                progv
 236                psetq
 237                do-all-symbols
 238                do-symbols
 239                dotimes
 240                dolist
 241                do*
 242                do
 243                loop
 244                return-from
 245                return
 246                block
 247                etypecase
 248                typecase
 249                ecase
 250                case
 251                load-time-value
 252                eval-when
 253                destructuring-bind
 254                gentemp
 255                gensym
 256                pairlis
 257                acons
 258                subst
 259                ;; adjoin ;It's already defined.
 260                copy-list
 261                ldiff
 262                list*
 263                cddddr
 264                cdddar
 265                cddadr
 266                cddaar
 267                cdaddr
 268                cdadar
 269                cdaadr
 270                cdaaar
 271                cadddr
 272                caddar
 273                cadadr
 274                cadaar
 275                caaddr
 276                caadar
 277                caaadr
 278                caaaar
 279                cdddr
 280                cddar
 281                cdadr
 282                cdaar
 283                caddr
 284                cadar
 285                caadr
 286                caaar
 287                tenth
 288                ninth
 289                eighth
 290                seventh
 291                sixth
 292                fifth
 293                fourth
 294                third
 295                endp
 296                rest
 297                second
 298                first
 299                svref
 300                copy-seq
 301                evenp
 302                oddp
 303                minusp
 304                plusp
 305                floatp-safe
 306                declaim
 307                proclaim
 308                nth-value
 309                multiple-value-call
 310                multiple-value-apply
 311                multiple-value-list
 312                values-list
 313                values
 314                pushnew
 315                decf
 316                incf
 317
 318                dolist
 319                dotimes
 320                ))
 321   (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
 322                (intern (format "cl-%s" fun)))))
 323     (if (fboundp new)
 324         (unless (or (eq (symbol-function new) fun)
 325                     (eq new (and (symbolp fun) (fboundp fun)
 326                                  (symbol-function fun))))
 327           (message "%S already defined, not rebinding" new))
 328       (defalias new fun))))
 329
 330 (unless (symbolp (symbol-function 'position))
 331   (autoload 'cl-position "cl-seq")
 332   (defadvice cl-position (around cl-lib (cl-item cl-seq &rest cl-keys) activate)
 333   (let ((argk (ad-get-args 2)))
 334     (if (or (null argk) (keywordp (car argk)))
 335         ;; This is a call to cl-lib's `cl-position'.
 336         (setq ad-return-value
 337               (apply #'position (ad-get-arg 0) (ad-get-arg 1) argk))
 338       ;; Must be a call to cl's old `cl-position'.
 339       ad-do-it))))
 340
 341 (unless (symbolp (symbol-function 'delete-duplicates))
 342   (autoload 'cl-delete-duplicates "cl-seq")
 343   (defadvice cl-delete-duplicates (around cl-lib (cl-seq &rest cl-keys) activate)
 344   (let ((argk (ad-get-args 1)))
 345     (if (or (null argk) (keywordp (car argk)))
 346         ;; This is a call to cl-lib's `cl-delete-duplicates'.
 347         (setq ad-return-value
 348               (apply #'delete-duplicates (ad-get-arg 0) argk))
 349       ;; Must be a call to cl's old `cl-delete-duplicates'.
 350       ad-do-it))))
 351
 352 (when (or (not (fboundp 'cl-member))
 353           (eq (symbol-function 'cl-member) #'memq))
 354   (defalias 'cl-member #'member*))
 355
 356 ;; `cl-labels' is not 100% compatible with `labels' when using dynamic scoping
 357 ;; (mostly because it does not turn lambdas that refer to those functions into
 358 ;; closures).  OTOH it is compatible when using lexical scoping.
 359
 360 (unless (fboundp 'cl-labels)
 361   (defmacro cl-labels (&rest args)
 362     (unless (and (boundp 'lexical-binding) lexical-binding)
 363       ;; We used to signal an error rather than a message, but in many uses of
 364       ;; cl-labels, the value of lexical-binding doesn't actually matter.
 365       ;; More importantly, the value of `lexical-binding' here is unreliable
 366       ;; (it does not necessarily reflect faithfully whether the output of this
 367       ;; macro will be interpreted as lexically bound code or not).
 368       (message "This `cl-labels' requires `lexical-binding' to be non-nil"))
 369     `(labels ,@args)))
 370
 371 (provide 'cl-lib)
 372 ;;; cl-lib.el ends here