/[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.2 by rtoy, Wed Apr 15 14:41:55 2009 UTC revision 1.12.30.3 by rtoy, Sat Apr 18 12:27:05 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
# Line 581  Line 581 
581                             (1+ index))                             (1+ index))
582                          (declare (fixnum index)))))                          (declare (fixnum index)))))
583        (subseq (the simple-string string) left-end right-end))))        (subseq (the simple-string string) left-end right-end))))
584    
585    (defun glyph (string index)
586      "GLYPH returns the glyph at the indexed position in a string, and the
587       position of the next glyph (or NIL) as a second value.  A glyph is
588       a substring consisting of the character at INDEX followed by all
589       subsequent combining characters."
590      (declare (type simple-string string) (type kernel:index index))
591      #-unicode
592      (char string index)
593      #+unicode
594      (with-array-data ((string string) (start) (end))
595        (declare (ignore start end))
596        (sglyph string index)))
597    
598    (defun sglyph (string index)
599      "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
600       except that the string must be a simple-string."
601      (declare (type simple-string string) (type kernel:index index))
602      #-unicode
603      (schar string index)
604      #+unicode
605      (flet ((xchar (string index)
606               (let ((c (char-code (char string index))))
607                 (cond ((<= #xD800 c #xDBFF)
608                        (let ((c2 (char-code (char string (1+ index)))))
609                          (if (<= #xDC00 c2 #xDFFF)
610                              (+ (ash (- c #xD800) 10) c2 #x2400)
611                              (error "Naked high surrogate in string."))))
612                       ((<= #xDC00 c #xDFFF)
613                        (error "Naked low surrogate in string."))
614                       (t c)))))
615        (let* ((l (length string))
616               (c (xchar string index))
617               (n (+ index (if (> c #xFFFF) 2 1))))
618          (declare (type (integer 0 #x10FFFF) c) (type kernel:index n))
619          (loop while (< n l) do
620            (let ((c (xchar string n)))
621              (when (zerop (lisp::unicode-combining-class c)) (return))
622              (incf n (if (> c #xFFFF) 2 1))))
623          (values (subseq string index n) (and (< n l) n)))))

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

  ViewVC Help
Powered by ViewVC 1.1.5