/[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.30.3 by rtoy, Sat Apr 18 12:27:05 2009 UTC revision 1.12.30.4 by rtoy, Mon Apr 20 14:26:48 2009 UTC
# Line 20  Line 20 
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 415  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 444  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 504  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 newstring new-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 new-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 newstring (incf new-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 516  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 newstring new-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 newstring new-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 newstring (incf new-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 582  Line 643 
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  (defun glyph (string index)  (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    "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    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    a substring consisting of the character at INDEX followed by all
707     subsequent combining characters."    subsequent combining characters."
708    (declare (type simple-string string) (type kernel:index index))    (declare (type simple-string string) (type kernel:index index))
709    #-unicode    #-unicode
710    (char string index)    (char string index)
711    #+unicode    #+unicode
712    (with-array-data ((string string) (start) (end))    (with-array-data ((string string) (start) (end))
713      (declare (ignore start end))      (declare (ignore start end))
714      (sglyph string index)))      (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)  (defun sglyph (string index &key (from-end nil))
720    "SGLYPH returns the glyph at the indexed position, the same as GLYPH,    "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
721     except that the string must be a simple-string."    except that the string must be a simple-string"
722    (declare (type simple-string string) (type kernel:index index))    (declare (type simple-string string) (type kernel:index index))
723    #-unicode    #-unicode
724    (schar string index)    (schar string index)
725    #+unicode    #+unicode
726    (flet ((xchar (string index)    (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
727             (let ((c (char-code (char string index))))      (if from-end
728               (cond ((<= #xD800 c #xDBFF)          (values (subseq string n index) (and (> n 0) n))
729                      (let ((c2 (char-code (char string (1+ index)))))          (values (subseq string index n) (and (< n (length string)) n)))))
730                        (if (<= #xDC00 c2 #xDFFF)  
731                            (+ (ash (- c #xD800) 10) c2 #x2400)  (defun string-to-nfd (string)
732                            (error "Naked high surrogate in string."))))    ;;@@ Implement me
733                     ((<= #xDC00 c #xDFFF)    string)
734                      (error "Naked low surrogate in string."))  
735                     (t c)))))  (defun string-to-nfkd (string)
736      (let* ((l (length string))    ;;@@ Implement me
737             (c (xchar string index))    string)
738             (n (+ index (if (> c #xFFFF) 2 1))))  
739        (declare (type (integer 0 #x10FFFF) c) (type kernel:index n))  (defun string-to-nfc (string)
740        (loop while (< n l) do    ;;@@ Implement me
741          (let ((c (xchar string n)))    string)
742            (when (zerop (lisp::unicode-combining-class c)) (return))  
743            (incf n (if (> c #xFFFF) 2 1))))  (defun string-to-nfkc (string)
744        (values (subseq string index n) (and (< n l) n)))))    ;;@@ Implement me
745      string)

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

  ViewVC Help
Powered by ViewVC 1.1.5