/[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.2 by rtoy, Wed Apr 15 14:41:55 2009 UTC
# 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))))))

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

  ViewVC Help
Powered by ViewVC 1.1.5