/[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.16 by rtoy, Tue May 19 20:24:19 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    (defun utf16-string-p (string)
74      "Check if String is a valid UTF-16 string.  If the string is valid,
75      T is returned.  If the string is not valid, NIL is returned, and the
76      second value is the index into the string of the invalid character."
77      (do ((len (length string))
78           (index 0 (1+ index)))
79          ((>= index len)
80           t)
81        (multiple-value-bind (codepoint wide)
82            (codepoint string index)
83          ;; We stepping through the string in order.  If there are any
84          ;; surrogates, we must reach the lead surrogate first, which
85          ;; means WIDE is +1.  If we get any surrogate codepoint that
86          ;; is in the surrogate range, we have an invalid string.
87          (when (or (eq wide -1)
88                    (<= #xD800 codepoint #xDFFF))
89            (return-from utf16-string-p (values nil index)))
90          (when wide (incf index)))))
91    
92  (defun string (X)  (defun string (X)
93    "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
94     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
95     string containing that character is returned.  If X cannot be coerced    string containing that character is returned.  If X cannot be coerced
96     into a string, an error occurs."    into a string, an error occurs."
97    (cond ((stringp x) x)    (cond ((stringp x) x)
98          ((symbolp x) (symbol-name x))          ((symbolp x) (symbol-name x))
99          ((characterp x)          ((characterp x)
# Line 106  Line 168 
168    
169  (defun schar (string index)  (defun schar (string index)
170    "SCHAR returns the character object at an indexed position in a string    "SCHAR returns the character object at an indexed position in a string
171     just as CHAR does, except the string must be a simple-string."    just as CHAR does, except the string must be a simple-string."
172    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
173    (schar string index))    (schar string index))
174    
# Line 143  Line 205 
205                         (the fixnum end2))                         (the fixnum end2))
206                      ,(if lessp                      ,(if lessp
207                           `nil                           `nil
208                         `(- (the fixnum index) ,offset1)))                           `(- (the fixnum index) ,offset1)))
209                       #-unicode
210                     ((,(if lessp 'char< 'char>)                     ((,(if lessp 'char< 'char>)
211                       (schar string1 index)                       (schar string1 index)
212                       (schar string2 (+ (the fixnum index) (- start2 start1))))                       (schar string2 (+ (the fixnum index) (- start2 start1))))
213                      (- (the fixnum index) ,offset1))                      (- (the fixnum index) ,offset1))
214                     (t nil))                     #-unicode
215                       (t nil)
216                       #+unicode
217                       (t
218                        ;; Compare in code point order.  See
219                        ;; http://icu-project.org/docs/papers/utf16_code_point_order.html
220                        (flet ((fixup (code)
221                                 (if (>= code #xe000)
222                                     (- code #x800)
223                                     (+ code #x2000))))
224                          (declare (inline fixup))
225                          (let* ((c1 (char-code (schar string1 index)))
226                                 (c2 (char-code (schar string2
227                                                       (+ (the fixnum index)
228                                                          (- start2 start1))))))
229                            (cond ((and (>= c1 #xd800)
230                                        (>= c2 #xd800))
231                                   (let ((fix-c1 (fixup c1))
232                                         (fix-c2 (fixup c2)))
233                                     (if (,(if lessp '< '>) fix-c1 fix-c2)
234                                         (- (the fixnum index) ,offset1)
235                                         nil)))
236                                  (t
237                                   (if (,(if lessp '< '>) c1 c2)
238                                       (- (the fixnum index) ,offset1)
239                                       nil)))))))
240               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))               ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
241  ) ; eval-when  ) ; eval-when
242    
# Line 281  Line 369 
369    (if lessp    (if lessp
370        (if equalp        (if equalp
371            ;; STRING-NOT-GREATERP            ;; STRING-NOT-GREATERP
372            (values '<= `(not (char-greaterp char1 char2)))            (values '<=
373                      #-unicode `(not (char-greaterp char1 char2))
374                      #+unicode `(<= char1 char2))
375            ;; STRING-LESSP            ;; STRING-LESSP
376            (values '< `(char-lessp char1 char2)))            (values '<
377                      #-unicode `(char-lessp char1 char2)
378                      #+unicode `(< char1 char2)))
379        (if equalp        (if equalp
380            ;; STRING-NOT-LESSP            ;; STRING-NOT-LESSP
381            (values '>= `(not (char-lessp char1 char2)))            (values '>=
382                      #-unicode `(not (char-lessp char1 char2))
383                      #+unicode `(>= char1 char2))
384            ;; STRING-GREATERP            ;; STRING-GREATERP
385            (values '> `(char-greaterp char1 char2)))))            (values '>
386                      #-unicode `(char-greaterp char1 char2)
387                      #+unicode `(> char1 char2)))))
388    
389    #-unicode
390  (defmacro string-less-greater-equal (lessp equalp)  (defmacro string-less-greater-equal (lessp equalp)
391    (multiple-value-bind (length-test character-test)    (multiple-value-bind (length-test character-test)
392                         (string-less-greater-equal-tests lessp equalp)                         (string-less-greater-equal-tests lessp equalp)
# Line 314  Line 411 
411                     (return (- index1 offset1))                     (return (- index1 offset1))
412                     (return ()))))))))                     (return ()))))))))
413    
414    #+unicode
415    (defmacro equal-char-codepoint (codepoint)
416      `(let ((ch ,codepoint))
417         (if (< 96 ch 123)
418             (- ch 32)
419             #-(and unicode (not unicode-bootstrap))
420             ch
421             #+(and unicode (not unicode-bootstrap))
422             (if (> ch 127) (unicode-upper ch) ch))))
423    
424    #+unicode
425    (defmacro string-less-greater-equal (lessp equalp)
426      (multiple-value-bind (length-test character-test)
427          (string-less-greater-equal-tests lessp equalp)
428        `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
429           (let ((slen1 (- (the fixnum end1) start1))
430                 (slen2 (- (the fixnum end2) start2)))
431             (declare (fixnum slen1 slen2))
432             (if (or (minusp slen1) (minusp slen2))
433                 ;;prevent endless looping later.
434                 (error "Improper bounds for string comparison."))
435             (do ((index1 start1 (1+ index1))
436                  (index2 start2 (1+ index2)))
437                 ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
438                  (if (,length-test slen1 slen2) (- index1 offset1)))
439               (declare (fixnum index1 index2))
440               (multiple-value-bind (char1 wide1)
441                   (codepoint string1 index1)
442                 (multiple-value-bind (char2 wide2)
443                     (codepoint string2 index2)
444                   (if (= (equal-char-codepoint char1)
445                          (equal-char-codepoint char2))
446                       (progn
447                         (when wide1 (incf index1))
448                         (when wide2 (incf index2)))
449                       (if ,character-test
450                           (return (- index1 offset1))
451                           (return ()))))))))))
452    
453  ) ; eval-when  ) ; eval-when
454    
455  (defun string-lessp* (string1 string2 start1 end1 start2 end2)  (defun string-lessp* (string1 string2 start1 end1 start2 end2)
# Line 360  Line 496 
496    
497  (defun make-string (count &key element-type ((:initial-element fill-char)))  (defun make-string (count &key element-type ((:initial-element fill-char)))
498    "Given a character count and an optional fill character, makes and returns    "Given a character count and an optional fill character, makes and returns
499     a new string Count long filled with the fill character."    a new string Count long filled with the fill character."
500    (declare (type fixnum count))    (declare (type fixnum count))
501    (assert (subtypep element-type 'character))    (assert (subtypep element-type 'character))
502    (if fill-char    (if fill-char
# Line 391  Line 527 
527               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
528              ((= index (the fixnum end)))              ((= index (the fixnum end)))
529            (declare (fixnum index new-index))            (declare (fixnum index new-index))
530            (setf (schar newstring new-index)            (multiple-value-bind (code wide) (codepoint string index)
531                  (char-upcase (schar string index))))              (when wide (incf index))
532                ;; Handle ASCII specially because this is called early in
533                ;; initialization, before unidata is available.
534                (cond ((< 96 code 123) (decf code 32))
535                      ((> code 127) (setq code (unicode-upper code))))
536                ;;@@ WARNING: this may, in theory, need to extend newstring
537                ;;  but that never actually occurs as of Unicode 5.1.0,
538                ;;  so I'm just going to ignore it for now...
539                (multiple-value-bind (hi lo) (surrogates code)
540                  (setf (schar newstring new-index) hi)
541                  (when lo
542                    (setf (schar newstring (incf new-index)) lo)))))
543            ;;@@ WARNING: see above
544          (do ((index end (1+ index))          (do ((index end (1+ index))
545               (new-index (- (the fixnum end) offset) (1+ new-index)))               (new-index (- (the fixnum end) offset) (1+ new-index)))
546              ((= index offset-slen))              ((= index offset-slen))
# Line 420  Line 568 
568               (new-index (- start offset) (1+ new-index)))               (new-index (- start offset) (1+ new-index)))
569              ((= index (the fixnum end)))              ((= index (the fixnum end)))
570            (declare (fixnum index new-index))            (declare (fixnum index new-index))
571            (setf (schar newstring new-index)            (multiple-value-bind (code wide) (codepoint string index)
572                  (char-downcase (schar string index))))              (when wide (incf index))
573                ;; Handle ASCII specially because this is called early in
574                ;; initialization, before unidata is available.
575                (cond ((< 64 code 91) (incf code 32))
576                      ((> code 127) (setq code (unicode-lower code))))
577                ;;@@ WARNING: this may, in theory, need to extend newstring
578                ;;  but that never actually occurs as of Unicode 5.1.0,
579                ;;  so I'm just going to ignore it for now...
580                (multiple-value-bind (hi lo) (surrogates code)
581                  (setf (schar newstring new-index) hi)
582                  (when lo
583                    (setf (schar newstring (incf new-index)) lo)))))
584            ;;@@ WARNING: see above
585          (do ((index end (1+ index))          (do ((index end (1+ index))
586               (new-index (- (the fixnum end) offset) (1+ new-index)))               (new-index (- (the fixnum end) offset) (1+ new-index)))
587              ((= index offset-slen))              ((= index offset-slen))
# Line 459  Line 619 
619                   (setq newword t))                   (setq newword t))
620                  (newword                  (newword
621                   ;;char is first case-modifiable after non-case-modifiable                   ;;char is first case-modifiable after non-case-modifiable
622                   (setq char (char-upcase char))                   (setq char (char-titlecase char))
623                   (setq newword ()))                   (setq newword ()))
624                  ;;char is case-modifiable, but not first                  ;;char is case-modifiable, but not first
625                  (t (setq char (char-downcase char))))                  (t (setq char (char-downcase char))))
# Line 480  Line 640 
640        (do ((index start (1+ index)))        (do ((index start (1+ index)))
641            ((= index (the fixnum end)))            ((= index (the fixnum end)))
642          (declare (fixnum index))          (declare (fixnum index))
643          (setf (schar string index) (char-upcase (schar string index)))))          (multiple-value-bind (code wide) (codepoint string index)
644              (declare (ignore wide))
645              ;; Handle ASCII specially because this is called early in
646              ;; initialization, before unidata is available.
647              (cond ((< 96 code 123) (decf code 32))
648                    ((> code 127) (setq code (unicode-upper code))))
649              ;;@@ WARNING: this may, in theory, need to extend string
650              ;;      (which, obviously, we can't do here.  Unless
651              ;;       STRING is adjustable, maybe)
652              ;;  but that never actually occurs as of Unicode 5.1.0,
653              ;;  so I'm just going to ignore it for now...
654              (multiple-value-bind (hi lo) (surrogates code)
655                (setf (schar string index) hi)
656                (when lo
657                  (setf (schar string (incf index)) lo))))))
658      save-header))      save-header))
659    
660  (defun nstring-downcase (string &key (start 0) end)  (defun nstring-downcase (string &key (start 0) end)
# Line 492  Line 666 
666        (do ((index start (1+ index)))        (do ((index start (1+ index)))
667            ((= index (the fixnum end)))            ((= index (the fixnum end)))
668          (declare (fixnum index))          (declare (fixnum index))
669          (setf (schar string index) (char-downcase (schar string index)))))          (multiple-value-bind (code wide) (codepoint string index)
670              (declare (ignore wide))
671              (cond ((< 64 code 91) (incf code 32))
672                    ((> code 127) (setq code (unicode-lower code))))
673              ;;@@ WARNING: this may, in theory, need to extend string
674              ;;      (which, obviously, we can't do here.  Unless
675              ;;       STRING is adjustable, maybe)
676              ;;  but that never actually occurs as of Unicode 5.1.0,
677              ;;  so I'm just going to ignore it for now...
678              (multiple-value-bind (hi lo) (surrogates code)
679                (setf (schar string index) hi)
680                (when lo
681                  (setf (schar string (incf index)) lo))))))
682      save-header))      save-header))
683    
684  (defun nstring-capitalize (string &key (start 0) end)  (defun nstring-capitalize (string &key (start 0) end)
# Line 514  Line 700 
700                 (setq newword t))                 (setq newword t))
701                (newword                (newword
702                 ;;char is first case-modifiable after non-case-modifiable                 ;;char is first case-modifiable after non-case-modifiable
703                 (setf (schar string index) (char-upcase char))                 (setf (schar string index) (char-titlecase char))
704                 (setq newword ()))                 (setq newword ()))
705                (t                (t
706                 (setf (schar string index) (char-downcase char))))))                 (setf (schar string index) (char-downcase char))))))
# Line 557  Line 743 
743                             (1+ index))                             (1+ index))
744                          (declare (fixnum index)))))                          (declare (fixnum index)))))
745        (subseq (the simple-string string) left-end right-end))))        (subseq (the simple-string string) left-end right-end))))
746    
747    (declaim (inline %glyph-f %glyph-b))
748    (defun %glyph-f (string index)
749      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
750               (type simple-string string) (type kernel:index index))
751      (let* ((prev 0)
752             (l (length string))
753             (c (codepoint string index l))
754             (n (+ index (if (> c #xFFFF) 2 1))))
755        (declare (type (integer 0 #x10FFFF) c) (type kernel:index l n))
756        (loop while (< n l) do
757          (let* ((c (codepoint string n l))
758                 (d (the (unsigned-byte 8) (unicode-combining-class c))))
759            (when (or (zerop d) (< d prev))
760              (return))
761            (setq prev d)
762            (incf n (if (> c #xFFFF) 2 1))))
763        n))
764    
765    (defun %glyph-b (string index)
766      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
767               (type simple-string string) (type kernel:index index))
768      (let* ((prev 255)
769             (n (1- index)))
770        (declare (type kernel:index n))
771        (loop until (< n 0) do
772          (let* ((c (codepoint string n 0))
773                 (d (the (unsigned-byte 8) (unicode-combining-class c))))
774            (cond ((zerop d) (return))
775                  ((> d prev) (incf n (if (> c #xFFFF) 2 1)) (return)))
776            (setq prev d)
777            (decf n (if (> c #xFFFF) 2 1))))
778        n))
779    
780    (defun glyph (string index &key (from-end nil))
781      "GLYPH returns the glyph at the indexed position in a string, and the
782      position of the next glyph (or NIL) as a second value.  A glyph is
783      a substring consisting of the character at INDEX followed by all
784      subsequent combining characters."
785      (declare (type simple-string string) (type kernel:index index))
786      #-unicode
787      (char string index)
788      #+unicode
789      (with-array-data ((string string) (start) (end))
790        (declare (ignore start end))
791        (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
792          (if from-end
793              (values (subseq string n index) (and (> n 0) n))
794              (values (subseq string index n) (and (< n (length string)) n))))))
795    
796    (defun sglyph (string index &key (from-end nil))
797      "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
798      except that the string must be a simple-string"
799      (declare (type simple-string string) (type kernel:index index))
800      #-unicode
801      (schar string index)
802      #+unicode
803      (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
804        (if from-end
805            (values (subseq string n index) (and (> n 0) n))
806            (values (subseq string index n) (and (< n (length string)) n)))))
807    
808    (defun decompose (string &optional (compatibility t))
809      (declare (type string string))
810      (let ((result (make-string (cond ((< (length string) 40)
811                                        (* 5 (length string)))
812                                       ((< (length string) 4096)
813                                        (* 2 (length string)))
814                                       (t (round (length string) 5/6)))))
815            (fillptr 0))
816        (declare (type kernel:index fillptr))
817        (labels ((rec (string)
818                   (declare (type simple-string string))
819                   (do ((i 0 (1+ i)))
820                       ((= i (length string)))
821                     (declare (type kernel:index i))
822                     (multiple-value-bind (code wide) (codepoint string i)
823                       (when wide (incf i))
824                       (let ((decomp (unicode-decomp code compatibility)))
825                         (if decomp (rec decomp) (out code))))))
826                 (out (code)
827                   (multiple-value-bind (hi lo) (surrogates code)
828                     (outch hi)
829                     (when lo
830                       (outch lo))
831                     (let ((cc (unicode-combining-class code)))
832                       (unless (zerop cc)
833                         (order lo cc (- fillptr (if lo 2 1)))))))
834                 (outch (char)
835                   (when (= fillptr (length result))
836                     (let ((tmp (make-string (round (length result) 5/6))))
837                       (replace tmp result)
838                       (setq result tmp)))
839                   (setf (schar result fillptr) char)
840                   (incf fillptr))
841                 (order (wide1 cc last)
842                   (loop until (minusp last) do
843                     (multiple-value-bind (code2 wide2) (codepoint result last)
844                       (let ((cc2 (unicode-combining-class code2)))
845                         (cond ((zerop cc2) (return))
846                               ((> cc2 cc)
847                                (case (+ (if wide2 2 0) (if wide1 1 0))
848                                  (0 (rotatef (schar result last)
849                                              (schar result (1+ last))))
850                                  (1 (rotatef (schar result last)
851                                              (schar result (+ last 1))
852                                              (schar result (+ last 2))))
853                                  (2 (rotatef (schar result last)
854                                              (schar result (1- last))
855                                              (schar result (1+ last))))
856                                  (3 (rotatef (schar result last)
857                                              (schar result (+ last 2)))
858                                     (rotatef (schar result (1- last))
859                                              (schar result (1+ last)))))
860                                (decf last (if wide2 2 1)))
861                               (t (return))))))))
862          (with-array-data ((string string) (start) (end))
863            (declare (ignore start end))
864            (rec string))
865          (shrink-vector result fillptr))))
866    
867    (defun string-to-nfd (string)
868      "Convert String to Unicode Normalization Form D (NFD) using the
869      canonical decomposition.  The NFD string is returned"
870      (decompose string nil))
871    
872    (defun string-to-nfkd (string)
873      "Convert String to Unicode Normalization Form KD (NFKD) uisng the
874      compatible decomposition form.  The NFKD string is returned."
875      (decompose string t))
876    
877    #+unicode
878    (defun string-to-nfc (string)
879      ;;@@ Implement me
880      ;; must return a simple-string for the package machinery
881      (if (simple-string-p string) string (coerce string 'simple-string)))
882    
883    #-unicode  ;; Needed by package.lisp
884    (defun string-to-nfc (string)
885      (if (simple-string-p string) string (coerce string 'simple-string)))
886    
887    (defun string-to-nfkc (string)
888      ;;@@ Implement me
889      (if (simple-string-p string) string (coerce string 'simple-string)))

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

  ViewVC Help
Powered by ViewVC 1.1.5