src/base/uchars.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Surrogates of chars.
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Constants
  10 ;;;-------------------------------------------------------------------------
  11
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defconstant uchar-code-limit #x110000))
  14 \f
  15
  16 ;;;-------------------------------------------------------------------------
  17 ;;; Classes and Types
  18 ;;;-------------------------------------------------------------------------
  19
  20 (deftype uchar ()
  21   '(mod #.uchar-code-limit))
  22
  23 (deftype ustring (&optional (size '*))
  24   `(simple-array uchar (,size)))
  25 \f
  26
  27 ;;;-------------------------------------------------------------------------
  28 ;;; Constructors
  29 ;;;-------------------------------------------------------------------------
  30
  31 ;; FIXME: USELESS ?
  32 (defun code-uchar (code)
  33   (check-type code (mod #.uchar-code-limit))
  34   code)
  35
  36 ;; FIXME: USELESS ?
  37 (defun uchar-code (uchar)
  38   (check-type uchar uchar)
  39   uchar)
  40
  41 (defun char-to-uchar (character)
  42   (char-code character))
  43
  44 (defun uchar-to-char (uchar)
  45   (code-char uchar))
  46
  47 (defun digit-uchar (digit &optional (radix 10))
  48   (check-type digit unsigned-byte)
  49   (check-type radix (integer 2 36))
  50   (if (< digit radix)
  51       (+ digit #x30)
  52       nil))
  53
  54 (defun uchar (thing)
  55   (etypecase thing
  56     (uchar thing)
  57     ((ustring 1) (aref thing 0))
  58     (character-designator
  59      (char-to-uchar (character thing)))))
  60 \f
  61
  62 ;;;-------------------------------------------------------------------------
  63 ;;; Predicates
  64 ;;;-------------------------------------------------------------------------
  65
  66 (defun ucharp (uchar)
  67   (typep uchar 'uchar))
  68
  69 (defun unicode-uchar-p (uchar)
  70   (check-type uchar uchar)
  71   (or (< uchar #xD800)
  72       (> uchar #xDFFF)))
  73
  74 (defun uchar/= (uchar &rest more-uchars)
  75   (check-type uchar uchar)
  76   (assert (every #'ucharp more-uchars))
  77   (= (1+ (length more-uchars))
  78      (length (remove-duplicates (list* uchar more-uchars)
  79                                 :test #'=))))
  80
  81 (defun uchar-not-equal (uchar &rest more-uchars)
  82   (check-type uchar uchar)
  83   (assert (every #'ucharp more-uchars))
  84   (= (1+ (length more-uchars))
  85      (length (remove-duplicates (list* uchar more-uchars)
  86                                 :test #'= :key #'uchar-downcase))))
  87
  88 (macrolet
  89     ((define-uchar-comparison (name test &key (key 'identity))
  90        `(defun ,name (uchar &rest more-uchars)
  91           (check-type uchar uchar)
  92           (assert (every #'ucharp more-uchars))
  93           (do* ((r (,key uchar) (,key (car list)))
  94                 (list more-uchars (cdr list)))
  95                ((null list) t)
  96             (unless (,test r (,key (car list)))
  97               (return nil))))))
  98   (define-uchar-comparison uchar=              =                   )
  99   (define-uchar-comparison uchar-equal         = :key uchar-downcase)
 100   (define-uchar-comparison uchar<              <                   )
 101   (define-uchar-comparison uchar-lessp         < :key uchar-downcase)
 102   (define-uchar-comparison uchar>              >                   )
 103   (define-uchar-comparison uchar-greaterp      > :key uchar-downcase)
 104   (define-uchar-comparison uchar<=            <=                   )
 105   (define-uchar-comparison uchar-not-greaterp <= :key uchar-downcase)
 106   (define-uchar-comparison uchar>=            >=                   )
 107   (define-uchar-comparison uchar-not-lessp    >= :key uchar-downcase))
 108
 109 (defun alpha-uchar-p (uchar)
 110   (and (unicode-uchar-p uchar)
 111        (alpha-char-p (uchar-to-char uchar))))
 112
 113 (defun alphanumeric-uchar-p (uchar)
 114   (and (unicode-uchar-p uchar)
 115        (alphanumericp (uchar-to-char uchar))))
 116
 117 (defun digit-uchar-p (uchar &optional (radix 10))
 118   (digit-char-p (uchar-to-char uchar) radix))
 119
 120 (defun graphic-uchar-p (uchar)
 121   (and (unicode-uchar-p uchar)
 122        (graphic-char-p (uchar-to-char uchar))))
 123
 124 (defun upper-case-uchar-p (uchar)
 125   (and (unicode-uchar-p uchar)
 126        (upper-case-p (uchar-to-char uchar))))
 127
 128 (defun lower-case-uchar-p (uchar)
 129   (and (unicode-uchar-p uchar)
 130        (lower-case-p (uchar-to-char uchar))))
 131
 132 (defun both-case-uchar-p (uchar)
 133   (and (unicode-uchar-p uchar)
 134        (both-case-p (uchar-to-char uchar))))
 135 \f
 136
 137 ;;;-------------------------------------------------------------------------
 138 ;;; Operators
 139 ;;;-------------------------------------------------------------------------
 140
 141 (defun uchar-upcase (uchar)
 142   (if (unicode-uchar-p uchar)
 143       (char-to-uchar (char-upcase (uchar-to-char uchar)))
 144       uchar))
 145
 146 (defun uchar-downcase (uchar)
 147   (if (unicode-uchar-p uchar)
 148       (char-to-uchar (char-downcase (uchar-to-char uchar)))
 149       uchar))
 150