Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 286:57709be46d1b r21-0b41

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b41
author cvs
date Mon, 13 Aug 2007 10:35:03 +0200
parents 558f606b08ae
children 8bec6624d99b
comparison
equal deleted inserted replaced
285:9a3756523c1b 286:57709be46d1b
514 (defvar least-positive-normalized-float) 514 (defvar least-positive-normalized-float)
515 (defvar least-negative-normalized-float) 515 (defvar least-negative-normalized-float)
516 (defvar float-epsilon) 516 (defvar float-epsilon)
517 (defvar float-negative-epsilon) 517 (defvar float-negative-epsilon)
518 518
519 ;;(defun cl-float-limits ()
520 (or most-positive-float
521 (not (featurep 'lisp-float-type))
522 (let ((x '2e0) y z)
523 ;; Find maximum exponent (first two loops are optimizations)
524 (while (cl-finite-do '* x x) (setq x (* x x)))
525 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
526 (while (cl-finite-do '+ x x) (setq x (+ x x)))
527 (setq z x y (/ x 2))
528 ;; Now fill in 1's in the mantissa.
529 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
530 (setq x (+ x y) y (/ y 2)))
531 (setq most-positive-float x
532 most-negative-float (- x))
533 ;; Divide down until mantissa starts rounding.
534 (setq x (/ x z) y (/ 16 z) x (* x y))
535 (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
536 (arith-error nil))
537 (setq x (/ x 2) y (/ y 2)))
538 (setq least-positive-normalized-float y
539 least-negative-normalized-float (- y))
540 ;; Divide down until value underflows to zero.
541 (setq x (/ 1 z) y x)
542 (while (condition-case err (> (/ x 2) 0) (arith-error nil))
543 (setq x (/ x 2)))
544 (setq least-positive-float x
545 least-negative-float (- x))
546 (setq x '1e0)
547 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
548 (setq float-epsilon (* x 2))
549 (setq x '1e0)
550 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
551 (setq float-negative-epsilon (* x 2))))
552 ;;)
553
554 (defun cl-float-limits () 519 (defun cl-float-limits ()
555 ;; No-op, defined for old code that calls this to setup the 520 (or most-positive-float (not (numberp '2e1))
556 ;; constants. 521 (let ((x '2e0) y z)
557 ) 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
558 553
559 ;;; Sequence functions. 554 ;;; Sequence functions.
560 555
561 ;XEmacs -- our built-in is more powerful. 556 ;XEmacs -- our built-in is more powerful.
562 ;(defun subseq (seq start &optional end) 557 ;(defun subseq (seq start &optional end)