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