/[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.14 by rtoy, Tue May 12 16:31:49 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 27  Line 28 
28            nstring-capitalize))            nstring-capitalize))
29    
30    
31    (declaim (inline surrogates-to-codepoint codepoint surrogates))
32    
33    (defun surrogates-to-codepoint (hi lo)
34      "Convert the given Hi and Lo surrogate characters to the
35      corresponding codepoint value"
36      (declare (type character hi lo))
37      (+ (ash (- (the (integer #xD800 #xDBFF) (char-code hi)) #xD800) 10)
38         (the (integer #xDC00 #xDFFF) (char-code lo)) #x2400))
39    
40    (defun codepoint (string i &optional (end (length string)))
41      "Return the codepoint value from String at position I.  If that
42      position is a surrogate, it is combined with either the previous or
43      following character (when possible) to compute the codepoint.  The
44      second return value is NIL if the position is not a surrogate pair.
45      Otherwise +1 or -1 is returned if the position is the high or low
46      surrogate value, respectively."
47      (declare (type simple-string string) (type kernel:index i end))
48      (let ((code (char-code (schar string i))))
49        (cond ((and (<= #xD800 code #xDBFF) (< (1+ i) end))
50               (let ((tmp (char-code (schar string (1+ i)))))
51                 (if (<= #xDC00 tmp #xDFFF)
52                     (values (+ (ash (- code #xD800) 10) tmp #x2400) +1)
53                     (values code nil))))
54              ((and (<= #xDC00 code #xDFFF) (> i 0))
55               (let ((tmp (char-code (schar string (1- i)))))
56                 (if (<= #xD800 tmp #xDBFF)
57                     (values (+ (ash (- tmp #xD800) 10) code #x2400) -1)
58                     (values code nil))))
59              (t (values code nil)))))
60    
61    (defun surrogates (codepoint)
62      "Return the high and low surrogate characters for Codepoint.  If
63      Codepoint is in the BMP, the first return value is the corresponding
64      character and the second is NIL."
65      (declare (type (integer 0 #x10FFFF) codepoint))
66      (if (< codepoint #x10000)
67          (values (code-char codepoint) nil)
68          (let* ((tmp (- codepoint #x10000))
69                 (hi (logior (ldb (byte 10 10) tmp) #xD800))
70                 (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
71            (values (code-char hi) (code-char lo)))))
72    
73    
74  (defun string (X)  (defun string (X)
75    "Coerces X into a string.  If X is a string, X is returned.  If X is a    "Coerces X into a string.  If X is a string, X is returned.  If X is a
76     symbol, X's pname is returned.  If X is a character then a one element    symbol, X's pname is returned.  If X is a character then a one element
77     string containing that character is returned.  If X cannot be coerced    string containing that character is returned.  If X cannot be coerced
78     into a string, an error occurs."    into a string, an error occurs."
79    (cond ((stringp x) x)    (cond ((stringp x) x)
80          ((symbolp x) (symbol-name x))          ((symbolp x) (symbol-name x))
81          ((characterp x)          ((characterp x)
# Line 106  Line 150 
150    
151  (defun schar (string index)  (defun schar (string index)
152    "SCHAR returns the character object at an indexed position in a string    "SCHAR returns the character object at an indexed position in a string
153     just as CHAR does, except the string must be a simple-string."    just as CHAR does, except the string must be a simple-string."
154    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
155    (schar string index))    (schar string index))
156    
# Line 143  Line 187 
187                         (the fixnum end2))                         (the fixnum end2))
188                      ,(if lessp                      ,(if lessp
189                           `nil                           `nil
190                         `(- (the fixnum index) ,offset1)))                           `(- (the fixnum index) ,offset1)))
191                       #-unicode
192                     ((,(if lessp 'char< 'char>)                     ((,(if lessp 'char< 'char>)
193                       (schar string1 index)                       (schar string1 index)
194                       (schar string2 (+ (the fixnum index) (- start2 start1))))                       (schar string2 (+ (the fixnum index) (- start2 start1))))
195                      (- (the fixnum index) ,offset1))                      (- (the fixnum index) ,offset1))
196                     (t nil))                     #-unicode
197                       (t nil)
198                       #+unicode
199                       (t
200                        ;; Compare in code point order.  See
201                        ;; http://icu-project.org/docs/papers/utf16_code_point_order.html
202                        (flet ((fixup (code)
203                                 (if (>= code #xe000)
204                                     (- code #x800)
205                                     (+ code #x2000))))
206                          (declare (inline fixup))
207                          (let* ((c1 (char-code (schar string1 index)))
208                                 (c2 (char-code (schar string2
209                                                       (+ (the fixnum index)
210                                                          (- start2 start1))))))
211                            (cond ((and (>= c1 #xd800)
212                                        (>= c2 #xd800))
213                                   (let ((fix-c1 (fixup c1))
214                                         (fix-c2 (fixup c2)))
215                                     (if (,(if lessp '< '>) fix-c1 fix-c2)
216                                         (- (the fixnum index) ,offset1)
217                                         nil)))
218                                  (t
219                                   (if (,(if lessp '< '>) c1 c2)
220                                       (- (the fixnum index) ,offset1)
221                                       nil)))))))
222               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
223  ) ; eval-when  ) ; eval-when
224    
# Line 360  Line 430 
430    
431  (defun make-string (count &key element-type ((:initial-element fill-char)))  (defun make-string (count &key element-type ((:initial-element fill-char)))
432    "Given a character count and an optional fill character, makes and returns    "Given a character count and an optional fill character, makes and returns
433     a new string Count long filled with the fill character."    a new string Count long filled with the fill character."
434    (declare (type fixnum count))    (declare (type fixnum count))
435    (assert (subtypep element-type 'character))    (assert (subtypep element-type 'character))
436    (if fill-char    (if fill-char
# Line 391  Line 461 
461               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
462              ((= index (the fixnum end)))              ((= index (the fixnum end)))
463            (declare (fixnum index new-index))            (declare (fixnum index new-index))
464            (setf (schar newstring new-index)            (multiple-value-bind (code wide) (codepoint string index)
465                  (char-upcase (schar string index))))              (when wide (incf index))
466                ;; Handle ASCII specially because this is called early in
467                ;; initialization, before unidata is available.
468                (cond ((< 96 code 123) (decf code 32))
469                      ((> code 127) (setq code (unicode-upper code))))
470                ;;@@ WARNING: this may, in theory, need to extend newstring
471                ;;  but that never actually occurs as of Unicode 5.1.0,
472                ;;  so I'm just going to ignore it for now...
473                (multiple-value-bind (hi lo) (surrogates code)
474                  (setf (schar newstring new-index) hi)
475                  (when lo
476                    (setf (schar newstring (incf new-index)) 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 420  Line 502 
502               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
503              ((= index (the fixnum end)))              ((= index (the fixnum end)))
504            (declare (fixnum index new-index))            (declare (fixnum index new-index))
505            (setf (schar newstring new-index)            (multiple-value-bind (code wide) (codepoint string index)
506                  (char-downcase (schar string index))))              (when wide (incf index))
507                ;; Handle ASCII specially because this is called early in
508                ;; initialization, before unidata is available.
509                (cond ((< 64 code 91) (incf code 32))
510                      ((> code 127) (setq code (unicode-lower code))))
511                ;;@@ WARNING: this may, in theory, need to extend newstring
512                ;;  but that never actually occurs as of Unicode 5.1.0,
513                ;;  so I'm just going to ignore it for now...
514                (multiple-value-bind (hi lo) (surrogates code)
515                  (setf (schar newstring new-index) hi)
516                  (when lo
517                    (setf (schar newstring (incf new-index)) lo)))))
518            ;;@@ WARNING: see above
519          (do ((index end (1+ index))          (do ((index end (1+ index))
520               (new-index (- (the fixnum end) offset) (1+ new-index)))               (new-index (- (the fixnum end) offset) (1+ new-index)))
521              ((= index offset-slen))              ((= index offset-slen))
# Line 459  Line 553 
553                   (setq newword t))                   (setq newword t))
554                  (newword                  (newword
555                   ;;char is first case-modifiable after non-case-modifiable                   ;;char is first case-modifiable after non-case-modifiable
556                   (setq char (char-upcase char))                   (setq char (char-titlecase char))
557                   (setq newword ()))                   (setq newword ()))
558                  ;;char is case-modifiable, but not first                  ;;char is case-modifiable, but not first
559                  (t (setq char (char-downcase char))))                  (t (setq char (char-downcase char))))
# Line 480  Line 574 
574        (do ((index start (1+ index)))        (do ((index start (1+ index)))
575            ((= index (the fixnum end)))            ((= index (the fixnum end)))
576          (declare (fixnum index))          (declare (fixnum index))
577          (setf (schar string index) (char-upcase (schar string index)))))          (multiple-value-bind (code wide) (codepoint string index)
578              (declare (ignore wide))
579              ;; Handle ASCII specially because this is called early in
580              ;; initialization, before unidata is available.
581              (cond ((< 96 code 123) (decf code 32))
582                    ((> code 127) (setq code (unicode-upper code))))
583              ;;@@ WARNING: this may, in theory, need to extend string
584              ;;      (which, obviously, we can't do here.  Unless
585              ;;       STRING is adjustable, maybe)
586              ;;  but that never actually occurs as of Unicode 5.1.0,
587              ;;  so I'm just going to ignore it for now...
588              (multiple-value-bind (hi lo) (surrogates code)
589                (setf (schar string index) hi)
590                (when lo
591                  (setf (schar string (incf index)) lo))))))
592      save-header))      save-header))
593    
594  (defun nstring-downcase (string &key (start 0) end)  (defun nstring-downcase (string &key (start 0) end)
# Line 492  Line 600 
600        (do ((index start (1+ index)))        (do ((index start (1+ index)))
601            ((= index (the fixnum end)))            ((= index (the fixnum end)))
602          (declare (fixnum index))          (declare (fixnum index))
603          (setf (schar string index) (char-downcase (schar string index)))))          (multiple-value-bind (code wide) (codepoint string index)
604              (declare (ignore wide))
605              (cond ((< 64 code 91) (incf code 32))
606                    ((> code 127) (setq code (unicode-lower code))))
607              ;;@@ WARNING: this may, in theory, need to extend string
608              ;;      (which, obviously, we can't do here.  Unless
609              ;;       STRING is adjustable, maybe)
610              ;;  but that never actually occurs as of Unicode 5.1.0,
611              ;;  so I'm just going to ignore it for now...
612              (multiple-value-bind (hi lo) (surrogates code)
613                (setf (schar string index) hi)
614                (when lo
615                  (setf (schar string (incf index)) lo))))))
616      save-header))      save-header))
617    
618  (defun nstring-capitalize (string &key (start 0) end)  (defun nstring-capitalize (string &key (start 0) end)
# Line 514  Line 634 
634                 (setq newword t))                 (setq newword t))
635                (newword                (newword
636                 ;;char is first case-modifiable after non-case-modifiable                 ;;char is first case-modifiable after non-case-modifiable
637                 (setf (schar string index) (char-upcase char))                 (setf (schar string index) (char-titlecase char))
638                 (setq newword ()))                 (setq newword ()))
639                (t                (t
640                 (setf (schar string index) (char-downcase char))))))                 (setf (schar string index) (char-downcase char))))))
# Line 557  Line 677 
677                             (1+ index))                             (1+ index))
678                          (declare (fixnum index)))))                          (declare (fixnum index)))))
679        (subseq (the simple-string string) left-end right-end))))        (subseq (the simple-string string) left-end right-end))))
680    
681    (declaim (inline %glyph-f %glyph-b))
682    (defun %glyph-f (string index)
683      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
684               (type simple-string string) (type kernel:index index))
685      (let* ((prev 0)
686             (l (length string))
687             (c (codepoint string index l))
688             (n (+ index (if (> c #xFFFF) 2 1))))
689        (declare (type (integer 0 #x10FFFF) c) (type kernel:index l n))
690        (loop while (< n l) do
691          (let* ((c (codepoint string n l))
692                 (d (the (unsigned-byte 8) (unicode-combining-class c))))
693            (when (or (zerop d) (< d prev))
694              (return))
695            (setq prev d)
696            (incf n (if (> c #xFFFF) 2 1))))
697        n))
698    
699    (defun %glyph-b (string index)
700      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
701               (type simple-string string) (type kernel:index index))
702      (let* ((prev 255)
703             (n (1- index)))
704        (declare (type kernel:index n))
705        (loop until (< n 0) do
706          (let* ((c (codepoint string n 0))
707                 (d (the (unsigned-byte 8) (unicode-combining-class c))))
708            (cond ((zerop d) (return))
709                  ((> d prev) (incf n (if (> c #xFFFF) 2 1)) (return)))
710            (setq prev d)
711            (decf n (if (> c #xFFFF) 2 1))))
712        n))
713    
714    (defun glyph (string index &key (from-end nil))
715      "GLYPH returns the glyph at the indexed position in a string, and the
716      position of the next glyph (or NIL) as a second value.  A glyph is
717      a substring consisting of the character at INDEX followed by all
718      subsequent combining characters."
719      (declare (type simple-string string) (type kernel:index index))
720      #-unicode
721      (char string index)
722      #+unicode
723      (with-array-data ((string string) (start) (end))
724        (declare (ignore start end))
725        (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
726          (if from-end
727              (values (subseq string n index) (and (> n 0) n))
728              (values (subseq string index n) (and (< n (length string)) n))))))
729    
730    (defun sglyph (string index &key (from-end nil))
731      "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
732      except that the string must be a simple-string"
733      (declare (type simple-string string) (type kernel:index index))
734      #-unicode
735      (schar string index)
736      #+unicode
737      (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
738        (if from-end
739            (values (subseq string n index) (and (> n 0) n))
740            (values (subseq string index n) (and (< n (length string)) n)))))
741    
742    (defun decompose (string &optional (compatibility t))
743      (declare (type string string))
744      (let ((result (make-string (cond ((< (length string) 40)
745                                        (* 5 (length string)))
746                                       ((< (length string) 4096)
747                                        (* 2 (length string)))
748                                       (t (round (length string) 5/6)))))
749            (fillptr 0))
750        (declare (type kernel:index fillptr))
751        (labels ((rec (string)
752                   (declare (type simple-string string))
753                   (do ((i 0 (1+ i)))
754                       ((= i (length string)))
755                     (declare (type kernel:index i))
756                     (multiple-value-bind (code wide) (codepoint string i)
757                       (when wide (incf i))
758                       (let ((decomp (unicode-decomp code compatibility)))
759                         (if decomp (rec decomp) (out code))))))
760                 (out (code)
761                   (multiple-value-bind (hi lo) (surrogates code)
762                     (outch hi)
763                     (when lo
764                       (outch lo))
765                     (let ((cc (unicode-combining-class code)))
766                       (unless (zerop cc)
767                         (order lo cc (- fillptr (if lo 2 1)))))))
768                 (outch (char)
769                   (when (= fillptr (length result))
770                     (let ((tmp (make-string (round (length result) 5/6))))
771                       (replace tmp result)
772                       (setq result tmp)))
773                   (setf (schar result fillptr) char)
774                   (incf fillptr))
775                 (order (wide1 cc last)
776                   (loop until (minusp last) do
777                     (multiple-value-bind (code2 wide2) (codepoint result last)
778                       (let ((cc2 (unicode-combining-class code2)))
779                         (cond ((zerop cc2) (return))
780                               ((> cc2 cc)
781                                (case (+ (if wide2 2 0) (if wide1 1 0))
782                                  (0 (rotatef (schar result last)
783                                              (schar result (1+ last))))
784                                  (1 (rotatef (schar result last)
785                                              (schar result (+ last 1))
786                                              (schar result (+ last 2))))
787                                  (2 (rotatef (schar result last)
788                                              (schar result (1- last))
789                                              (schar result (1+ last))))
790                                  (3 (rotatef (schar result last)
791                                              (schar result (+ last 2)))
792                                     (rotatef (schar result (1- last))
793                                              (schar result (1+ last)))))
794                                (decf last (if wide2 2 1)))
795                               (t (return))))))))
796          (with-array-data ((string string) (start) (end))
797            (declare (ignore start end))
798            (rec string))
799          (shrink-vector result fillptr))))
800    
801    (defun string-to-nfd (string)
802      "Convert String to Unicode Normalization Form D (NFD) using the
803      canonical decomposition.  The NFD string is returned"
804      (decompose string nil))
805    
806    (defun string-to-nfkd (string)
807      "Convert String to Unicode Normalization Form KD (NFKD) uisng the
808      compatible decomposition form.  The NFKD string is returned."
809      (decompose string t))
810    
811    #+unicode
812    (defun string-to-nfc (string)
813      ;;@@ Implement me
814      ;; must return a simple-string for the package machinery
815      (if (simple-string-p string) string (coerce string 'simple-string)))
816    
817    #-unicode  ;; Needed by package.lisp
818    (defun string-to-nfc (string)
819      (if (simple-string-p string) string (coerce string 'simple-string)))
820    
821    (defun string-to-nfkc (string)
822      ;;@@ Implement me
823      (if (simple-string-p string) string (coerce string 'simple-string)))

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

  ViewVC Help
Powered by ViewVC 1.1.5