Ignore:
Timestamp:
Oct 9, 2007, 2:50:27 AM (14 years ago)
Author:
gb
Message:

Treat non STANDARD-CHARs which obviously have "case" as if they had case;
this affects UPPER-CASE-P/LOWER-CASE-P, CHAR-UPCASE/-DOWNCASE, ALPHA-CHAR-P
and BOTH-CASE-P, [N]STRING-UPCASE/DOWNCASE, etc.

This stuff is currently only defined for characters C for which either:

(char-upcase C) is distinct from C, and downcasing the uppercase version
returns C, or

(char-downcase C) is distinct from C, and uppercasing the downcase version
returns C.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/chars.lisp

    r5328 r7369  
    8181
    8282
     83(defun %non-standard-lower-case-equivalent (char)
     84  (gethash char *non-standard-upper-to-lower*))
     85
     86
    8387
    8488(defun upper-case-p (c)
     
    8791  (let* ((code (char-code c)))
    8892    (declare (type (mod #x110000) code))
    89     (and (>= code (char-code #\A))
    90          (<= code (char-code #\Z)))))
     93    (or (and (>= code (char-code #\A))
     94             (<= code (char-code #\Z)))
     95        (and (>= code #x80)
     96             (not (null (%non-standard-lower-case-equivalent c)))))))
    9197
    9298
     
    115121          (<= code (char-code #\z)))
    116122     (and (>= code (char-code #\A))
    117           (<= code (char-code #\Z))))))
     123          (<= code (char-code #\Z)))
     124     (and (> code #x80)
     125          (or (not (null (%non-standard-upper-case-equivalent c)))
     126              (not (null (%non-standard-lower-case-equivalent c))))))))
    118127
    119128(defun char= (ch &rest others)
     
    297306  (%strdown string start end))
    298307
     308
    299309(defun %strdown (string start end)
    300   (declare (fixnum start end))
    301   (loop
    302     (when (>= start end)(return string))
    303     (let ((code (%scharcode string start)))
    304       (when (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
    305         (setq code (%i+ code #.(- (char-code #\a)(char-code #\A))))
    306         (setf (%scharcode string start) code))
    307       (setq start (%i+ 1 start)))))
     310  (declare (fixnum start end)
     311           (optimize (speed 3) (safety 0)))
     312  (unless (typep string 'simple-string)
     313    (check-type string simple-string))
     314  (do* ((i start (1+ i)))
     315       ((>= i end) string)
     316    (declare (fixnum i))
     317    (let* ((ch (schar string i))
     318           (code (char-code ch))
     319           (lower (if (and (char<= ch #\Z)
     320                           (char>= ch #\A))
     321                    (%code-char (the (unsigned-byte 8)
     322                                  (+ code (- (char-code #\a)(char-code #\A)))))
     323                    (if (>= code #x80)
     324                      (%non-standard-lower-case-equivalent ch)))))
     325      (declare (character ch) (type (mod #x11000) code))
     326      (when lower
     327        (setf (schar string i) lower)))))
     328
     329
    308330
    309331
     
    328350
    329351(defun %strup (string start end)
    330   (declare (fixnum start end))
    331   (loop
    332     (when (>= start end)(return string))
    333     (let ((code (%scharcode string start)))
    334       (when (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
    335         (setq code (%i- code #.(- (char-code #\a)(char-code #\A))))
    336         (setf (%scharcode string start) code))
    337       (setq start (%i+ 1 start)))))
     352  (declare (fixnum start end)
     353           (optimize (speed 3) (safety 0)))
     354  (unless (typep string 'simple-string)
     355    (check-type string simple-string))
     356  (do* ((i start (1+ i)))
     357       ((>= i end) string)
     358    (declare (fixnum i))
     359    (let* ((ch (schar string i))
     360           (code (char-code ch))
     361           (upper (if (and (char<= ch #\z)
     362                           (char>= ch #\a))
     363                    (%code-char (the (unsigned-byte 8)
     364                                  (- code (- (char-code #\a)(char-code #\A)))))
     365                    (if (>= code #x80)
     366                      (%non-standard-upper-case-equivalent ch)))))
     367      (declare (character ch) (type (mod #x11000) code))
     368      (when upper
     369        (setf (schar string i) upper)))))
    338370
    339371
Note: See TracChangeset for help on using the changeset viewer.