/[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 by emarsden, Fri Apr 11 15:41:59 2003 UTC revision 1.12.30.3 by rtoy, Sat Apr 18 12:27:05 2009 UTC
# Line 16  Line 16 
16  ;;; ****************************************************************  ;;; ****************************************************************
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19  (export '(char schar string  (export '(char schar glyph sglyph string
20            string= string-equal string< string> string<= string>= string/=            string= string-equal string< string> string<= string>= string/=
21            string-lessp string-greaterp string-not-lessp string-not-greaterp            string-lessp string-greaterp string-not-lessp string-not-greaterp
22            string-not-equal            string-not-equal
# Line 143  Line 143 
143                         (the fixnum end2))                         (the fixnum end2))
144                      ,(if lessp                      ,(if lessp
145                           `nil                           `nil
146                         `(- (the fixnum index) ,offset1)))                           `(- (the fixnum index) ,offset1)))
147                       #-unicode
148                     ((,(if lessp 'char< 'char>)                     ((,(if lessp 'char< 'char>)
149                       (schar string1 index)                       (schar string1 index)
150                       (schar string2 (+ (the fixnum index) (- start2 start1))))                       (schar string2 (+ (the fixnum index) (- start2 start1))))
151                      (- (the fixnum index) ,offset1))                      (- (the fixnum index) ,offset1))
152                     (t nil))                     #-unicode
153                       (t nil)
154                       #+unicode
155                       (t
156                        ;; Compare in code point order.  See
157                        ;; http://icu-project.org/docs/papers/utf16_code_point_order.html
158                        (flet ((fixup (code)
159                                 (if (>= code #xe000)
160                                     (- code #x800)
161                                     (+ code #x2000))))
162                          (declare (inline fixup))
163                          (let* ((c1 (char-code (schar string1 index)))
164                                 (c2 (char-code (schar string2 (+ (the fixnum index) (- start2 start1))))))
165                            (cond ((and (>= c1 #xd800)
166                                        (>= c2 #xd800))
167                                   (let ((fix-c1 (fixup c1))
168                                         (fix-c2 (fixup c2)))
169                                     (if (,(if lessp '< '>) fix-c1 fix-c2)
170                                         (- (the fixnum index) ,offset1)
171                                         nil)))
172                                  (t
173                                   (if (,(if lessp '< '>) c1 c2)
174                                         (- (the fixnum index) ,offset1)
175                                         nil)))))))
176               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
177  ) ; eval-when  ) ; eval-when
178    
# Line 459  Line 483 
483                   (setq newword t))                   (setq newword t))
484                  (newword                  (newword
485                   ;;char is first case-modifiable after non-case-modifiable                   ;;char is first case-modifiable after non-case-modifiable
486                   (setq char (char-upcase char))                   (setq char (char-titlecase char))
487                   (setq newword ()))                   (setq newword ()))
488                  ;;char is case-modifiable, but not first                  ;;char is case-modifiable, but not first
489                  (t (setq char (char-downcase char))))                  (t (setq char (char-downcase char))))
# Line 514  Line 538 
538                 (setq newword t))                 (setq newword t))
539                (newword                (newword
540                 ;;char is first case-modifiable after non-case-modifiable                 ;;char is first case-modifiable after non-case-modifiable
541                 (setf (schar string index) (char-upcase char))                 (setf (schar string index) (char-titlecase char))
542                 (setq newword ()))                 (setq newword ()))
543                (t                (t
544                 (setf (schar string index) (char-downcase char))))))                 (setf (schar string index) (char-downcase char))))))
# Line 557  Line 581 
581                             (1+ index))                             (1+ index))
582                          (declare (fixnum index)))))                          (declare (fixnum index)))))
583        (subseq (the simple-string string) left-end right-end))))        (subseq (the simple-string string) left-end right-end))))
584    
585    (defun glyph (string index)
586      "GLYPH returns the glyph at the indexed position in a string, and the
587       position of the next glyph (or NIL) as a second value.  A glyph is
588       a substring consisting of the character at INDEX followed by all
589       subsequent combining characters."
590      (declare (type simple-string string) (type kernel:index index))
591      #-unicode
592      (char string index)
593      #+unicode
594      (with-array-data ((string string) (start) (end))
595        (declare (ignore start end))
596        (sglyph string index)))
597    
598    (defun sglyph (string index)
599      "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
600       except that the string must be a simple-string."
601      (declare (type simple-string string) (type kernel:index index))
602      #-unicode
603      (schar string index)
604      #+unicode
605      (flet ((xchar (string index)
606               (let ((c (char-code (char string index))))
607                 (cond ((<= #xD800 c #xDBFF)
608                        (let ((c2 (char-code (char string (1+ index)))))
609                          (if (<= #xDC00 c2 #xDFFF)
610                              (+ (ash (- c #xD800) 10) c2 #x2400)
611                              (error "Naked high surrogate in string."))))
612                       ((<= #xDC00 c #xDFFF)
613                        (error "Naked low surrogate in string."))
614                       (t c)))))
615        (let* ((l (length string))
616               (c (xchar string index))
617               (n (+ index (if (> c #xFFFF) 2 1))))
618          (declare (type (integer 0 #x10FFFF) c) (type kernel:index n))
619          (loop while (< n l) do
620            (let ((c (xchar string n)))
621              (when (zerop (lisp::unicode-combining-class c)) (return))
622              (incf n (if (> c #xFFFF) 2 1))))
623          (values (subseq string index n) (and (< n l) n)))))

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.12.30.3

  ViewVC Help
Powered by ViewVC 1.1.5