+(/debug "loading char.lisp!")
+
;; These comparison functions heavily borrowed from SBCL/CMUCL (public domain).
(defun char= (character &rest more-characters)
(list more-characters (cdr list)))
((null list) t)
(dolist (c list)
- (when (eql head c) (return-from char/= nil)))))
+ (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))))
+ (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))))
+ (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))))
+ (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))))
+ (char-int (car list)))
+ (return nil))))
(defun equal-char-code (character)
(char-code (char-upcase character)))
(do ((clist more-characters (cdr clist)))
((null clist) t)
(unless (two-arg-char-equal (car clist) character)
- (return nil))))
+ (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))))
+ ((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)))
(list more-characters (cdr list)))
((null list) t)
(unless (two-arg-char-lessp c (car list))
- (return nil))))
+ (return nil))))
(defun two-arg-char-greaterp (c1 c2)
(> (equal-char-code c1) (equal-char-code c2)))
(list more-characters (cdr list)))
((null list) t)
(unless (two-arg-char-greaterp c (car list))
- (return nil))))
+ (return nil))))
(defun two-arg-char-not-greaterp (c1 c2)
(<= (equal-char-code c1) (equal-char-code c2)))
(list more-characters (cdr list)))
((null list) t)
(unless (two-arg-char-not-greaterp c (car list))
- (return nil))))
+ (return nil))))
(defun two-arg-char-not-lessp (c1 c2)
(>= (equal-char-code c1) (equal-char-code c2)))
(list more-characters (cdr list)))
((null list) t)
(unless (two-arg-char-not-lessp c (car list))
- (return nil))))
+ (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))
;; 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)
+ (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))))
+ (return-from name-char (code-char i))))
nil))
projects / jscl.git / blobdiff