Mercurial > hg > xemacs-beta
comparison lisp/cl-extra.el @ 5400:aa78b0b0b289
Add various Common Lisp character functions, making porting CL code easier.
2011-04-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el:
* cl-extra.el ('char<): New.
* cl-extra.el ('char>=): New.
* cl-extra.el ('char>): New.
* cl-extra.el ('char<=): New.
* cl-extra.el (alpha-char-p): New.
* cl-extra.el (graphic-char-p): New.
* cl-extra.el (standard-char-p): New.
* cl-extra.el (char-name): New.
* cl-extra.el (name-char): New.
* cl-extra.el (upper-case-p): New.
* cl-extra.el (lower-case-p): New.
* cl-extra.el (both-case-p): New.
* cl-extra.el (char-upcase): New.
* cl-extra.el (char-downcase): New.
* cl-extra.el (integer-length): New.
Add various functions dealing (mainly) with characters, making
some Common Lisp code easier to port.
* descr-text.el (describe-char-unicode-data):
Add an autoload for this function, used by #'char-name.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 17 Apr 2011 11:14:38 +0100 |
| parents | 5f5d48053e86 |
| children | 568ec109e73d 248176c74e6b |
comparison
equal
deleted
inserted
replaced
| 5399:5ec4534daf16 | 5400:aa78b0b0b289 |
|---|---|
| 688 (setq x 1e0) | 688 (setq x 1e0) |
| 689 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2))) | 689 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2))) |
| 690 (setq float-negative-epsilon (* x 2)))))) | 690 (setq float-negative-epsilon (* x 2)))))) |
| 691 (cl-float-limits)) | 691 (cl-float-limits)) |
| 692 | 692 |
| 693 ;; No type-checking here, we should add it. | |
| 694 (defalias 'char< '<) | |
| 695 (defalias 'char>= '>=) | |
| 696 (defalias 'char> '>) | |
| 697 (defalias 'char<= '<=) | |
| 698 | |
| 699 ;;; Character functions. | |
| 700 (defun* digit-char-p (character &optional (radix 10)) | |
| 701 "Return non-nil if CHARACTER represents a digit in base RADIX. | |
| 702 | |
| 703 RADIX defaults to ten. The actual non-nil value returned is the integer | |
| 704 value of the character in base RADIX." | |
| 705 (check-type character character) | |
| 706 (check-type radix integer) | |
| 707 (if (<= radix 10) | |
| 708 (and (<= ?0 character (+ ?0 radix -1)) (- character ?0)) | |
| 709 (or (and (<= ?0 character ?9) (- character ?0)) | |
| 710 (and (<= ?a character (+ ?a (setq radix (- radix 11)))) | |
| 711 (+ character (- 10 ?a))) | |
| 712 (and (<= ?A character (+ ?A radix)) | |
| 713 (+ character (- 10 ?A)))))) | |
| 714 | |
| 715 (defun* digit-char (weight &optional (radix 10)) | |
| 716 "Return a character representing the integer WEIGHT in base RADIX. | |
| 717 | |
| 718 RADIX defaults to ten. If no such character exists, return nil." | |
| 719 (check-type weight integer) | |
| 720 (check-type radix integer) | |
| 721 (and (natnump weight) (< weight radix) | |
| 722 (if (< weight 10) | |
| 723 (int-char (+ ?0 weight)) | |
| 724 (int-char (+ ?A (- weight 10)))))) | |
| 725 | |
| 726 (defun alpha-char-p (character) | |
| 727 "Return t if CHARACTER is alphabetic, in some alphabet. | |
| 728 | |
| 729 Han characters are regarded as alphabetic." | |
| 730 (check-type character character) | |
| 731 (and (eql ?w (char-syntax character (standard-syntax-table))) | |
| 732 (not (<= ?0 character ?9)))) | |
| 733 | |
| 734 (defun graphic-char-p (character) | |
| 735 "Return t if CHARACTER is not a control character. | |
| 736 | |
| 737 Control characters are those in the range ?\\x00 to ?\\x15 and ?\\x7f to | |
| 738 ?\\x9f, inclusive." | |
| 739 (check-type character character) | |
| 740 (not (or (<= ?\x00 character ?\x1f) (<= ?\x7f character ?\x9f)))) | |
| 741 | |
| 742 (defun standard-char-p (character) | |
| 743 "Return t if CHARACTER is one of Common Lisp's standard characters. | |
| 744 | |
| 745 These are the non-control ASCII characters, plus the newline character." | |
| 746 (check-type character character) | |
| 747 (or (<= ?\x20 character ?\x7e) (eql character ?\n))) | |
| 748 | |
| 749 (symbol-macrolet | |
| 750 ((names '((?\x08 . "Backspace") (?\x09 . "Tab") (?\x0a . "Newline") | |
| 751 (?\x0C . "Page") (?\x0d . "Return") (?\x20 . "Space") | |
| 752 (?\x7f . "Rubout")))) | |
| 753 | |
| 754 (defun char-name (character) | |
| 755 "Return a string naming CHARACTER. | |
| 756 | |
| 757 For the limited number of characters where the character name has been | |
| 758 specified by Common Lisp, this always returns the appropriate string | |
| 759 name. Otherwise, `char-name' requires that the Unicode database be | |
| 760 available; see `describe-char-unicode-data'." | |
| 761 (check-type character character) | |
| 762 (or (cdr (assq character names)) | |
| 763 (let ((unicode-data | |
| 764 (assoc "Name" (describe-char-unicode-data character)))) | |
| 765 (and unicode-data | |
| 766 (if (string-match "^<[^>]+>$" (cadr unicode-data)) | |
| 767 (format "U%04X" (char-to-unicode character)) | |
| 768 (replace-in-string (cadr unicode-data) " " "_" t)))))) | |
| 769 | |
| 770 (defun name-char (name) | |
| 771 "Return a character with name NAME, a string." | |
| 772 (or (car (rassoc* name names :test #'equalp)) | |
| 773 (if (string-match "^[uU][0-9A-Fa-f]+$" name) | |
| 774 (unicode-to-char (string-to-number (subseq name 1) 16)) | |
| 775 (with-current-buffer (get-buffer-create " *Unicode Data*") | |
| 776 (require 'descr-text) | |
| 777 (when (zerop (buffer-size)) | |
| 778 ;; Don't use -literally in case of DOS line endings. | |
| 779 (insert-file-contents describe-char-unicodedata-file)) | |
| 780 (goto-char (point-min)) | |
| 781 (setq case-fold-search nil) | |
| 782 (and (re-search-forward (format #r"^\([0-9A-F]\{4,6\}\);%s;" | |
| 783 (upcase (replace-in-string | |
| 784 name "_" " " t))) nil t) | |
| 785 (unicode-to-char (string-to-number (match-string 1) 16)))))))) | |
| 786 | |
| 787 (defun upper-case-p (character) | |
| 788 "Return t if CHARACTER is majuscule in the standard case table." | |
| 789 (and (stringp character) (check-type character character)) | |
| 790 (with-case-table (standard-case-table) | |
| 791 (not (eq character (downcase character))))) | |
| 792 | |
| 793 (defun lower-case-p (character) | |
| 794 "Return t if CHARACTER is minuscule in the standard case table." | |
| 795 (and (stringp character) (check-type character character)) | |
| 796 (with-case-table (standard-case-table) | |
| 797 (not (eq character (upcase character))))) | |
| 798 | |
| 799 (defun both-case-p (character) | |
| 800 "Return t if CHARACTER has case information in the standard case table." | |
| 801 (and (stringp character) (check-type character character)) | |
| 802 (with-case-table (standard-case-table) | |
| 803 (or (not (eq character (upcase character))) | |
| 804 (not (eq character (downcase character)))))) | |
| 805 | |
| 806 (defun char-upcase (character) | |
| 807 "If CHARACTER is lowercase, return its corresponding uppercase character. | |
| 808 Otherwise, return CHARACTER." | |
| 809 (and (stringp character) (check-type character character)) | |
| 810 (with-case-table (standard-case-table) (upcase character))) | |
| 811 | |
| 812 (defun char-downcase (character) | |
| 813 "If CHARACTER is uppercase, return its corresponding lowercase character. | |
| 814 Otherwise, return CHARACTER." | |
| 815 (and (stringp character) (check-type character character)) | |
| 816 (with-case-table (standard-case-table) (downcase character))) | |
| 817 | |
| 818 (defun integer-length (integer) | |
| 819 "Return the number of bits need to represent INTEGER in two's complement." | |
| 820 (ecase (signum integer) | |
| 821 (0 0) | |
| 822 (-1 (1- (length (format "%b" (- integer))))) | |
| 823 (1 (length (format "%b" integer))))) | |
| 824 | |
| 693 (run-hooks 'cl-extra-load-hook) | 825 (run-hooks 'cl-extra-load-hook) |
| 694 | 826 |
| 695 ;; XEmacs addition | 827 ;; XEmacs addition |
| 696 (provide 'cl-extra) | 828 (provide 'cl-extra) |
| 697 | 829 |