diff --git a/code/string.lisp b/code/string.lisp index 7ad9da4694b9470a93e67a39d786fbb4481e6f31..a084bb134435d544d186bb51e85965cb8ef6c6ae 100644 --- a/code/string.lisp +++ b/code/string.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.19 2009/09/15 15:51:25 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.20 2009/09/15 15:52:43 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -1481,155 +1481,6 @@ ;; ;;;-------------------------------------------------------------------------------- -#+nil -(progn -(defun string-next-word-break (s i) - (let ((n (length s))) - (labels - ((char-word-break-category (c) - ;; Map our unicode word break property into what this - ;; algorithm wants. - (let ((cat (lisp::unicode-word-break (char-code c)))) - (case cat - ((:lf :cr :newline) - :sep) - ((:extend :format) - :extend-or-format) - (otherwise cat)))) - (left-context (i) - ;; Given a valid index i into s, returns the left context - ;; at i. - (let* ((c (char s i)) - (cat (char-word-break-category c))) - (case cat - ((:sep) - (if (char= c #\return) :cr cat)) - ((:midletter) - (let ((i-1 (- i 1))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :aletter)) - :aletter-midletter - cat))) - ((:midnum) - (let ((i-1 (- i 1))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :numeric)) - :numeric-midnum - cat))) - ((:extendorformat) - (if (< 0 i) - (left-context (- i 1)) - :other)) - (otherwise cat)))) - - (index-of-previous-non-ignored (j) - ;; Returns the index of the last non-Extend, non-Format - ;; character within (substring s 0 j). Should not be - ;; called unless such a character exists. - - (let* ((j1 (- j 1)) - (c (char s j1)) - (cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (index-of-previous-non-ignored j1)) - (otherwise j1)))) - - (lookup (j context) - ;; Given j and the context to the left of (not including) j, - ;; returns the index at the start of the next word - ;; (or before which a word break is permitted). - - (if (>= j n) - (case context - ((:aletter-midletter :numeric-midnum) - (let ((j (index-of-previous-non-ignored n))) - (if (< i j) j n))) - (otherwise n)) - (let* ((c (char s j)) - (cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (case context - ((:cr :sep) j) - (otherwise (lookup (+ j 1) context)))) - (otherwise - (case context - ((:cr) - (if (char= c #\linefeed) - (lookup (+ j 1) cat) - j)) - ((:aletter) - (case cat - ((:aletter :numeric :extendnumlet) - (lookup (+ j 1) cat)) - ((:midletter :midnumlet) - (lookup (+ j 1) :aletter-midletter)) - (otherwise j))) - ((:aletter-midletter) - (case cat - ((:aletter) - (lookup (+ j 1) cat)) - (otherwise - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:numeric) - (case cat - ((:numeric :aletter :extendnumlet) - (lookup (+ j 1) cat)) - ((:midnum :midnumlet) - (lookup (+ j 1) :numeric-midnum)) - (otherwise j))) - ((:numeric-midnum) - (case cat - ((:numeric) - (lookup (+ j 1) cat)) - (otherwise - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:midletter :midnum :midnumlet) j) - ((:katakana) - (case cat - ((:katakana :extendnumlet) - (lookup (+ j 1) cat)) - (otherwise j))) - ((:extendnumlet) - (case cat - ((:extendnumlet :aletter :numeric :katakana) - (lookup (+ j 1) cat)) - (otherwise j))) - (otherwise j)))))))) - (declare (notinline lookup left-context)) - (cond ((< i 0) 0) - ((<= n i) n) - (t (lookup (+ i 1) (left-context i))))))) - -(defun string-capitalize-unicode (s &key (start 0) end casing) - (declare (type (member :simple :full) casing)) - (let ((end (or end (length s)))) - (with-output-to-string (result) - (let ((upper (ecase casing - (:simple - #'(lambda (ch) - (write-char (char-upcase ch) result))) - (:full - #'(lambda (ch) - (write-string (unicode-full-case-title (char-code ch)) result)))))) - (when (plusp start) - (write-string s result :start 0 :end start)) - (do ((start start next) - (next (string-next-word-break s start) - (string-next-word-break s next))) - ((or (= start next) - (>= start end)) - (write-string s result :start start) - nil) - (funcall upper (char s start)) - (write-string (string-downcase s :start (1+ start) :end next :casing casing) - result :start (1+ start) :end next)))))) - -) - (defun string-next-word-break (s i) (let ((n (length s))) (labels