X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fchar.lisp;h=cad81a23e36ad1b35168da657050b4d472a61231;hb=29c5587e4ad81dd1442c5f54cc686a45f7cb9d2e;hp=6fe28b65e9bc7f564c4d07b1a1b93639e3a71b4b;hpb=f8e5f4e8ae9b7bdc7efc7382a26aa6e28f6c4652;p=jscl.git

diff --git a/src/char.lisp b/src/char.lisp
index 6fe28b6..cad81a2 100644
--- a/src/char.lisp
+++ b/src/char.lisp
@@ -1,3 +1,5 @@
+(/debug "loading char.lisp!")
+
 ;; These comparison functions heavily borrowed from SBCL/CMUCL (public domain).
 
 (defun char= (character &rest more-characters)
@@ -9,39 +11,39 @@
         (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)))
@@ -53,17 +55,17 @@
   (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)))
@@ -73,7 +75,7 @@
         (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)))
@@ -83,7 +85,7 @@
         (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)))
@@ -93,7 +95,7 @@
         (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)))
@@ -103,19 +105,19 @@
         (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>),
@@ -219,7 +221,7 @@
   (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)
@@ -240,10 +242,10 @@
 (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))
@@ -254,21 +256,26 @@ character exists."
        (>= 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:
@@ -282,6 +289,15 @@ character exists."
          (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))
@@ -327,15 +343,14 @@ For the first 32 characters ('C0 controls'), the first
   ;; 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))