src/char.lisp

   1 (defun character (character)
   2   (cond ((characterp character)
   3          character)
   4         ((and (stringp character)
   5               (= 1 (length character)))
   6          (char character 0))
   7         ((and (symbolp character)
   8               (= 1 (length (symbol-name character))))
   9          (symbol-name character))
  10         (t
  11          (error "not a valid character designator"))))
  12
  13 ;; This list comes from SBCL: everything that's ALPHA-CHAR-P, but
  14 ;; not SB-IMPL::UCD-DECIMAL-DIGIT (to work around <https://bugs.launchpad.net/sbcl/+bug/1177986>),
  15 ;; then combined into a much smaller set of ranges.  Yes, this can be compressed better.
  16 (defconstant +unicode-alphas+
  17   '((65 . 90) (97 . 122) (170 . 170) (181 . 181) (186 . 186) (192 . 214)
  18     (216 . 246) (248 . 705) (710 . 721) (736 . 740) (748 . 748) (750 . 750)
  19     (880 . 884) (886 . 887) (890 . 893) (902 . 902) (904 . 906) (908 . 908)
  20     (910 . 929) (931 . 1013) (1015 . 1153) (1162 . 1317) (1329 . 1366)
  21     (1369 . 1369) (1377 . 1415) (1488 . 1514) (1520 . 1522) (1569 . 1610)
  22     (1646 . 1647) (1649 . 1747) (1749 . 1749) (1765 . 1766) (1774 . 1775)
  23     (1786 . 1788) (1791 . 1791) (1808 . 1808) (1810 . 1839) (1869 . 1957)
  24     (1969 . 1969) (1994 . 2026) (2036 . 2037) (2042 . 2042) (2048 . 2069)
  25     (2074 . 2074) (2084 . 2084) (2088 . 2088) (2308 . 2361) (2365 . 2365)
  26     (2384 . 2384) (2392 . 2401) (2417 . 2418) (2425 . 2431) (2437 . 2444)
  27     (2447 . 2448) (2451 . 2472) (2474 . 2480) (2482 . 2482) (2486 . 2489)
  28     (2493 . 2493) (2510 . 2510) (2524 . 2525) (2527 . 2529) (2544 . 2545)
  29     (2565 . 2570) (2575 . 2576) (2579 . 2600) (2602 . 2608) (2610 . 2611)
  30     (2613 . 2614) (2616 . 2617) (2649 . 2652) (2654 . 2654) (2674 . 2676)
  31     (2693 . 2701) (2703 . 2705) (2707 . 2728) (2730 . 2736) (2738 . 2739)
  32     (2741 . 2745) (2749 . 2749) (2768 . 2768) (2784 . 2785) (2821 . 2828)
  33     (2831 . 2832) (2835 . 2856) (2858 . 2864) (2866 . 2867) (2869 . 2873)
  34     (2877 . 2877) (2908 . 2909) (2911 . 2913) (2929 . 2929) (2947 . 2947)
  35     (2949 . 2954) (2958 . 2960) (2962 . 2965) (2969 . 2970) (2972 . 2972)
  36     (2974 . 2975) (2979 . 2980) (2984 . 2986) (2990 . 3001) (3024 . 3024)
  37     (3077 . 3084) (3086 . 3088) (3090 . 3112) (3114 . 3123) (3125 . 3129)
  38     (3133 . 3133) (3160 . 3161) (3168 . 3169) (3205 . 3212) (3214 . 3216)
  39     (3218 . 3240) (3242 . 3251) (3253 . 3257) (3261 . 3261) (3294 . 3294)
  40     (3296 . 3297) (3333 . 3340) (3342 . 3344) (3346 . 3368) (3370 . 3385)
  41     (3389 . 3389) (3424 . 3425) (3450 . 3455) (3461 . 3478) (3482 . 3505)
  42     (3507 . 3515) (3517 . 3517) (3520 . 3526) (3585 . 3632) (3634 . 3635)
  43     (3648 . 3654) (3713 . 3714) (3716 . 3716) (3719 . 3720) (3722 . 3722)
  44     (3725 . 3725) (3732 . 3735) (3737 . 3743) (3745 . 3747) (3749 . 3749)
  45     (3751 . 3751) (3754 . 3755) (3757 . 3760) (3762 . 3763) (3773 . 3773)
  46     (3776 . 3780) (3782 . 3782) (3804 . 3805) (3840 . 3840) (3904 . 3911)
  47     (3913 . 3948) (3976 . 3979) (4096 . 4138) (4159 . 4159) (4176 . 4181)
  48     (4186 . 4189) (4193 . 4193) (4197 . 4198) (4206 . 4208) (4213 . 4225)
  49     (4238 . 4238) (4256 . 4293) (4304 . 4346) (4348 . 4348) (4352 . 4680)
  50     (4682 . 4685) (4688 . 4694) (4696 . 4696) (4698 . 4701) (4704 . 4744)
  51     (4746 . 4749) (4752 . 4784) (4786 . 4789) (4792 . 4798) (4800 . 4800)
  52     (4802 . 4805) (4808 . 4822) (4824 . 4880) (4882 . 4885) (4888 . 4954)
  53     (4992 . 5007) (5024 . 5108) (5121 . 5740) (5743 . 5759) (5761 . 5786)
  54     (5792 . 5866) (5888 . 5900) (5902 . 5905) (5920 . 5937) (5952 . 5969)
  55     (5984 . 5996) (5998 . 6000) (6016 . 6067) (6103 . 6103) (6108 . 6108)
  56     (6176 . 6263) (6272 . 6312) (6314 . 6314) (6320 . 6389) (6400 . 6428)
  57     (6480 . 6509) (6512 . 6516) (6528 . 6571) (6593 . 6599) (6656 . 6678)
  58     (6688 . 6740) (6823 . 6823) (6917 . 6963) (6981 . 6987) (7043 . 7072)
  59     (7086 . 7087) (7168 . 7203) (7245 . 7247) (7258 . 7293) (7401 . 7404)
  60     (7406 . 7409) (7424 . 7615) (7680 . 7957) (7960 . 7965) (7968 . 8005)
  61     (8008 . 8013) (8016 . 8023) (8025 . 8025) (8027 . 8027) (8029 . 8029)
  62     (8031 . 8061) (8064 . 8116) (8118 . 8124) (8126 . 8126) (8130 . 8132)
  63     (8134 . 8140) (8144 . 8147) (8150 . 8155) (8160 . 8172) (8178 . 8180)
  64     (8182 . 8188) (8305 . 8305) (8319 . 8319) (8336 . 8340) (8450 . 8450)
  65     (8455 . 8455) (8458 . 8467) (8469 . 8469) (8473 . 8477) (8484 . 8484)
  66     (8486 . 8486) (8488 . 8488) (8490 . 8493) (8495 . 8505) (8508 . 8511)
  67     (8517 . 8521) (8526 . 8526) (8579 . 8580) (11264 . 11310) (11312 . 11358)
  68     (11360 . 11492) (11499 . 11502) (11520 . 11557) (11568 . 11621)
  69     (11631 . 11631) (11648 . 11670) (11680 . 11686) (11688 . 11694)
  70     (11696 . 11702) (11704 . 11710) (11712 . 11718) (11720 . 11726)
  71     (11728 . 11734) (11736 . 11742) (11823 . 11823) (12293 . 12294)
  72     (12337 . 12341) (12347 . 12348) (12353 . 12438) (12445 . 12447)
  73     (12449 . 12538) (12540 . 12543) (12549 . 12589) (12593 . 12686)
  74     (12704 . 12727) (12784 . 12799) (13312 . 19893) (19968 . 40907)
  75     (40960 . 42124) (42192 . 42237) (42240 . 42508) (42512 . 42527)
  76     (42538 . 42539) (42560 . 42591) (42594 . 42606) (42623 . 42647)
  77     (42656 . 42725) (42775 . 42783) (42786 . 42888) (42891 . 42892)
  78     (43003 . 43009) (43011 . 43013) (43015 . 43018) (43020 . 43042)
  79     (43072 . 43123) (43138 . 43187) (43250 . 43255) (43259 . 43259)
  80     (43274 . 43301) (43312 . 43334) (43360 . 43388) (43396 . 43442)
  81     (43471 . 43471) (43520 . 43560) (43584 . 43586) (43588 . 43595)
  82     (43616 . 43638) (43642 . 43642) (43648 . 43695) (43697 . 43697)
  83     (43701 . 43702) (43705 . 43709) (43712 . 43712) (43714 . 43714)
  84     (43739 . 43741) (43968 . 44002) (44032 . 55203) (55216 . 55238)
  85     (55243 . 55291) (63744 . 64045) (64048 . 64109) (64112 . 64217)
  86     (64256 . 64262) (64275 . 64279) (64285 . 64285) (64287 . 64296)
  87     (64298 . 64310) (64312 . 64316) (64318 . 64318) (64320 . 64321)
  88     (64323 . 64324) (64326 . 64433) (64467 . 64829) (64848 . 64911)
  89     (64914 . 64967) (65008 . 65019) (65136 . 65140) (65142 . 65276)
  90     (65313 . 65338) (65345 . 65370) (65382 . 65470) (65474 . 65479)
  91     (65482 . 65487) (65490 . 65495) (65498 . 65500) (65536 . 65547)
  92     (65549 . 65574) (65576 . 65594) (65596 . 65597) (65599 . 65613)
  93     (65616 . 65629) (65664 . 65786) (66176 . 66204) (66208 . 66256)
  94     (66304 . 66334) (66352 . 66368) (66370 . 66377) (66432 . 66461)
  95     (66464 . 66499) (66504 . 66511) (66560 . 66717) (67584 . 67589)
  96     (67592 . 67592) (67594 . 67637) (67639 . 67640) (67644 . 67644)
  97     (67647 . 67669) (67840 . 67861) (67872 . 67897) (68096 . 68096)
  98     (68112 . 68115) (68117 . 68119) (68121 . 68147) (68192 . 68220)
  99     (68352 . 68405) (68416 . 68437) (68448 . 68466) (68608 . 68680)
 100     (69763 . 69807) (73728 . 74606) (77824 . 78894) (119808 . 119892)
 101     (119894 . 119964) (119966 . 119967) (119970 . 119970) (119973 . 119974)
 102     (119977 . 119980) (119982 . 119993) (119995 . 119995) (119997 . 120003)
 103     (120005 . 120069) (120071 . 120074) (120077 . 120084) (120086 . 120092)
 104     (120094 . 120121) (120123 . 120126) (120128 . 120132) (120134 . 120134)
 105     (120138 . 120144) (120146 . 120485) (120488 . 120512) (120514 . 120538)
 106     (120540 . 120570) (120572 . 120596) (120598 . 120628) (120630 . 120654)
 107     (120656 . 120686) (120688 . 120712) (120714 . 120744) (120746 . 120770)
 108     (120772 . 120779) (131072 . 173782) (173824 . 177972) (194560 . 195101))
 109   "(Start . End) ranges of codepoints for alphabetic characters, as of Unicode 6.2.")
 110
 111 (defun alpha-char-p (char)
 112   (let ((code (char-code char)))
 113     (dolist (alpha-pair +unicode-alphas+)
 114       (when (<= (car alpha-pair) code (cdr alpha-pair))
 115         (return-from alpha-char-p t)))
 116     nil))
 117
 118 (defun alphanumericp (char)
 119   ;; from the hyperspec:
 120   (or (alpha-char-p char)
 121       (not (null (digit-char-p char)))))
 122
 123 ;; I made this list by running DIGIT-CHAR-P in SBCL on every codepoint up to CHAR-CODE-LIMIT,
 124 ;; filtering on only those with SB-IMPL::UCD-GENERAL-CATEGORY 12 (Nd), and then grouping
 125 ;; consecutive sets.  There's 37 spans of 10, plus 1 extra digit (6618).
 126 (defconstant +unicode-zeroes+
 127   '(48 1632 1776 1984 2406 2534 2662 2790 2918 3046 3174 3302 3430 3664
 128        3792 3872 4160 4240 6112 6160 6470 6608 6784 6800 6992 7088 7232 7248
 129        42528 43216 43264 43472 43600 44016 65296 66720 120782)
 130   "Unicode codepoints which have Digit value 0, followed by 1, 2, ..., 9, as of Unicode 6.2")
 131
 132 ;; The "Digit value" of a (Unicode) character, or NIL, if it doesn't have one.
 133 (defun unicode-digit-value (char)
 134   (let ((code (char-code char)))
 135     (if (= code 6618)
 136         1  ;; it's special!
 137       (dolist (z +unicode-zeroes+)
 138         (when (<= z code (+ z 9))
 139           (return-from unicode-digit-value (- code z)))))))
 140
 141 ;; from SBCL/CMUCL:
 142 (defun digit-char (weight &optional (radix 10))
 143   "All arguments must be integers. Returns a character object that represents
 144 a digit of the given weight in the specified radix. Returns NIL if no such
 145 character exists."
 146   (and ;; (typep weight 'fixnum)
 147        (>= weight 0) (< weight radix) (< weight 36)
 148        (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
 149
 150 ;; borrowed from my proposed fix to SBCL: https://bugs.launchpad.net/sbcl/+bug/1177986
 151 (defun digit-char-p (char &optional (radix 10))
 152   (let ((number (unicode-digit-value char))
 153         (code (char-code char))
 154         (little-a (char-code #\a))
 155         (big-a (char-code #\A)))
 156     (cond ((and number (< number radix))
 157            number)
 158           (number
 159            nil)
 160           ((<= big-a code (+ big-a radix -10 -1))
 161            (+ code (- big-a) 10))
 162           ((<= little-a code (+ little-a radix -10 -1))
 163            (+ code (- little-a) 10))
 164           (t nil))))
 165
 166 (defun graphic-char-p (char)
 167   ;; from SBCL/CMUCL:
 168   (let ((n (char-code char)))
 169     (or (< 31 n 127)
 170         (< 159 n))))
 171
 172 (defun standard-char-p (char)
 173   ;; from SBCL/CMUCL:
 174   (and (let ((n (char-code char)))
 175          (or (< 31 n 127)
 176              (= n 10)))))
 177
 178 (defun char-int (character)
 179   ;; no implementation-defined character attributes
 180   (char-code character))
 181
 182 (defconstant char-code-limit 1114111)  ;; 0x10FFFF