Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents d0ea57eb3de4
children 95b04754ea8c
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
95 numbers of different types (float vs. integer), and also compares 95 numbers of different types (float vs. integer), and also compares
96 strings case-insensitively." 96 strings case-insensitively."
97 (cond ((eq x y) t) 97 (cond ((eq x y) t)
98 ((stringp x) 98 ((stringp x)
99 ;; XEmacs change: avoid downcase 99 ;; XEmacs change: avoid downcase
100 (eq t (compare-strings x nil nil y nil nil t))) 100 (and (stringp y)
101 (eq t (compare-strings x nil nil y nil nil t))))
101 ;; XEmacs addition: compare characters 102 ;; XEmacs addition: compare characters
102 ((characterp x) 103 ((characterp x)
103 (and (characterp y) 104 (and (characterp y)
104 (or (char-equal x y) 105 (or (char-equal x y)
105 (char-equal (downcase x) (downcase y))))) 106 (char-equal (downcase x) (downcase y)))))
392 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) 393 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
393 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) 394 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
394 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) 395 (or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
395 (defalias 'expt 'cl-expt)) 396 (defalias 'expt 'cl-expt))
396 397
397 (defun floor* (x &optional y) 398 ;; We can't use macrolet in this file; whence the literal macro
398 "Return a list of the floor of X and the fractional part of X. 399 ;; definition-and-call:
399 With two arguments, return floor and remainder of their quotient." 400 ((macro . (lambda (&rest symbols)
400 (let ((q (floor x y))) 401 "Make some old CL package truncate and round functions available.
401 (list q (- x (if y (* y q) q))))) 402
402 403 These functions are now implemented in C; their Lisp implementations in this
403 (defun ceiling* (x &optional y) 404 XEmacs are trivial, so we provide them and mark them obsolete."
404 "Return a list of the ceiling of X and the fractional part of X. 405 (let (symbol result)
405 With two arguments, return ceiling and remainder of their quotient." 406 (while symbols
406 (let ((res (floor* x y))) 407 (setq symbol (car symbols)
407 (if (= (car (cdr res)) 0) res 408 symbols (cdr symbols))
408 (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) 409 (push `(make-obsolete ',(intern (format "%s*" symbol))
409 410 ',symbol "21.5.29")
410 (defun truncate* (x &optional y) 411 result)
411 "Return a list of the integer part of X and the fractional part of X. 412 (push
412 With two arguments, return truncation and remainder of their quotient." 413 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor)
413 (if (eq (>= x 0) (or (null y) (>= y 0))) 414 ,(format "See `%s'. This returns a list, not multiple values."
414 (floor* x y) (ceiling* x y))) 415 symbol)
415 416 (multiple-value-list (,symbol number divisor)))
416 (defun round* (x &optional y) 417 result))
417 "Return a list of X rounded to the nearest integer and the remainder. 418 (cons 'progn result))))
418 With two arguments, return rounding and remainder of their quotient." 419 ceiling floor round truncate)
419 (if y
420 (if (and (integerp x) (integerp y))
421 (let* ((hy (/ y 2))
422 (res (floor* (+ x hy) y)))
423 (if (and (= (car (cdr res)) 0)
424 (= (+ hy hy) y)
425 (/= (% (car res) 2) 0))
426 (list (1- (car res)) hy)
427 (list (car res) (- (car (cdr res)) hy))))
428 (let ((q (round (/ x y))))
429 (list q (- x (* q y)))))
430 (if (integerp x) (list x 0)
431 (let ((q (round x)))
432 (list q (- x q))))))
433 420
434 (defun mod* (x y) 421 (defun mod* (x y)
435 "The remainder of X divided by Y, with the same sign as Y." 422 "The remainder of X divided by Y, with the same sign as Y."
436 (nth 1 (floor* x y))) 423 (nth-value 1 (floor x y)))
437 424
438 (defun rem* (x y) 425 (defun rem* (x y)
439 "The remainder of X divided by Y, with the same sign as X." 426 "The remainder of X divided by Y, with the same sign as X."
440 (nth 1 (truncate* x y))) 427 (nth-value 1 (truncate x y)))
441 428
442 (defun signum (a) 429 (defun signum (a)
443 "Return 1 if A is positive, -1 if negative, 0 if zero." 430 "Return 1 if A is positive, -1 if negative, 0 if zero."
444 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) 431 (cond ((> a 0) 1) ((< a 0) -1) (t 0)))
445
446 432
447 ;; Random numbers. 433 ;; Random numbers.
448 434
449 (defvar *random-state*) 435 (defvar *random-state*)
450 (defun random* (lim &optional state) 436 (defun random* (lim &optional state)