Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5387:5f5d48053e86

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs 2011-03-29 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (cl-finite-do, cl-float-limits): Don't make these available as functions in the dumped image (let them be garbage-collected), since they're only called at dump time. * obsolete.el (cl-float-limits): Make this an alias to #'identity (since it's called at dump time), mark it as obsolete in 21.5.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 29 Mar 2011 23:27:46 +0100
parents 38e24b8be4ea
children aa78b0b0b289
comparison
equal deleted inserted replaced
5385:436e67ca8c79 5387:5f5d48053e86
362 362
363 (defun random-state-p (object) 363 (defun random-state-p (object)
364 "Return t if OBJECT is a random-state object." 364 "Return t if OBJECT is a random-state object."
365 (and (vectorp object) (= (length object) 4) 365 (and (vectorp object) (= (length object) 4)
366 (eq (aref object 0) 'cl-random-state-tag))) 366 (eq (aref object 0) 'cl-random-state-tag)))
367
368
369 ;; Implementation limits.
370
371 (defun cl-finite-do (func a b)
372 (condition-case nil
373 (let ((res (funcall func a b))) ; check for IEEE infinity
374 (and (numberp res) (/= res (/ res 2)) res))
375 (arith-error nil)))
376
377 (defun cl-float-limits ()
378 (or most-positive-float (not (numberp '2e1))
379 (let ((x '2e0) y z)
380 ;; Find maximum exponent (first two loops are optimizations)
381 (while (cl-finite-do '* x x) (setq x (* x x)))
382 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
383 (while (cl-finite-do '+ x x) (setq x (+ x x)))
384 (setq z x y (/ x 2))
385 ;; Now fill in 1's in the mantissa.
386 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
387 (setq x (+ x y) y (/ y 2)))
388 (setq most-positive-float x
389 most-negative-float (- x))
390 ;; Divide down until mantissa starts rounding.
391 (setq x (/ x z) y (/ 16 z) x (* x y))
392 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
393 (arith-error nil))
394 (setq x (/ x 2) y (/ y 2)))
395 (setq least-positive-normalized-float y
396 least-negative-normalized-float (- y))
397 ;; Divide down until value underflows to zero.
398 (setq x (/ 1 z) y x)
399 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
400 (setq x (/ x 2)))
401 (setq least-positive-float x
402 least-negative-float (- x))
403 (setq x '1e0)
404 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
405 (setq float-epsilon (* x 2))
406 (setq x '1e0)
407 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
408 (setq float-negative-epsilon (* x 2))))
409 nil)
410
411 ;; XEmacs; call cl-float-limits at dump time.
412 (cl-float-limits)
413 367
414 ;;; Sequence functions. 368 ;;; Sequence functions.
415 369
416 ;; XEmacs; #'subseq is in C. 370 ;; XEmacs; #'subseq is in C.
417 371
691 ;; XEmacs addition; force cl-macs to be available from here on when 645 ;; XEmacs addition; force cl-macs to be available from here on when
692 ;; compiling files to be dumped. This is more reasonable than forcing other 646 ;; compiling files to be dumped. This is more reasonable than forcing other
693 ;; files to do the same, multiple times. 647 ;; files to do the same, multiple times.
694 (eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) 648 (eval-when-compile (or (cl-compiling-file) (load "cl-macs")))
695 649
650 ;; Implementation limits.
651
652 ;; XEmacs; call cl-float-limits at dump time.
653 (labels
654 ((cl-finite-do (func a b)
655 (condition-case nil
656 (let ((res (funcall func a b))) ; check for IEEE infinity
657 (and (numberp res) (/= res (/ res 2)) res))
658 (arith-error nil)))
659 (cl-float-limits ()
660 (unless most-positive-float
661 (let ((x 2e0) y z)
662 ;; Find maximum exponent (first two loops are optimizations)
663 (while (cl-finite-do '* x x) (setq x (* x x)))
664 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
665 (while (cl-finite-do '+ x x) (setq x (+ x x)))
666 (setq z x y (/ x 2))
667 ;; Now fill in 1's in the mantissa.
668 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
669 (setq x (+ x y) y (/ y 2)))
670 (setq most-positive-float x
671 most-negative-float (- x))
672 ;; Divide down until mantissa starts rounding.
673 (setq x (/ x z) y (/ 16 z) x (* x y))
674 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
675 (arith-error nil))
676 (setq x (/ x 2) y (/ y 2)))
677 (setq least-positive-normalized-float y
678 least-negative-normalized-float (- y))
679 ;; Divide down until value underflows to zero.
680 (setq x (/ 1 z) y x)
681 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
682 (setq x (/ x 2)))
683 (setq least-positive-float x
684 least-negative-float (- x))
685 (setq x 1e0)
686 (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2)))
687 (setq float-epsilon (* x 2))
688 (setq x 1e0)
689 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2)))
690 (setq float-negative-epsilon (* x 2))))))
691 (cl-float-limits))
692
696 (run-hooks 'cl-extra-load-hook) 693 (run-hooks 'cl-extra-load-hook)
697 694
698 ;; XEmacs addition 695 ;; XEmacs addition
699 (provide 'cl-extra) 696 (provide 'cl-extra)
700 697