/[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.5 by rtoy, Mon Apr 20 19:46:48 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
23              string-to-nfd string-to-nfkd string-to-nfc string-to-nfkc
24            make-string            make-string
25            string-trim string-left-trim string-right-trim            string-trim string-left-trim string-right-trim
26            string-upcase            string-upcase
# Line 143  Line 144 
144                         (the fixnum end2))                         (the fixnum end2))
145                      ,(if lessp                      ,(if lessp
146                           `nil                           `nil
147                         `(- (the fixnum index) ,offset1)))                           `(- (the fixnum index) ,offset1)))
148                       #-unicode
149                     ((,(if lessp 'char< 'char>)                     ((,(if lessp 'char< 'char>)
150                       (schar string1 index)                       (schar string1 index)
151                       (schar string2 (+ (the fixnum index) (- start2 start1))))                       (schar string2 (+ (the fixnum index) (- start2 start1))))
152                      (- (the fixnum index) ,offset1))                      (- (the fixnum index) ,offset1))
153                     (t nil))                     #-unicode
154                       (t nil)
155                       #+unicode
156                       (t
157                        ;; Compare in code point order.  See
158                        ;; http://icu-project.org/docs/papers/utf16_code_point_order.html
159                        (flet ((fixup (code)
160                                 (if (>= code #xe000)
161                                     (- code #x800)
162                                     (+ code #x2000))))
163                          (declare (inline fixup))
164                          (let* ((c1 (char-code (schar string1 index)))
165                                 (c2 (char-code (schar string2 (+ (the fixnum index) (- start2 start1))))))
166                            (cond ((and (>= c1 #xd800)
167                                        (>= c2 #xd800))
168                                   (let ((fix-c1 (fixup c1))
169                                         (fix-c2 (fixup c2)))
170                                     (if (,(if lessp '< '>) fix-c1 fix-c2)
171                                         (- (the fixnum index) ,offset1)
172                                         nil)))
173                                  (t
174                                   (if (,(if lessp '< '>) c1 c2)
175                                         (- (the fixnum index) ,offset1)
176                                         nil)))))))
177               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
178  ) ; eval-when  ) ; eval-when
179    
# Line 391  Line 416 
416               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
417              ((= index (the fixnum end)))              ((= index (the fixnum end)))
418            (declare (fixnum index new-index))            (declare (fixnum index new-index))
419            (setf (schar newstring new-index)            (let ((code (char-code (schar string index))))
420                  (char-upcase (schar string index))))              (when (and (<= #xD800 code #xDBFF) (< (1+ index) (the fixnum end)))
421                  (setq code (+ (ash (- code #xD800) 10) #x2400
422                                (char-code (schar string (incf index))))))
423                (setq code (unicode-upper code))
424                (if (< code #x10000)
425                    (setf (schar newstring new-index) (code-char code))
426                    (let* ((tmp (- code #x10000))
427                           (hi (logior (ldb (byte 10 10) tmp) #xD800))
428                           (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
429                      (setf (schar newstring new-index) (code-char hi))
430                      ;;@@ WARNING: this may, in theory, need to extend newstring
431                      ;;  but that never actually occurs as of Unicode 5.1.0,
432                      ;;  so I'm just going to ignore it for now...
433                      (setf (schar newstring (incf new-index)) (code-char lo))))))
434            ;;@@ WARNING: see above
435          (do ((index end (1+ index))          (do ((index end (1+ index))
436               (new-index (- (the fixnum end) offset) (1+ new-index)))               (new-index (- (the fixnum end) offset) (1+ new-index)))
437              ((= index offset-slen))              ((= index offset-slen))
# Line 420  Line 459 
459               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
460              ((= index (the fixnum end)))              ((= index (the fixnum end)))
461            (declare (fixnum index new-index))            (declare (fixnum index new-index))
462            (setf (schar newstring new-index)            (let ((code (char-code (schar string index))))
463                  (char-downcase (schar string index))))              (when (and (<= #xD800 code #xDBFF) (< (1+ index) (the fixnum end)))
464                  (setq code (+ (ash (- code #xD800) 10) #x2400
465                                (char-code (schar string (incf index))))))
466                (setq code (unicode-lower code))
467                (if (< code #x10000)
468                    (setf (schar newstring new-index) (code-char code))
469                    (let* ((tmp (- code #x10000))
470                           (hi (logior (ldb (byte 10 10) tmp) #xD800))
471                           (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
472                      (setf (schar newstring new-index) (code-char hi))
473                      ;;@@ WARNING: this may, in theory, need to extend newstring
474                      ;;  but that never actually occurs as of Unicode 5.1.0,
475                      ;;  so I'm just going to ignore it for now...
476                      (setf (schar newstring (incf new-index)) (code-char lo))))))
477            ;;@@ WARNING: see above
478          (do ((index end (1+ index))          (do ((index end (1+ index))
479               (new-index (- (the fixnum end) offset) (1+ new-index)))               (new-index (- (the fixnum end) offset) (1+ new-index)))
480              ((= index offset-slen))              ((= index offset-slen))
# Line 459  Line 512 
512                   (setq newword t))                   (setq newword t))
513                  (newword                  (newword
514                   ;;char is first case-modifiable after non-case-modifiable                   ;;char is first case-modifiable after non-case-modifiable
515                   (setq char (char-upcase char))                   (setq char (char-titlecase char))
516                   (setq newword ()))                   (setq newword ()))
517                  ;;char is case-modifiable, but not first                  ;;char is case-modifiable, but not first
518                  (t (setq char (char-downcase char))))                  (t (setq char (char-downcase char))))
# Line 480  Line 533 
533        (do ((index start (1+ index)))        (do ((index start (1+ index)))
534            ((= index (the fixnum end)))            ((= index (the fixnum end)))
535          (declare (fixnum index))          (declare (fixnum index))
536          (setf (schar string index) (char-upcase (schar string index)))))          (let ((code (char-code (schar string index))))
537                (when (and (<= #xD800 code #xDBFF) (< (1+ index) (the fixnum end)))
538                  (setq code (+ (ash (- code #xD800) 10) #x2400
539                                (char-code (schar string (incf index))))))
540                (setq code (unicode-upper code))
541                (if (< code #x10000)
542                    (setf (schar string index) (code-char code))
543                    (let* ((tmp (- code #x10000))
544                           (hi (logior (ldb (byte 10 10) tmp) #xD800))
545                           (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
546                      (setf (schar newstring index) (code-char hi))
547                      ;;@@ WARNING: this may, in theory, need to extend newstring
548                      ;;      (which, obviously, we can't do here.  Unless
549                      ;;       STRING is adjustable, maybe)
550                      ;;  but that never actually occurs as of Unicode 5.1.0,
551                      ;;  so I'm just going to ignore it for now...
552                      (setf (schar string (incf index)) (code-char lo)))))))
553      save-header))      save-header))
554    
555  (defun nstring-downcase (string &key (start 0) end)  (defun nstring-downcase (string &key (start 0) end)
# Line 492  Line 561 
561        (do ((index start (1+ index)))        (do ((index start (1+ index)))
562            ((= index (the fixnum end)))            ((= index (the fixnum end)))
563          (declare (fixnum index))          (declare (fixnum index))
564          (setf (schar string index) (char-downcase (schar string index)))))          (let ((code (char-code (schar string index))))
565                (when (and (<= #xD800 code #xDBFF) (< (1+ index) (the fixnum end)))
566                  (setq code (+ (ash (- code #xD800) 10) #x2400
567                                (char-code (schar string (incf index))))))
568                (setq code (unicode-lower code))
569                (if (< code #x10000)
570                    (setf (schar string index) (code-char code))
571                    (let* ((tmp (- code #x10000))
572                           (hi (logior (ldb (byte 10 10) tmp) #xD800))
573                           (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
574                      (setf (schar string index) (code-char hi))
575                      ;;@@ WARNING: this may, in theory, need to extend newstring
576                      ;;      (which, obviously, we can't do here.  Unless
577                      ;;       STRING is adjustable, maybe)
578                      ;;  but that never actually occurs as of Unicode 5.1.0,
579                      ;;  so I'm just going to ignore it for now...
580                      (setf (schar string (incf index)) (code-char lo)))))))
581      save-header))      save-header))
582    
583  (defun nstring-capitalize (string &key (start 0) end)  (defun nstring-capitalize (string &key (start 0) end)
# Line 514  Line 599 
599                 (setq newword t))                 (setq newword t))
600                (newword                (newword
601                 ;;char is first case-modifiable after non-case-modifiable                 ;;char is first case-modifiable after non-case-modifiable
602                 (setf (schar string index) (char-upcase char))                 (setf (schar string index) (char-titlecase char))
603                 (setq newword ()))                 (setq newword ()))
604                (t                (t
605                 (setf (schar string index) (char-downcase char))))))                 (setf (schar string index) (char-downcase char))))))
# Line 557  Line 642 
642                             (1+ index))                             (1+ index))
643                          (declare (fixnum index)))))                          (declare (fixnum index)))))
644        (subseq (the simple-string string) left-end right-end))))        (subseq (the simple-string string) left-end right-end))))
645    
646    (declaim (inline %glyph-f %glyph-b))
647    (defun %glyph-f (string index)
648      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
649               (type simple-string string) (type kernel:index index))
650      (flet ((xchar (string index)
651               (let ((c (char-code (schar string index))))
652                 (declare (type (integer 0 #x10FFFF) c))
653                 (cond ((<= #xD800 c #xDBFF)
654                        (if (= (1+ index) (length string))
655                            (error "String ends with an unpaired surrogate.")
656                            (let ((c2 (char-code (schar string (1+ index)))))
657                              (if (<= #xDC00 c2 #xDFFF)
658                                  (+ (ash (- c #xD800) 10) c2 #x2400)
659                                  (error "Naked high surrogate in string.")))))
660                       ((<= #xDC00 c #xDFFF)
661                        (error "Naked low surrogate in string."))
662                       (t c)))))
663        (let* ((prev 0)
664               (l (length string))
665               (c (xchar string index))
666               (n (+ index (if (> c #xFFFF) 2 1))))
667          (declare (type (integer 0 #x10FFFF) c) (type kernel:index l n))
668          (loop while (< n l) do
669            (let* ((c (xchar string n))
670                   (d (the (unsigned-byte 8) (unicode-combining-class c))))
671              (when (or (zerop d) (< d prev))
672                (return))
673              (setq prev d)
674              (incf n (if (> c #xFFFF) 2 1))))
675          n)))
676    
677    (defun %glyph-b (string index)
678      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
679               (type simple-string string) (type kernel:index index))
680      (flet ((xchar (string index)
681               (let ((c (char-code (schar string index))))
682                 (declare (type (integer 0 #x10FFFF) c))
683                 (cond ((<= #xDC00 c #xDFFF)
684                        (let ((c2 (char-code (schar string (1- index)))))
685                          (if (<= #xD800 c2 #xDBFF)
686                              (+ (ash (- c2 #xD800) 10) c #x2400)
687                              (error "Naked low surrogate in string."))))
688                       ((<= #xD800 c #xDBFF)
689                        (error "Naked high surrogate in string."))
690                       (t c)))))
691        (let ((prev 255)
692              (n (1- index)))
693          (declare (type kernel:index n))
694          (loop while (> n 0) do
695            (let* ((c (xchar string n))
696                   (d (the (unsigned-byte 8) (unicode-combining-class c))))
697              (cond ((zerop d) (return))
698                    ((> d prev) (incf n (if (> c #xFFFF) 2 1)) (return)))
699              (setq prev d)
700              (decf n (if (> c #xFFFF) 2 1))))
701          n)))
702    
703    (defun glyph (string index &key (from-end nil))
704      "GLYPH returns the glyph at the indexed position in a string, and the
705      position of the next glyph (or NIL) as a second value.  A glyph is
706      a substring consisting of the character at INDEX followed by all
707      subsequent combining characters."
708      (declare (type simple-string string) (type kernel:index index))
709      #-unicode
710      (char string index)
711      #+unicode
712      (with-array-data ((string string) (start) (end))
713        (declare (ignore start end))
714        (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
715          (if from-end
716              (values (subseq string n index) (and (> n 0) n))
717              (values (subseq string index n) (and (< n (length string)) n))))))
718    
719    (defun sglyph (string index &key (from-end nil))
720      "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
721      except that the string must be a simple-string"
722      (declare (type simple-string string) (type kernel:index index))
723      #-unicode
724      (schar string index)
725      #+unicode
726      (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
727        (if from-end
728            (values (subseq string n index) (and (> n 0) n))
729            (values (subseq string index n) (and (< n (length string)) n)))))
730    
731    (defun string-to-nfd (string)
732      ;;@@ Implement me
733      string)
734    
735    (defun string-to-nfkd (string)
736      ;;@@ Implement me
737      string)
738    
739    (defun string-to-nfc (string)
740      ;;@@ Implement me
741      string)
742    
743    (defun string-to-nfkc (string)
744      ;;@@ Implement me
745      string)

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

  ViewVC Help
Powered by ViewVC 1.1.5