Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5475:248176c74e6b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Sat, 23 Apr 2011 23:47:13 +0200
parents 0af042a0c116 aa78b0b0b289
children f2881cb841b4
comparison
equal deleted inserted replaced
5474:4dee0387b9de 5475:248176c74e6b
360 360
361 (defun random-state-p (object) 361 (defun random-state-p (object)
362 "Return t if OBJECT is a random-state object." 362 "Return t if OBJECT is a random-state object."
363 (and (vectorp object) (= (length object) 4) 363 (and (vectorp object) (= (length object) 4)
364 (eq (aref object 0) 'cl-random-state-tag))) 364 (eq (aref object 0) 'cl-random-state-tag)))
365
366
367 ;; Implementation limits.
368
369 (defun cl-finite-do (func a b)
370 (condition-case nil
371 (let ((res (funcall func a b))) ; check for IEEE infinity
372 (and (numberp res) (/= res (/ res 2)) res))
373 (arith-error nil)))
374
375 (defun cl-float-limits ()
376 (or most-positive-float (not (numberp '2e1))
377 (let ((x '2e0) y z)
378 ;; Find maximum exponent (first two loops are optimizations)
379 (while (cl-finite-do '* x x) (setq x (* x x)))
380 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
381 (while (cl-finite-do '+ x x) (setq x (+ x x)))
382 (setq z x y (/ x 2))
383 ;; Now fill in 1's in the mantissa.
384 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
385 (setq x (+ x y) y (/ y 2)))
386 (setq most-positive-float x
387 most-negative-float (- x))
388 ;; Divide down until mantissa starts rounding.
389 (setq x (/ x z) y (/ 16 z) x (* x y))
390 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
391 (arith-error nil))
392 (setq x (/ x 2) y (/ y 2)))
393 (setq least-positive-normalized-float y
394 least-negative-normalized-float (- y))
395 ;; Divide down until value underflows to zero.
396 (setq x (/ 1 z) y x)
397 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
398 (setq x (/ x 2)))
399 (setq least-positive-float x
400 least-negative-float (- x))
401 (setq x '1e0)
402 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
403 (setq float-epsilon (* x 2))
404 (setq x '1e0)
405 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
406 (setq float-negative-epsilon (* x 2))))
407 nil)
408
409 ;; XEmacs; call cl-float-limits at dump time.
410 (cl-float-limits)
411 365
412 ;;; Sequence functions. 366 ;;; Sequence functions.
413 367
414 ;; XEmacs; #'subseq is in C. 368 ;; XEmacs; #'subseq is in C.
415 369
689 ;; XEmacs addition; force cl-macs to be available from here on when 643 ;; XEmacs addition; force cl-macs to be available from here on when
690 ;; compiling files to be dumped. This is more reasonable than forcing other 644 ;; compiling files to be dumped. This is more reasonable than forcing other
691 ;; files to do the same, multiple times. 645 ;; files to do the same, multiple times.
692 (eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) 646 (eval-when-compile (or (cl-compiling-file) (load "cl-macs")))
693 647
648 ;; Implementation limits.
649
650 ;; XEmacs; call cl-float-limits at dump time.
651 (labels
652 ((cl-finite-do (func a b)
653 (condition-case nil
654 (let ((res (funcall func a b))) ; check for IEEE infinity
655 (and (numberp res) (/= res (/ res 2)) res))
656 (arith-error nil)))
657 (cl-float-limits ()
658 (unless most-positive-float
659 (let ((x 2e0) y z)
660 ;; Find maximum exponent (first two loops are optimizations)
661 (while (cl-finite-do '* x x) (setq x (* x x)))
662 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
663 (while (cl-finite-do '+ x x) (setq x (+ x x)))
664 (setq z x y (/ x 2))
665 ;; Now fill in 1's in the mantissa.
666 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
667 (setq x (+ x y) y (/ y 2)))
668 (setq most-positive-float x
669 most-negative-float (- x))
670 ;; Divide down until mantissa starts rounding.
671 (setq x (/ x z) y (/ 16 z) x (* x y))
672 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
673 (arith-error nil))
674 (setq x (/ x 2) y (/ y 2)))
675 (setq least-positive-normalized-float y
676 least-negative-normalized-float (- y))
677 ;; Divide down until value underflows to zero.
678 (setq x (/ 1 z) y x)
679 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
680 (setq x (/ x 2)))
681 (setq least-positive-float x
682 least-negative-float (- x))
683 (setq x 1e0)
684 (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2)))
685 (setq float-epsilon (* x 2))
686 (setq x 1e0)
687 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2)))
688 (setq float-negative-epsilon (* x 2))))))
689 (cl-float-limits))
690
691 ;; No type-checking here, we should add it.
692 (defalias 'char< '<)
693 (defalias 'char>= '>=)
694 (defalias 'char> '>)
695 (defalias 'char<= '<=)
696
697 ;;; Character functions.
698 (defun* digit-char-p (character &optional (radix 10))
699 "Return non-nil if CHARACTER represents a digit in base RADIX.
700
701 RADIX defaults to ten. The actual non-nil value returned is the integer
702 value of the character in base RADIX."
703 (check-type character character)
704 (check-type radix integer)
705 (if (<= radix 10)
706 (and (<= ?0 character (+ ?0 radix -1)) (- character ?0))
707 (or (and (<= ?0 character ?9) (- character ?0))
708 (and (<= ?a character (+ ?a (setq radix (- radix 11))))
709 (+ character (- 10 ?a)))
710 (and (<= ?A character (+ ?A radix))
711 (+ character (- 10 ?A))))))
712
713 (defun* digit-char (weight &optional (radix 10))
714 "Return a character representing the integer WEIGHT in base RADIX.
715
716 RADIX defaults to ten. If no such character exists, return nil."
717 (check-type weight integer)
718 (check-type radix integer)
719 (and (natnump weight) (< weight radix)
720 (if (< weight 10)
721 (int-char (+ ?0 weight))
722 (int-char (+ ?A (- weight 10))))))
723
724 (defun alpha-char-p (character)
725 "Return t if CHARACTER is alphabetic, in some alphabet.
726
727 Han characters are regarded as alphabetic."
728 (check-type character character)
729 (and (eql ?w (char-syntax character (standard-syntax-table)))
730 (not (<= ?0 character ?9))))
731
732 (defun graphic-char-p (character)
733 "Return t if CHARACTER is not a control character.
734
735 Control characters are those in the range ?\\x00 to ?\\x15 and ?\\x7f to
736 ?\\x9f, inclusive."
737 (check-type character character)
738 (not (or (<= ?\x00 character ?\x1f) (<= ?\x7f character ?\x9f))))
739
740 (defun standard-char-p (character)
741 "Return t if CHARACTER is one of Common Lisp's standard characters.
742
743 These are the non-control ASCII characters, plus the newline character."
744 (check-type character character)
745 (or (<= ?\x20 character ?\x7e) (eql character ?\n)))
746
747 (symbol-macrolet
748 ((names '((?\x08 . "Backspace") (?\x09 . "Tab") (?\x0a . "Newline")
749 (?\x0C . "Page") (?\x0d . "Return") (?\x20 . "Space")
750 (?\x7f . "Rubout"))))
751
752 (defun char-name (character)
753 "Return a string naming CHARACTER.
754
755 For the limited number of characters where the character name has been
756 specified by Common Lisp, this always returns the appropriate string
757 name. Otherwise, `char-name' requires that the Unicode database be
758 available; see `describe-char-unicode-data'."
759 (check-type character character)
760 (or (cdr (assq character names))
761 (let ((unicode-data
762 (assoc "Name" (describe-char-unicode-data character))))
763 (and unicode-data
764 (if (string-match "^<[^>]+>$" (cadr unicode-data))
765 (format "U%04X" (char-to-unicode character))
766 (replace-in-string (cadr unicode-data) " " "_" t))))))
767
768 (defun name-char (name)
769 "Return a character with name NAME, a string."
770 (or (car (rassoc* name names :test #'equalp))
771 (if (string-match "^[uU][0-9A-Fa-f]+$" name)
772 (unicode-to-char (string-to-number (subseq name 1) 16))
773 (with-current-buffer (get-buffer-create " *Unicode Data*")
774 (require 'descr-text)
775 (when (zerop (buffer-size))
776 ;; Don't use -literally in case of DOS line endings.
777 (insert-file-contents describe-char-unicodedata-file))
778 (goto-char (point-min))
779 (setq case-fold-search nil)
780 (and (re-search-forward (format #r"^\([0-9A-F]\{4,6\}\);%s;"
781 (upcase (replace-in-string
782 name "_" " " t))) nil t)
783 (unicode-to-char (string-to-number (match-string 1) 16))))))))
784
785 (defun upper-case-p (character)
786 "Return t if CHARACTER is majuscule in the standard case table."
787 (and (stringp character) (check-type character character))
788 (with-case-table (standard-case-table)
789 (not (eq character (downcase character)))))
790
791 (defun lower-case-p (character)
792 "Return t if CHARACTER is minuscule in the standard case table."
793 (and (stringp character) (check-type character character))
794 (with-case-table (standard-case-table)
795 (not (eq character (upcase character)))))
796
797 (defun both-case-p (character)
798 "Return t if CHARACTER has case information in the standard case table."
799 (and (stringp character) (check-type character character))
800 (with-case-table (standard-case-table)
801 (or (not (eq character (upcase character)))
802 (not (eq character (downcase character))))))
803
804 (defun char-upcase (character)
805 "If CHARACTER is lowercase, return its corresponding uppercase character.
806 Otherwise, return CHARACTER."
807 (and (stringp character) (check-type character character))
808 (with-case-table (standard-case-table) (upcase character)))
809
810 (defun char-downcase (character)
811 "If CHARACTER is uppercase, return its corresponding lowercase character.
812 Otherwise, return CHARACTER."
813 (and (stringp character) (check-type character character))
814 (with-case-table (standard-case-table) (downcase character)))
815
816 (defun integer-length (integer)
817 "Return the number of bits need to represent INTEGER in two's complement."
818 (ecase (signum integer)
819 (0 0)
820 (-1 (1- (length (format "%b" (- integer)))))
821 (1 (length (format "%b" integer)))))
822
694 (run-hooks 'cl-extra-load-hook) 823 (run-hooks 'cl-extra-load-hook)
695 824
696 ;; XEmacs addition 825 ;; XEmacs addition
697 (provide 'cl-extra) 826 (provide 'cl-extra)
698 827