/[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.8 by rtoy, Thu Apr 23 15:10:08 2009 UTC revision 1.12.30.9 by rtoy, Sat May 2 11:54:37 2009 UTC
# Line 761  Line 761 
761          (values (subseq string n index) (and (> n 0) n))          (values (subseq string n index) (and (> n 0) n))
762          (values (subseq string index n) (and (< n (length string)) n)))))          (values (subseq string index n) (and (< n (length string)) n)))))
763    
764    (defun decompose (string &optional (compatibility t))
765      (declare (type string string))
766      (let ((result (make-string (cond ((< (length string) 40)
767                                        (* 5 (length string)))
768                                       ((< (length string) 4096)
769                                        (* 2 (length string)))
770                                       (t (round (length string) 5/6)))))
771            (fillptr 0)
772            (start 0))
773        (declare (type kernel:index fillptr start))
774        (labels ((rec (string)
775                   (declare (type simple-string string))
776                   (do ((i 0 (1+ i)))
777                       ((= i (length string)))
778                     (declare (type kernel:index i))
779                     (multiple-value-bind (code wide) (codepoint string i)
780                       (when wide (incf i))
781                       (let ((decomp (unicode-decomp code compatibility)))
782                         (if decomp (rec decomp) (out code))))))
783                 (out (code)
784                   (when (zerop (unicode-combining-class code))
785                     (order result start fillptr)
786                     (setq start fillptr))
787                   (multiple-value-bind (hi lo) (surrogates code)
788                     (outch hi)
789                     (when lo
790                       (outch lo))))
791                 (outch (char)
792                   (when (= fillptr (length result))
793                     (let ((tmp (make-string (round (length result) 5/6))))
794                       (replace tmp result)
795                       (setq result tmp)))
796                   (setf (schar result fillptr) char)
797                   (incf fillptr))
798                 (order (string start end)
799                   (when (> (- end start) (if (zerop start) 1 2))
800                     (loop for done = t do
801                          (do ((x start (1+ x)))
802                              ((>= x (1- end)))
803                            (declare (type kernel:index x))
804                            (multiple-value-bind (code1 wide1)
805                                (codepoint string x)
806                              (when (and wide1 (= (+ x 2) end)) (return))
807                              (multiple-value-bind (code2 wide2)
808                                  (codepoint string (+ x (if wide1 2 1)))
809                                (when (> (unicode-combining-class code1)
810                                         (unicode-combining-class code2))
811                                  (rotatef wide1 wide2)
812                                  (case (+ (if wide1 2 0) (if wide2 1 0))
813                                    (0 (rotatef (schar string x)
814                                                (schar string (+ x 1))))
815                                    (1 (rotatef (schar string x)
816                                                (schar string (+ x 2))
817                                                (schar string (+ x 1))))
818                                    (2 (rotatef (schar string x)
819                                                (schar string (+ x 1))
820                                                (schar string (+ x 2))))
821                                    (3 (rotatef (schar string x)
822                                                (schar string (+ x 2)))
823                                       (rotatef (schar string (+ x 1))
824                                                (schar string (+ x 3)))))
825                                  (setq done nil))
826                                (when wide1 (incf x)))))
827                          until done))))
828          (with-array-data ((string string) (start) (end))
829            (declare (ignore start end))
830            (rec string))
831          (order result start fillptr)
832          (shrink-vector result fillptr))))
833    
834  (defun string-to-nfd (string)  (defun string-to-nfd (string)
835    ;;@@ Implement me    (decompose string nil))
   string)  
836    
837  (defun string-to-nfkd (string)  (defun string-to-nfkd (string)
838    ;;@@ Implement me    (decompose string t))
   string)  
839    
840  (defun string-to-nfc (string)  (defun string-to-nfc (string)
841    ;;@@ Implement me    ;;@@ Implement me

Legend:
Removed from v.1.12.30.8  
changed lines
  Added in v.1.12.30.9

  ViewVC Help
Powered by ViewVC 1.1.5