+(/debug "loading char.lisp!")
+
+;; These comparison functions heavily borrowed from SBCL/CMUCL (public domain).
+
+(defun char= (character &rest more-characters)
+ (dolist (c more-characters t)
+ (unless (eql c character) (return nil))))
+
+(defun char/= (character &rest more-characters)
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (dolist (c list)
+ (when (eql head c) (return-from char/= nil)))))
+
+(defun char< (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (< (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char> (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (> (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char<= (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (<= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char>= (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (>= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun equal-char-code (character)
+ (char-code (char-upcase character)))
+
+(defun two-arg-char-equal (c1 c2)
+ (= (equal-char-code c1) (equal-char-code c2)))
+
+(defun char-equal (character &rest more-characters)
+ (do ((clist more-characters (cdr clist)))
+ ((null clist) t)
+ (unless (two-arg-char-equal (car clist) character)
+ (return nil))))
+
+(defun char-not-equal (character &rest more-characters)
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (do* ((l list (cdr l)))
+ ((null l) t)
+ (when (two-arg-char-equal head (car l))
+ (return nil)))
+ (return nil))))
+
+(defun two-arg-char-lessp (c1 c2)
+ (< (equal-char-code c1) (equal-char-code c2)))
+
+(defun char-lessp (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (two-arg-char-lessp c (car list))
+ (return nil))))
+
+(defun two-arg-char-greaterp (c1 c2)
+ (> (equal-char-code c1) (equal-char-code c2)))
+
+(defun char-greaterp (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (two-arg-char-greaterp c (car list))
+ (return nil))))
+
+(defun two-arg-char-not-greaterp (c1 c2)
+ (<= (equal-char-code c1) (equal-char-code c2)))
+
+(defun char-not-greaterp (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (two-arg-char-not-greaterp c (car list))
+ (return nil))))
+
+(defun two-arg-char-not-lessp (c1 c2)
+ (>= (equal-char-code c1) (equal-char-code c2)))
+
+(defun char-not-lessp (character &rest more-characters)
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((null list) t)
+ (unless (two-arg-char-not-lessp c (car list))
+ (return nil))))
+
(defun character (character)
(cond ((characterp character)
- character)
- ((and (stringp character)
- (= 1 (length character)))
- (char character 0))
- ((and (symbolp character)
- (= 1 (length (symbol-name character))))
- (symbol-name character))
- (t
- (error "not a valid character designator"))))
+ character)
+ ((and (stringp character)
+ (= 1 (length character)))
+ (char character 0))
+ ((and (symbolp character)
+ (= 1 (length (symbol-name character))))
+ (symbol-name character))
+ (t
+ (error "not a valid character designator"))))
;; This list comes from SBCL: everything that's ALPHA-CHAR-P, but
;; not SB-IMPL::UCD-DECIMAL-DIGIT (to work around <https://bugs.launchpad.net/sbcl/+bug/1177986>),
(let ((code (char-code char)))
(dolist (alpha-pair +unicode-alphas+)
(when (<= (car alpha-pair) code (cdr alpha-pair))
- (return-from alpha-char-p t)))
+ (return-from alpha-char-p t)))
nil))
(defun alphanumericp (char)
(defun unicode-digit-value (char)
(let ((code (char-code char)))
(if (= code 6618)
- 1 ;; it's special!
+ 1 ;; it's special!
(dolist (z +unicode-zeroes+)
- (when (<= z code (+ z 9))
- (return-from unicode-digit-value (- code z)))))))
+ (when (<= z code (+ z 9))
+ (return-from unicode-digit-value (- code z)))))))
;; from SBCL/CMUCL:
(defun digit-char (weight &optional (radix 10))
(>= weight 0) (< weight radix) (< weight 36)
(code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
-;; borrowed from my proposed fix to SBCL: https://bugs.launchpad.net/sbcl/+bug/1177986
+;; From comment #4 on <https://bugs.launchpad.net/sbcl/+bug/1177986>:
(defun digit-char-p (char &optional (radix 10))
- (let ((number (unicode-digit-value char))
- (code (char-code char))
- (little-a (char-code #\a))
- (big-a (char-code #\A)))
- (cond ((and number (< number radix))
- number)
- (number
- nil)
- ((<= big-a code (+ big-a radix -10 -1))
- (+ code (- big-a) 10))
- ((<= little-a code (+ little-a radix -10 -1))
- (+ code (- little-a) 10))
- (t nil))))
+ "Includes ASCII 0-9 a-z A-Z, plus Unicode HexDigit characters (fullwidth variants of 0-9 and A-F)."
+ (let* ((number (unicode-digit-value char))
+ (code (char-code char))
+ (upper (char-upcase char))
+ (code-upper (char-code upper))
+ (potential (cond (number number)
+ ((char<= #\0 char #\9)
+ (- code (char-code #\0)))
+ ((<= 65296 code 65305) ;; FULLWIDTH_DIGIT_ZERO, FULLWIDTH_DIGIT_NINE
+ (- code 65296))
+ ((char<= #\A upper #\Z)
+ (+ 10 (- code-upper (char-code #\A))))
+ ((<= 65313 (char-code upper) 65318) ;; FULLWIDTH_LATIN_CAPITAL_LETTER_A, FULLWIDTH_LATIN_CAPITAL_LETTER_F
+ (+ 10 (- code-upper 65313)))
+ (t nil))))
+ (if (and potential (< potential radix))
+ potential
+ nil)))
(defun graphic-char-p (char)
;; from SBCL/CMUCL:
(or (< 31 n 127)
(= n 10)))))
+(defun upper-case-p (character)
+ (char/= character (char-downcase character)))
+
+(defun lower-case-p (character)
+ (char/= character (char-upcase character)))
+
+(defun both-case-p (character)
+ (or (upper-case-p character) (lower-case-p character)))
+
(defun char-int (character)
;; no implementation-defined character attributes
(char-code character))
(defconstant char-code-limit 1114111) ;; 0x10FFFF
+
+(defconstant +ascii-names+
+ #("NULL" "START_OF_HEADING" "START_OF_TEXT" "END_OF_TEXT" "END_OF_TRANSMISSION" "ENQUIRY" "ACKNOWLEDGE"
+ "BELL" "Backspace" "Tab" "Newline" "LINE_TABULATION" "Page" "Return" "SHIFT_OUT" "SHIFT_IN"
+ "DATA_LINK_ESCAPE" "DEVICE_CONTROL_ONE" "DEVICE_CONTROL_TWO" "DEVICE_CONTROL_THREE" "DEVICE_CONTROL_FOUR"
+ "NEGATIVE_ACKNOWLEDGE" "SYNCHRONOUS_IDLE" "END_OF_TRANSMISSION_BLOCK" "CANCEL" "END_OF_MEDIUM" "SUBSTITUTE"
+ "ESCAPE" "INFORMATION_SEPARATOR_FOUR" "INFORMATION_SEPARATOR_THREE" "INFORMATION_SEPARATOR_TWO"
+ "INFORMATION_SEPARATOR_ONE" "Space" "EXCLAMATION_MARK" "QUOTATION_MARK" "NUMBER_SIGN" "DOLLAR_SIGN"
+ "PERCENT_SIGN" "AMPERSAND" "APOSTROPHE" "LEFT_PARENTHESIS" "RIGHT_PARENTHESIS" "ASTERISK" "PLUS_SIGN"
+ "COMMA" "HYPHEN-MINUS" "FULL_STOP" "SOLIDUS" "DIGIT_ZERO" "DIGIT_ONE" "DIGIT_TWO" "DIGIT_THREE" "DIGIT_FOUR"
+ "DIGIT_FIVE" "DIGIT_SIX" "DIGIT_SEVEN" "DIGIT_EIGHT" "DIGIT_NINE" "COLON" "SEMICOLON" "LESS-THAN_SIGN"
+ "EQUALS_SIGN" "GREATER-THAN_SIGN" "QUESTION_MARK" "COMMERCIAL_AT" "LATIN_CAPITAL_LETTER_A"
+ "LATIN_CAPITAL_LETTER_B" "LATIN_CAPITAL_LETTER_C" "LATIN_CAPITAL_LETTER_D" "LATIN_CAPITAL_LETTER_E"
+ "LATIN_CAPITAL_LETTER_F" "LATIN_CAPITAL_LETTER_G" "LATIN_CAPITAL_LETTER_H" "LATIN_CAPITAL_LETTER_I"
+ "LATIN_CAPITAL_LETTER_J" "LATIN_CAPITAL_LETTER_K" "LATIN_CAPITAL_LETTER_L" "LATIN_CAPITAL_LETTER_M"
+ "LATIN_CAPITAL_LETTER_N" "LATIN_CAPITAL_LETTER_O" "LATIN_CAPITAL_LETTER_P" "LATIN_CAPITAL_LETTER_Q"
+ "LATIN_CAPITAL_LETTER_R" "LATIN_CAPITAL_LETTER_S" "LATIN_CAPITAL_LETTER_T" "LATIN_CAPITAL_LETTER_U"
+ "LATIN_CAPITAL_LETTER_V" "LATIN_CAPITAL_LETTER_W" "LATIN_CAPITAL_LETTER_X" "LATIN_CAPITAL_LETTER_Y"
+ "LATIN_CAPITAL_LETTER_Z" "LEFT_SQUARE_BRACKET" "REVERSE_SOLIDUS" "RIGHT_SQUARE_BRACKET" "CIRCUMFLEX_ACCENT"
+ "LOW_LINE" "GRAVE_ACCENT" "LATIN_SMALL_LETTER_A" "LATIN_SMALL_LETTER_B" "LATIN_SMALL_LETTER_C"
+ "LATIN_SMALL_LETTER_D" "LATIN_SMALL_LETTER_E" "LATIN_SMALL_LETTER_F" "LATIN_SMALL_LETTER_G"
+ "LATIN_SMALL_LETTER_H" "LATIN_SMALL_LETTER_I" "LATIN_SMALL_LETTER_J" "LATIN_SMALL_LETTER_K"
+ "LATIN_SMALL_LETTER_L" "LATIN_SMALL_LETTER_M" "LATIN_SMALL_LETTER_N" "LATIN_SMALL_LETTER_O"
+ "LATIN_SMALL_LETTER_P" "LATIN_SMALL_LETTER_Q" "LATIN_SMALL_LETTER_R" "LATIN_SMALL_LETTER_S"
+ "LATIN_SMALL_LETTER_T" "LATIN_SMALL_LETTER_U" "LATIN_SMALL_LETTER_V" "LATIN_SMALL_LETTER_W"
+ "LATIN_SMALL_LETTER_X" "LATIN_SMALL_LETTER_Y" "LATIN_SMALL_LETTER_Z" "LEFT_CURLY_BRACKET" "VERTICAL_LINE"
+ "RIGHT_CURLY_BRACKET" "TILDE" "Rubout")
+ "Names/codepoints of the first 128 characters from Unicode 6.2,
+except with Common Lisp's suggested changes.
+For the first 32 characters ('C0 controls'), the first
+'Commonly used alternative alias' is used -- note that this differs from SBCL, which uses abbreviations.")
+;; I hope being slightly different from SBCL doesn't bite me down the road.
+;; I'll figure out a good way to add the other 21701 names later.
+
+(defun char-name (char)
+ ;; For consistency, I'm using the SBCL convention of the Unicode
+ ;; name, with spaces as underscores. It would be nice to use
+ ;; their "Uxxxx" convention for names I don't know, but there's
+ ;; not much in FORMAT yet. I'm only implementing ASCII names right
+ ;; now, since Unicode is kind of big.
+ (let ((code (char-code char)))
+ (if (<= code 127)
+ (aref +ascii-names+ code)
+ nil))) ;; for now, no name
+
+(defun name-char (name)
+ (let ((name-upcase (string-upcase (string name))))
+ (dotimes (i (length +ascii-names+))
+ (when (string= name-upcase (string-upcase (aref +ascii-names+ i))) ;; poor man's STRING-EQUAL
+ (return-from name-char (code-char i))))
+ nil))
projects / jscl.git / blobdiff