/[cmucl]/src/code/string.lisp
ViewVC logotype

Diff of /src/code/string.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12.30.18 by rtoy, Wed May 20 16:30:08 2009 UTC revision 1.12.30.19 by rtoy, Wed May 20 21:47:36 2009 UTC
# Line 28  Line 28 
28            nstring-capitalize))            nstring-capitalize))
29    
30    
31  (declaim (inline surrogates-to-codepoint codepoint surrogates))  (declaim (inline surrogatep surrogates-to-codepoint codepoint surrogates))
32    
33    (defun surrogatep (c &optional surrogate-type)
34      "Test if C is a surrogate.  C may be either an integer or a
35      character. Surrogate-type indicates what kind of surrogate to test
36      for.  :High means to test for the high (leading) surrogate; :Low
37      tests for the low (trailing surrogate).  A value of :Any or Nil
38      tests for any surrogate value (high or low)."
39      (declare (type (or character (integer 0 #x10ffff)) c))
40      (let ((code (if (characterp c)
41                      (char-code c)
42                      c)))
43        (ecase surrogate-type
44          ((:high :leading)
45           ;; Test for high surrogate
46           (<= #xD800 code #xDBFF))
47          ((:low :trailing)
48           ;; Test for low surrogate
49           (<= #xDC00 code #xDFFF))
50          ((:any nil)
51           ;; Test for any surrogate
52           (<= #xD800 code #xDFFF)))))
53    
54  (defun surrogates-to-codepoint (hi lo)  (defun surrogates-to-codepoint (hi lo)
55    "Convert the given Hi and Lo surrogate characters to the    "Convert the given Hi and Lo surrogate characters to the
# Line 46  Line 67 
67    surrogate value, respectively."    surrogate value, respectively."
68    (declare (type simple-string string) (type kernel:index i end))    (declare (type simple-string string) (type kernel:index i end))
69    (let ((code (char-code (schar string i))))    (let ((code (char-code (schar string i))))
70      (cond ((and (<= #xD800 code #xDBFF) (< (1+ i) end))      (cond ((and (surrogatep code :high) (< (1+ i) end))
71             (let ((tmp (char-code (schar string (1+ i)))))             (let ((tmp (char-code (schar string (1+ i)))))
72               (if (<= #xDC00 tmp #xDFFF)               (if (surrogatep tmp :low)
73                   (values (+ (ash (- code #xD800) 10) tmp #x2400) +1)                   (values (+ (ash (- code #xD800) 10) tmp #x2400) +1)
74                   (values code nil))))                   (values code nil))))
75            ((and (<= #xDC00 code #xDFFF) (> i 0))            ((and (surrogatep code :low) (> i 0))
76             (let ((tmp (char-code (schar string (1- i)))))             (let ((tmp (char-code (schar string (1- i)))))
77               (if (<= #xD800 tmp #xDBFF)               (if (surrogatep tmp :high)
78                   (values (+ (ash (- tmp #xD800) 10) code #x2400) -1)                   (values (+ (ash (- tmp #xD800) 10) code #x2400) -1)
79                   (values code nil))))                   (values code nil))))
80            (t (values code nil)))))            (t (values code nil)))))
# Line 86  Line 107 
107        ;; surrogate pair.  If we get any codepoint that is in        ;; surrogate pair.  If we get any codepoint that is in
108        ;; the surrogate range, we also have an invalid string.        ;; the surrogate range, we also have an invalid string.
109        (when (or (eq wide -1)        (when (or (eq wide -1)
110                  (<= #xD800 codepoint #xDFFF))                  (surrogatep codepoint))
111          (return-from utf16-string-p (values nil index)))          (return-from utf16-string-p (values nil index)))
112        (when wide (incf index)))))        (when wide (incf index)))))
113    

Legend:
Removed from v.1.12.30.18  
changed lines
  Added in v.1.12.30.19

  ViewVC Help
Powered by ViewVC 1.1.5