From: Chris Hanson Date: Wed, 22 Feb 2017 06:42:43 +0000 (-0800) Subject: Eliminate "capitalize" string operations, add dummy string-titlecase. X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~21 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34f45013ed666efd0a8f7ab421c1d6afa2768de7;p=mit-scheme.git Eliminate "capitalize" string operations, add dummy string-titlecase. --- diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index a0c06a059..9f8b2d8e9 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -953,7 +953,7 @@ using the read-eval-print environment instead.") (debugger-failure port "There is no current environment.")) (define (reason+message reason message) - (string-capitalize (if reason (string-append reason "; " message) message))) + (string-titlecase (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) (parameterize* (list (cons param:unparser-list-depth-limit diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 445d9cadb..8e87840a2 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -1066,7 +1066,7 @@ USA. (write-string " because: " port) (let ((reason (access-condition condition 'REASON))) (if reason - (write-string (string-capitalize reason) port) + (write-string (string-titlecase reason) port) (begin (write-string "No such " port) (write-string noun port)))) diff --git a/src/runtime/recslot.scm b/src/runtime/recslot.scm index e0ff5a8f6..e82f630e8 100644 --- a/src/runtime/recslot.scm +++ b/src/runtime/recslot.scm @@ -133,7 +133,7 @@ USA. (with-restart 'USE-VALUE (string-append "Specify a " noun-phrase ".") k - (string->interactor (string-capitalize noun-phrase)) + (string->interactor (string-titlecase noun-phrase)) thunk)) (define ((string->interactor string)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index cb85fb385..ac633cfc2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1040,8 +1040,6 @@ USA. lisp-string->camel-case reverse-string reverse-substring - string-capitalize - string-capitalized? string-compare string-compare-ci string-match-backward @@ -1057,7 +1055,6 @@ USA. string-trim string-trim-left string-trim-right - substring-capitalized? substring-match-backward substring-match-backward-ci substring-match-forward @@ -1151,6 +1148,7 @@ USA. string-suffix-ci? string-suffix? string-tail + string-titlecase string-upcase string-upper-case? string<=? diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 4414d6c6e..20da67acf 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -89,78 +89,6 @@ USA. (string-set! result j (string-ref string i))) result))) -;;;; Case - -(define (string-capitalized? string) - (guarantee-string string 'STRING-CAPITALIZED?) - (substring-capitalized? string 0 (string-length string))) - -(define (substring-capitalized? string start end) - (guarantee-substring string start end 'SUBSTRING-CAPITALIZED?) - (%substring-capitalized? string start end)) - -(define (%substring-capitalized? string start end) - ;; Testing for capitalization is somewhat more involved than testing - ;; for upper or lower case. This algorithm requires that the first - ;; word be capitalized, and that the subsequent words be either - ;; lower case or capitalized. This is a very general definition of - ;; capitalization; if you need something more specific you should - ;; call this procedure on the individual words. - (letrec - ((find-first-word - (lambda (start) - (and (fix:< start end) - (let ((char (string-ref string start))) - (if (char-upper-case? char) - (scan-word-tail (fix:+ start 1)) - (and (not (char-lower-case? char)) - (find-first-word (fix:+ start 1)))))))) - (scan-word-tail - (lambda (start) - (or (fix:= start end) - (let ((char (string-ref string start))) - (if (char-lower-case? char) - (scan-word-tail (fix:+ start 1)) - (and (not (char-upper-case? char)) - (find-subsequent-word (fix:+ start 1)))))))) - (find-subsequent-word - (lambda (start) - (or (fix:= start end) - (let ((char (string-ref string start))) - (if (char-alphabetic? char) - (scan-word-tail (fix:+ start 1)) - (find-subsequent-word (fix:+ start 1)))))))) - (find-first-word start))) - -(define (string-capitalize string) - (guarantee-string string 'STRING-CAPITALIZE) - (let ((string (string-copy string))) - (%substring-capitalize! string 0 (string-length string)) - string)) - -(define (%substring-capitalize! string start end) - ;; This algorithm capitalizes the first word in the substring and - ;; downcases the subsequent words. This is arbitrary, but seems - ;; useful if the substring happens to be a sentence. Again, if you - ;; need finer control, parse the words yourself. - (let ((index - (substring-find-next-char-in-set string start end - char-set:alphabetic))) - (if index - (begin - (%substring-upcase! string index (fix:+ index 1)) - (%substring-downcase! string (fix:+ index 1) end))))) - -(define (%substring-upcase! string start end) - (do ((i start (fix:+ i 1))) - ((fix:= i end)) - (string-set! string i (char-upcase (string-ref string i))))) - -(define (%substring-downcase! string start end) - (do ((i start (fix:+ i 1))) - ((fix:= i end)) - (string-set! string i (char-downcase (string-ref string i))))) - ;;;; CamelCase support (define (camel-case-string->lisp string) diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index 4df0a2053..664454bfa 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -388,6 +388,10 @@ USA. (define (string-upcase string) (case-transform char-upcase-full string)) +(define (string-titlecase string) + ;; TODO(cph): implement this + (string-copy string)) + (define (case-transform transform string) (let ((chars (append-map transform (string->list string)))) (let ((n (length chars)))