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