cgit.sxemacs.org Git - sxemacs/blob - lisp/cl-extra.el

   1 ;;; cl-extra.el --- Common Lisp extensions for GNU Emacs Lisp (part two)
   2
   3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Version: 2.02
   8 ;; Keywords: extensions, dumped
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Synched up with: FSF 19.34.
  26
  27 ;;; Commentary:
  28
  29 ;; This file is dumped with SXEmacs.
  30
  31 ;; These are extensions to Emacs Lisp that provide a degree of
  32 ;; Common Lisp compatibility, beyond what is already built-in
  33 ;; in Emacs Lisp.
  34 ;;
  35 ;; This package was written by Dave Gillespie; it is a complete
  36 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  37 ;;
  38 ;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19.
  39 ;;
  40 ;; Bug reports, comments, and suggestions are welcome!
  41
  42 ;; This file contains portions of the Common Lisp extensions
  43 ;; package which are autoloaded since they are relatively obscure.
  44
  45 ;; See cl.el for Change Log.
  46
  47
  48 ;;; Code:
  49 (eval-when-compile
  50   (require 'obsolete))
  51
  52 (or (memq 'cl-19 features)
  53     (error "Tried to load `cl-extra' before `cl'!"))
  54
  55
  56 ;;; We define these here so that this file can compile without having
  57 ;;; loaded the cl.el file already.
  58
  59 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
  60 (defmacro cl-pop (place)
  61   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
  62
  63 (defvar cl-emacs-type)
  64
  65
  66 ;;; Type coercion.
  67
  68 (defun coerce (x type)
  69   "Coerce OBJECT to type TYPE.
  70 TYPE is a Common Lisp type specifier."
  71   (cond ((eq type 'list) (if (listp x) x (append x nil)))
  72         ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  73         ((eq type 'string) (if (stringp x) x (concat x)))
  74         ((eq type 'array) (if (arrayp x) x (vconcat x)))
  75         ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
  76         ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
  77         ((and (eq type 'character) (char-int-p x)) (int-char x))
  78         ((and (featurep 'number-types)
  79               (memq type '(int fixnum
  80                            bigz bignum
  81                            integer
  82                            bigq ratio
  83                            rational
  84                            float
  85                            bigf bigfloat
  86                            bigfr
  87                            real
  88                            bigg
  89                            bigc
  90                            ;;complex
  91                            ))
  92               (coerce-number x type)))
  93         ((and (eq type 'integer) (characterp x)) (char-int x))
  94         ((eq type 'float) (float x))
  95         ((eq type 'bit-vector) (if (bit-vector-p x) x
  96                                  (apply 'bit-vector (append x nil))))
  97         ((eq type 'weak-list)
  98          (if (weak-list-p x) x
  99            (let ((wl (make-weak-list)))
 100              (set-weak-list-list wl (if (listp x) x (append x nil)))
 101              wl)))
 102         ((typep x type) x)
 103         (t (error "Can't coerce %s to type %s" x type))))
 104
 105
 106 ;;; Predicates.
 107
 108 (defun equalp (x y)
 109   "Return t if two Lisp objects have similar structures and contents.
 110 This is like `equal', except that it accepts numerically equal
 111 numbers of different types (float vs. integer), and also compares
 112 strings case-insensitively."
 113   (cond ((eq x y) t)
 114         ((stringp x)
 115          (and (stringp y) (= (length x) (length y))
 116               (or (string-equal x y)
 117                   (string-equal (downcase x) (downcase y)))))   ; lazy but simple!
 118         ((characterp x)
 119          (and (characterp y)
 120               (or (char-equal x y)
 121                   (char-equal (downcase x) (downcase y)))))
 122         ((numberp x)
 123          (and (numberp y) (= x y)))
 124         ((consp x)
 125          ;; XEmacs change
 126          (while (and (consp x) (consp y) (equalp (car x) (car y)))
 127            (cl-pop x) (cl-pop y))
 128          (and (not (consp x)) (equalp x y)))
 129         ((vectorp x)
 130          (and (vectorp y) (= (length x) (length y))
 131               (let ((i (length x)))
 132                 (while (and (>= (setq i (1- i)) 0)
 133                             (equalp (aref x i) (aref y i))))
 134                 (< i 0))))
 135         (t (equal x y))))
 136
 137
 138 ;;; Control structures.
 139
 140 (defun cl-mapcar-many (cl-func cl-seqs)
 141   (if (cdr (cdr cl-seqs))
 142       (let* ((cl-res nil)
 143              (cl-n (apply 'min (mapcar 'length cl-seqs)))
 144              (cl-i 0)
 145              (cl-args (copy-sequence cl-seqs))
 146              cl-p1 cl-p2)
 147         (setq cl-seqs (copy-sequence cl-seqs))
 148         (while (< cl-i cl-n)
 149           (setq cl-p1 cl-seqs cl-p2 cl-args)
 150           (while cl-p1
 151             (setcar cl-p2
 152                     (if (consp (car cl-p1))
 153                         (prog1 (car (car cl-p1))
 154                           (setcar cl-p1 (cdr (car cl-p1))))
 155                       (aref (car cl-p1) cl-i)))
 156             (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
 157           (cl-push (apply cl-func cl-args) cl-res)
 158           (setq cl-i (1+ cl-i)))
 159         (nreverse cl-res))
 160     (let ((cl-res nil)
 161           (cl-x (car cl-seqs))
 162           (cl-y (nth 1 cl-seqs)))
 163       (let ((cl-n (min (length cl-x) (length cl-y)))
 164             (cl-i -1))
 165         (while (< (setq cl-i (1+ cl-i)) cl-n)
 166           (cl-push (funcall cl-func
 167                             (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i))
 168                             (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i)))
 169                    cl-res)))
 170       (nreverse cl-res))))
 171
 172 (defun map (cl-type cl-func cl-seq &rest cl-rest)
 173   "Map a function across one or more sequences, returning a sequence.
 174 TYPE is the sequence type to return, FUNC is the function, and SEQS
 175 are the argument sequences."
 176   (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
 177     (and cl-type (coerce cl-res cl-type))))
 178
 179 (defun maplist (cl-func cl-list &rest cl-rest)
 180   "Map FUNC to each sublist of LIST or LISTS.
 181 Like `mapcar', except applies to lists and their cdr's rather than to
 182 the elements themselves."
 183   (if cl-rest
 184       (let ((cl-res nil)
 185             (cl-args (cons cl-list (copy-sequence cl-rest)))
 186             cl-p)
 187         (while (not (memq nil cl-args))
 188           (cl-push (apply cl-func cl-args) cl-res)
 189           (setq cl-p cl-args)
 190           (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) )))
 191         (nreverse cl-res))
 192     (let ((cl-res nil))
 193       (while cl-list
 194         (cl-push (funcall cl-func cl-list) cl-res)
 195         (setq cl-list (cdr cl-list)))
 196       (nreverse cl-res))))
 197
 198
 199 (defun mapc (cl-func cl-seq &rest cl-rest)
 200   "Like `mapcar', but does not accumulate values returned by the function."
 201   (if cl-rest
 202       (apply 'map nil cl-func cl-seq cl-rest)
 203     ;; XEmacs change: in the simplest case we call mapc-internal,
 204     ;; which really doesn't accumulate any results.
 205     (mapc-internal cl-func cl-seq))
 206   cl-seq)
 207
 208 (defun mapl (cl-func cl-list &rest cl-rest)
 209   "Like `maplist', but does not accumulate values returned by the function."
 210   (if cl-rest
 211       (apply 'maplist cl-func cl-list cl-rest)
 212     (let ((cl-p cl-list))
 213       (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
 214   cl-list)
 215
 216 (defun mapcan (cl-func cl-seq &rest cl-rest)
 217   "Like `mapcar', but nconc's together the values returned by the function."
 218   (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
 219
 220 (defun mapcon (cl-func cl-list &rest cl-rest)
 221   "Like `maplist', but nconc's together the values returned by the function."
 222   (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
 223
 224 (defun some (cl-pred cl-seq &rest cl-rest)
 225   "Return true if PREDICATE is true of any element of SEQ or SEQs.
 226 If so, return the true (non-nil) value returned by PREDICATE."
 227   (if (or cl-rest (nlistp cl-seq))
 228       (catch 'cl-some
 229         (apply 'map nil
 230                (function (lambda (&rest cl-x)
 231                            (let ((cl-res (apply cl-pred cl-x)))
 232                              (if cl-res (throw 'cl-some cl-res)))))
 233                cl-seq cl-rest) nil)
 234     (let ((cl-x nil))
 235       (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq))))))
 236       cl-x)))
 237
 238 (defun every (cl-pred cl-seq &rest cl-rest)
 239   "Return true if PREDICATE is true of every element of SEQ or SEQs."
 240   (if (or cl-rest (nlistp cl-seq))
 241       (catch 'cl-every
 242         (apply 'map nil
 243                (function (lambda (&rest cl-x)
 244                            (or (apply cl-pred cl-x) (throw 'cl-every nil))))
 245                cl-seq cl-rest) t)
 246     (while (and cl-seq (funcall cl-pred (car cl-seq)))
 247       (setq cl-seq (cdr cl-seq)))
 248     (null cl-seq)))
 249
 250 (defun notany (cl-pred cl-seq &rest cl-rest)
 251   "Return true if PREDICATE is false of every element of SEQ or SEQs."
 252   (not (apply 'some cl-pred cl-seq cl-rest)))
 253
 254 (defun notevery (cl-pred cl-seq &rest cl-rest)
 255   "Return true if PREDICATE is false of some element of SEQ or SEQs."
 256   (not (apply 'every cl-pred cl-seq cl-rest)))
 257
 258 ;;; Support for `loop'.
 259 (defun cl-map-keymap (cl-func cl-map)
 260   (while (symbolp cl-map) (setq cl-map (symbol-function cl-map)))
 261   (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map)
 262     (if (listp cl-map)
 263         (let ((cl-p cl-map))
 264           (while (consp (setq cl-p (cdr cl-p)))
 265             (cond ((consp (car cl-p))
 266                    (funcall cl-func (car (car cl-p)) (cdr (car cl-p))))
 267                   ((vectorp (car cl-p))
 268                    (cl-map-keymap cl-func (car cl-p)))
 269                   ((eq (car cl-p) 'keymap)
 270                    (setq cl-p nil)))))
 271       (let ((cl-i -1))
 272         (while (< (setq cl-i (1+ cl-i)) (length cl-map))
 273           (if (aref cl-map cl-i)
 274               (funcall cl-func cl-i (aref cl-map cl-i))))))))
 275
 276 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
 277   (or cl-base
 278       (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0]))))
 279   (cl-map-keymap
 280    (function
 281     (lambda (cl-key cl-bind)
 282       (aset cl-base (1- (length cl-base)) cl-key)
 283       (if (keymapp cl-bind)
 284           (cl-map-keymap-recursively
 285            cl-func-rec cl-bind
 286            (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat)
 287                     cl-base (list 0)))
 288         (funcall cl-func-rec cl-base cl-bind))))
 289    cl-map))
 290
 291 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
 292   (or cl-what (setq cl-what (current-buffer)))
 293   (if (bufferp cl-what)
 294       (let (cl-mark cl-mark2 (cl-next t) cl-next2)
 295         (save-excursion
 296           (set-buffer cl-what)
 297           (setq cl-mark (copy-marker (or cl-start (point-min))))
 298           (setq cl-mark2 (and cl-end (copy-marker cl-end))))
 299         (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
 300           (setq cl-next (and (fboundp 'next-property-change)
 301                              (if cl-prop (next-single-property-change
 302                                           cl-mark cl-prop cl-what)
 303                                (next-property-change cl-mark cl-what)))
 304                 cl-next2 (or cl-next (save-excursion
 305                                        (set-buffer cl-what) (point-max))))
 306           (funcall cl-func (prog1 (marker-position cl-mark)
 307                              (set-marker cl-mark cl-next2))
 308                    (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
 309         (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
 310     (or cl-start (setq cl-start 0))
 311     (or cl-end (setq cl-end (length cl-what)))
 312     (while (< cl-start cl-end)
 313       (let ((cl-next (or (and (fboundp 'next-property-change)
 314                               (if cl-prop (next-single-property-change
 315                                            cl-start cl-prop cl-what)
 316                                 (next-property-change cl-start cl-what)))
 317                          cl-end)))
 318         (funcall cl-func cl-start (min cl-next cl-end))
 319         (setq cl-start cl-next)))))
 320
 321 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
 322   (or cl-buffer (setq cl-buffer (current-buffer)))
 323   (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change)
 324     (if-fboundp 'overlay-lists
 325
 326         ;; This is the preferred algorithm, though overlay-lists is undocumented.
 327         (let (cl-ovl)
 328           (save-excursion
 329             (set-buffer cl-buffer)
 330             (setq cl-ovl (overlay-lists))
 331             (if cl-start (setq cl-start (copy-marker cl-start)))
 332             (if cl-end (setq cl-end (copy-marker cl-end))))
 333           (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
 334           (while (and cl-ovl
 335                       (or (not (overlay-start (car cl-ovl)))
 336                           (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
 337                           (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
 338                           (not (funcall cl-func (car cl-ovl) cl-arg))))
 339             (setq cl-ovl (cdr cl-ovl)))
 340           (if cl-start (set-marker cl-start nil))
 341           (if cl-end (set-marker cl-end nil)))
 342
 343       ;; This alternate algorithm fails to find zero-length overlays.
 344       (let ((cl-mark (save-excursion (set-buffer cl-buffer)
 345                                      (copy-marker (or cl-start (point-min)))))
 346             (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer)
 347                                                   (copy-marker cl-end))))
 348             cl-pos cl-ovl)
 349         (while (save-excursion
 350                  (and (setq cl-pos (marker-position cl-mark))
 351                       (< cl-pos (or cl-mark2 (point-max)))
 352                       (progn
 353                         (set-buffer cl-buffer)
 354                         (setq cl-ovl (overlays-at cl-pos))
 355                         (set-marker cl-mark (next-overlay-change cl-pos)))))
 356           (while (and cl-ovl
 357                       (or (/= (overlay-start (car cl-ovl)) cl-pos)
 358                           (not (and (funcall cl-func (car cl-ovl) cl-arg)
 359                                     (set-marker cl-mark nil)))))
 360             (setq cl-ovl (cdr cl-ovl))))
 361         (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))))
 362
 363 ;;; Support for `setf'.
 364 (defun cl-set-frame-visible-p (frame val)
 365   (cond ((null val) (make-frame-invisible frame))
 366         ((eq val 'icon) (iconify-frame frame))
 367         (t (make-frame-visible frame)))
 368   val)
 369
 370 ;;; Support for `progv'.
 371 (defvar cl-progv-save)
 372 (defun cl-progv-before (syms values)
 373   (while syms
 374     (cl-push (if (boundp (car syms))
 375                  (cons (car syms) (symbol-value (car syms)))
 376                (car syms)) cl-progv-save)
 377     (if values
 378         (set (cl-pop syms) (cl-pop values))
 379       (makunbound (cl-pop syms)))))
 380
 381 (defun cl-progv-after ()
 382   (while cl-progv-save
 383     (if (consp (car cl-progv-save))
 384         (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
 385       (makunbound (car cl-progv-save)))
 386     (cl-pop cl-progv-save)))
 387
 388
 389 ;;; Numbers.
 390
 391 (unless (fboundp #'gcd)
 392   (defun gcd (&rest args)
 393     "Return the greatest common divisor of the arguments."
 394     (let ((a (abs (or (cl-pop args) 0))))
 395       (while args
 396         (let ((b (abs (cl-pop args))))
 397           (while (> b 0) (setq b (% a (setq a b))))))
 398       a)))
 399
 400 (unless (fboundp #'lcm)
 401   (defun lcm (&rest args)
 402     "Return the least common multiple of the arguments."
 403     (if (memq 0 args)
 404         0
 405       (let ((a (abs (or (cl-pop args) 1))))
 406         (while args
 407           (let ((b (abs (cl-pop args))))
 408             (setq a (* (/ a (gcd a b)) b))))
 409         a))))
 410
 411 (defun isqrt (a)
 412   "Return the integer square root of the argument."
 413   (if (and (integerp a) (> a 0))
 414       ;; XEmacs change
 415       (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
 416                      ((>= a 100) 100) (t 10)))
 417             g2)
 418         (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
 419           (setq g g2))
 420         g)
 421     (if (eq a 0) 0 (signal 'arith-error nil))))
 422
 423 (defun cl-expt (x y)
 424   "Return X raised to the power of Y.  Works only for integer arguments."
 425   (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
 426     (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
 427 (or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
 428     (defalias 'expt 'cl-expt))
 429
 430 (defun floor* (x &optional y)
 431   "Return a list of the floor of X and the fractional part of X.
 432 With two arguments, return floor and remainder of their quotient."
 433   (let ((q (floor x y)))
 434     (list q (- x (if y (* y q) q)))))
 435
 436 (defun ceiling* (x &optional y)
 437   "Return a list of the ceiling of X and the fractional part of X.
 438 With two arguments, return ceiling and remainder of their quotient."
 439   (let ((res (floor* x y)))
 440     (if (= (car (cdr res)) 0) res
 441       (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
 442
 443 (defun truncate* (x &optional y)
 444   "Return a list of the integer part of X and the fractional part of X.
 445 With two arguments, return truncation and remainder of their quotient."
 446   (if (eq (>= x 0) (or (null y) (>= y 0)))
 447       (floor* x y) (ceiling* x y)))
 448
 449 (defun round* (x &optional y)
 450   "Return a list of X rounded to the nearest integer and the remainder.
 451 With two arguments, return rounding and remainder of their quotient."
 452   (if y
 453       (if (and (integerp x) (integerp y))
 454           (let* ((hy (/ y 2))
 455                  (res (floor* (+ x hy) y)))
 456             (if (and (= (car (cdr res)) 0)
 457                      (= (+ hy hy) y)
 458                      (/= (% (car res) 2) 0))
 459                 (list (1- (car res)) hy)
 460               (list (car res) (- (car (cdr res)) hy))))
 461         (let ((q (round (/ x y))))
 462           (list q (- x (* q y)))))
 463     (if (integerp x) (list x 0)
 464       (let ((q (round x)))
 465         (list q (- x q))))))
 466
 467 (defun mod* (x y)
 468   "The remainder of X divided by Y, with the same sign as Y."
 469   (nth 1 (floor* x y)))
 470
 471 (defun rem* (x y)
 472   "The remainder of X divided by Y, with the same sign as X."
 473   (nth 1 (truncate* x y)))
 474
 475 (defun signum (a)
 476   "Return 1 if A is positive, -1 if negative, 0 if zero."
 477   (cond ((> a 0) 1) ((< a 0) -1) (t 0)))
 478
 479
 480 ;; Random numbers.
 481
 482 (defvar *random-state*)
 483 (defun random* (lim &optional state)
 484   "Return a random nonnegative number less than LIM, an integer or float.
 485 Optional second arg STATE is a random-state object."
 486   (or state (setq state *random-state*))
 487   ;; Inspired by "ran3" from Numerical Recipes.  Additive congruential method.
 488   (let ((vec (aref state 3)))
 489     (if (integerp vec)
 490         (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
 491           (aset state 3 (setq vec (make-vector 55 nil)))
 492           (aset vec 0 j)
 493           (while (> (setq i (% (+ i 21) 55)) 0)
 494             (aset vec i (setq j (prog1 k (setq k (- j k))))))
 495           (while (< (setq i (1+ i)) 200) (random* 2 state))))
 496     (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
 497            (j (aset state 2 (% (1+ (aref state 2)) 55)))
 498            (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
 499       (if (integerp lim)
 500           (if (<= lim 512) (% n lim)
 501             (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
 502             (let ((mask 1023))
 503               (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
 504               (if (< (setq n (logand n mask)) lim) n (random* lim state))))
 505         (* (/ n '8388608e0) lim)))))
 506
 507 (defun make-random-state (&optional state)
 508   "Return a copy of random-state STATE, or of `*random-state*' if omitted.
 509 If STATE is t, return a new state object seeded from the time of day."
 510   (cond ((null state) (make-random-state *random-state*))
 511         ((vectorp state) (cl-copy-tree state t))
 512         ((integerp state) (vector 'cl-random-state-tag -1 30 state))
 513         (t (make-random-state (cl-random-time)))))
 514
 515 (defun random-state-p (object)
 516   "Return t if OBJECT is a random-state object."
 517   (and (vectorp object) (= (length object) 4)
 518        (eq (aref object 0) 'cl-random-state-tag)))
 519
 520
 521 ;; Implementation limits.
 522
 523 (defun cl-finite-do (func a b)
 524   (condition-case nil
 525       (let ((res (funcall func a b)))   ; check for IEEE infinity
 526         (and (numberp res) (/= res (/ res 2)) res))
 527     (arith-error nil)))
 528
 529 (defvar most-positive-float)
 530 (defvar most-negative-float)
 531 (defvar least-positive-float)
 532 (defvar least-negative-float)
 533 (defvar least-positive-normalized-float)
 534 (defvar least-negative-normalized-float)
 535 (defvar float-epsilon)
 536 (defvar float-negative-epsilon)
 537
 538 (defun cl-float-limits ()
 539   (or most-positive-float (not (numberp '2e1))
 540       (let ((x '2e0) y z)
 541         ;; Find maximum exponent (first two loops are optimizations)
 542         (while (cl-finite-do '* x x) (setq x (* x x)))
 543         (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
 544         (while (cl-finite-do '+ x x) (setq x (+ x x)))
 545         (setq z x y (/ x 2))
 546         ;; Now fill in 1's in the mantissa.
 547         (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
 548           (setq x (+ x y) y (/ y 2)))
 549         (setq most-positive-float x
 550               most-negative-float (- x))
 551         ;; Divide down until mantissa starts rounding.
 552         (setq x (/ x z) y (/ 16 z) x (* x y))
 553         (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
 554                  (arith-error nil))
 555           (setq x (/ x 2) y (/ y 2)))
 556         (setq least-positive-normalized-float y
 557               least-negative-normalized-float (- y))
 558         ;; Divide down until value underflows to zero.
 559         (setq x (/ 1 z) y x)
 560         (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
 561           (setq x (/ x 2)))
 562         (setq least-positive-float x
 563               least-negative-float (- x))
 564         (setq x '1e0)
 565         (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
 566         (setq float-epsilon (* x 2))
 567         (setq x '1e0)
 568         (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
 569         (setq float-negative-epsilon (* x 2))))
 570   nil)
 571
 572
 573 ;;; Sequence functions.
 574
 575 ;XEmacs -- our built-in is more powerful.
 576 ;(defun subseq (seq start &optional end)
 577 ;  "Return the subsequence of SEQ from START to END.
 578 ;If END is omitted, it defaults to the length of the sequence.
 579 ;If START or END is negative, it counts from the end."
 580 ;  (if (stringp seq) (substring seq start end)
 581 ;    (let (len)
 582 ;      (and end (< end 0) (setq end (+ end (setq len (length seq)))))
 583 ;      (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
 584 ;      (cond ((listp seq)
 585 ;            (if (> start 0) (setq seq (nthcdr start seq)))
 586 ;            (if end
 587 ;                (let ((res nil))
 588 ;                  (while (>= (setq end (1- end)) start)
 589 ;                    (cl-push (cl-pop seq) res))
 590 ;                  (nreverse res))
 591 ;              (copy-sequence seq)))
 592 ;           (t
 593 ;            (or end (setq end (or len (length seq))))
 594 ;            (let ((res (make-vector (max (- end start) 0) nil))
 595 ;                  (i 0))
 596 ;              (while (< start end)
 597 ;                (aset res i (aref seq start))
 598 ;                (setq i (1+ i) start (1+ start)))
 599 ;              res))))))
 600
 601 (defun concatenate (type &rest seqs)
 602   "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
 603   (case type
 604     (vector (apply 'vconcat seqs))
 605     (string (apply 'concat seqs))
 606     (list   (apply 'append (append seqs '(nil))))
 607     (t (error "Not a sequence type name: %s" type))))
 608
 609 ;;; List functions.
 610
 611 (defun revappend (x y)
 612   "Equivalent to (append (reverse X) Y)."
 613   (nconc (reverse x) y))
 614
 615 (defun nreconc (x y)
 616   "Equivalent to (nconc (nreverse X) Y)."
 617   (nconc (nreverse x) y))
 618
 619 (defun list-length (x)
 620   "Return the length of a list.  Return nil if list is circular."
 621   (let ((n 0) (fast x) (slow x))
 622     (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
 623       (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
 624     (if fast (if (cdr fast) nil (1+ n)) n)))
 625
 626 (defun tailp (sublist list)
 627   "Return true if SUBLIST is a tail of LIST."
 628   (while (and (consp list) (not (eq sublist list)))
 629     (setq list (cdr list)))
 630   (if (numberp sublist) (equal sublist list) (eq sublist list)))
 631
 632 (defun cl-copy-tree (tree &optional vecp)
 633   "Make a copy of TREE.
 634 If TREE is a cons cell, this recursively copies both its car and its cdr.
 635 Contrast to copy-sequence, which copies only along the cdrs.  With second
 636 argument VECP, this copies vectors as well as conses."
 637   (if (consp tree)
 638       (let ((p (setq tree (copy-list tree))))
 639         (while (consp p)
 640           (if (or (consp (car p)) (and vecp (vectorp (car p))))
 641               (setcar p (cl-copy-tree (car p) vecp)))
 642           (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp)))
 643           (cl-pop p)))
 644     (if (and vecp (vectorp tree))
 645         (let ((i (length (setq tree (copy-sequence tree)))))
 646           (while (>= (setq i (1- i)) 0)
 647             (aset tree i (cl-copy-tree (aref tree i) vecp))))))
 648   tree)
 649 (or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree)))
 650     (defalias 'copy-tree 'cl-copy-tree))
 651
 652
 653 ;;; Property lists.
 654
 655 ;; XEmacs: our `get' groks DEFAULT.
 656 (defalias 'get* 'get)
 657 (defalias 'getf 'plist-get)
 658
 659 (defun cl-set-getf (plist tag val)
 660   (let ((p plist))
 661     (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
 662     (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
 663
 664 (defun cl-do-remf (plist tag)
 665   (let ((p (cdr plist)))
 666     (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
 667     (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
 668
 669 ;;; Hash tables.
 670
 671 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
 672 ;; Only backward compatibility stuff remains here.
 673 (defun make-hashtable (size &optional test)
 674   (make-hash-table :test test :size size))
 675 (defun make-weak-hashtable (size &optional test)
 676   (make-hash-table :test test :size size :weakness t))
 677 (defun make-key-weak-hashtable (size &optional test)
 678   (make-hash-table :test test :size size :weakness 'key))
 679 (defun make-value-weak-hashtable (size &optional test)
 680   (make-hash-table :test test :size size :weakness 'value))
 681
 682 (define-obsolete-function-alias 'hashtablep 'hash-table-p)
 683 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count)
 684 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test)
 685 (define-obsolete-function-alias 'hashtable-type 'hash-table-type)
 686 (define-obsolete-function-alias 'hashtable-size 'hash-table-size)
 687 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table)
 688
 689 (make-obsolete 'make-hashtable            'make-hash-table)
 690 (make-obsolete 'make-weak-hashtable       'make-hash-table)
 691 (make-obsolete 'make-key-weak-hashtable   'make-hash-table)
 692 (make-obsolete 'make-value-weak-hashtable 'make-hash-table)
 693 (make-obsolete 'hash-table-type           'hash-table-weakness)
 694
 695 (when (fboundp 'x-keysym-hash-table)
 696   (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table))
 697
 698 ;; Compatibility stuff for old kludgy cl.el hash table implementation
 699 (defvar cl-builtin-gethash (symbol-function 'gethash))
 700 (defvar cl-builtin-remhash (symbol-function 'remhash))
 701 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
 702 (defvar cl-builtin-maphash (symbol-function 'maphash))
 703
 704 (defalias 'cl-gethash 'gethash)
 705 (defalias 'cl-puthash 'puthash)
 706 (defalias 'cl-remhash 'remhash)
 707 (defalias 'cl-clrhash 'clrhash)
 708 (defalias 'cl-maphash 'maphash)
 709
 710 ;;; Some debugging aids.
 711
 712 (defun cl-prettyprint (form)
 713   "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
 714   (let ((pt (point)) last)
 715     (insert "\n" (prin1-to-string form) "\n")
 716     (setq last (point))
 717     (goto-char (1+ pt))
 718     (while (search-forward "(quote " last t)
 719       (delete-backward-char 7)
 720       (insert "'")
 721       (forward-sexp)
 722       (delete-char 1))
 723     (goto-char (1+ pt))
 724     (cl-do-prettyprint)))
 725
 726 (defun cl-do-prettyprint ()
 727   (skip-chars-forward " ")
 728   (if (looking-at "(")
 729       (let ((skip (or (looking-at "((") (looking-at "(prog")
 730                       (looking-at "(unwind-protect ")
 731                       (looking-at "(function (")
 732                       (looking-at "(cl-block-wrapper ")))
 733             (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
 734             (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
 735             (set (looking-at "(p?set[qf] ")))
 736         (if (or skip let
 737                 (progn
 738                   (forward-sexp)
 739                   (and (>= (current-column) 78) (progn (backward-sexp) t))))
 740             (let ((nl t))
 741               (forward-char 1)
 742               (cl-do-prettyprint)
 743               (or skip (looking-at ")") (cl-do-prettyprint))
 744               (or (not two) (looking-at ")") (cl-do-prettyprint))
 745               (while (not (looking-at ")"))
 746                 (if set (setq nl (not nl)))
 747                 (if nl (insert "\n"))
 748                 (lisp-indent-line)
 749                 (cl-do-prettyprint))
 750               (forward-char 1))))
 751     (forward-sexp)))
 752
 753 (defvar cl-macroexpand-cmacs nil)
 754 (defvar cl-closure-vars nil)
 755
 756 (defun cl-macroexpand-all (form &optional env)
 757   "Expand all macro calls through a Lisp FORM.
 758 This also does some trivial optimizations to make the form prettier."
 759   (while (or (not (eq form (setq form (macroexpand form env))))
 760              (and cl-macroexpand-cmacs
 761                   (not (eq form (setq form (compiler-macroexpand form)))))))
 762   (cond ((not (consp form)) form)
 763         ((memq (car form) '(let let*))
 764          (if (null (nth 1 form))
 765              (cl-macroexpand-all (cons 'progn (cddr form)) env)
 766            (let ((letf nil) (res nil) (lets (cadr form)))
 767              (while lets
 768                (cl-push (if (consp (car lets))
 769                             (let ((exp (cl-macroexpand-all (caar lets) env)))
 770                               (or (symbolp exp) (setq letf t))
 771                               (cons exp (cl-macroexpand-body (cdar lets) env)))
 772                           (let ((exp (cl-macroexpand-all (car lets) env)))
 773                             (if (symbolp exp) exp
 774                               (setq letf t) (list exp nil)))) res)
 775                (setq lets (cdr lets)))
 776              (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
 777                     (nreverse res) (cl-macroexpand-body (cddr form) env)))))
 778         ((eq (car form) 'cond)
 779          (cons (car form)
 780                (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
 781                        (cdr form))))
 782         ((eq (car form) 'condition-case)
 783          (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
 784                 (mapcar (function
 785                          (lambda (x)
 786                            (cons (car x) (cl-macroexpand-body (cdr x) env))))
 787                         (cdddr form))))
 788         ((memq (car form) '(quote function))
 789          (if (eq (car-safe (nth 1 form)) 'lambda)
 790              (let ((body (cl-macroexpand-body (cddadr form) env)))
 791                (if (and cl-closure-vars (eq (car form) 'function)
 792                         (cl-expr-contains-any body cl-closure-vars))
 793                    (let* ((new (mapcar 'gensym cl-closure-vars))
 794                           (sub (pairlis cl-closure-vars new)) (decls nil))
 795                      (while (or (stringp (car body))
 796                                 (eq (car-safe (car body)) 'interactive))
 797                        (cl-push (list 'quote (cl-pop body)) decls))
 798                      (put (car (last cl-closure-vars)) 'used t)
 799                      (append
 800                       (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
 801                       (sublis sub (nreverse decls))
 802                       (list
 803                        (list* 'list '(quote apply)
 804                               (list 'list '(quote quote)
 805                                     (list 'function
 806                                           (list* 'lambda
 807                                                  (append new (cadadr form))
 808                                                  (sublis sub body))))
 809                               (nconc (mapcar (function
 810                                               (lambda (x)
 811                                                 (list 'list '(quote quote) x)))
 812                                              cl-closure-vars)
 813                                      '((quote --cl-rest--)))))))
 814                  (list (car form) (list* 'lambda (cadadr form) body))))
 815            (let ((found (assq (cadr form) env)))
 816              (if (eq (cadr (caddr found)) 'cl-labels-args)
 817                  (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
 818                form))))
 819         ((memq (car form) '(defun defmacro))
 820          (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
 821         ((and (eq (car form) 'progn) (not (cddr form)))
 822          (cl-macroexpand-all (nth 1 form) env))
 823         ((eq (car form) 'setq)
 824          (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
 825            (while (and p (symbolp (car p))) (setq p (cddr p)))
 826            (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
 827         (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
 828
 829 (defun cl-macroexpand-body (body &optional env)
 830   (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
 831
 832 (defun cl-prettyexpand (form &optional full)
 833   (message "Expanding...")
 834   (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
 835         (byte-compile-macro-environment nil))
 836     (setq form (cl-macroexpand-all form
 837                                    (and (not full) '((block) (eval-when)))))
 838     (message "Formatting...")
 839     (prog1 (cl-prettyprint form)
 840       (message ""))))
 841
 842
 843
 844 (run-hooks 'cl-extra-load-hook)
 845
 846 (provide 'cl-extra)
 847
 848 ;;; cl-extra.el ends here