From a1cb59e95746c27482ee3ac08abf4b9a978a87a6 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 19 Feb 2017 01:21:31 -0800 Subject: [PATCH] Eliminate a bunch of operations that modify strings in place. These generally save a little memory but are difficult to implement with Unicode strings. It's not worth the trouble to keep them since the copying procedures can be used instead. --- src/edwin/dosfile.scm | 4 +- src/edwin/info.scm | 4 +- src/edwin/sendmail.scm | 18 +++---- src/edwin/texcom.scm | 18 ++----- src/imail/imail-imap.scm | 4 +- src/runtime/input.scm | 2 +- src/runtime/pgsql.scm | 2 +- src/runtime/runtime.pkg | 11 ---- src/runtime/string.scm | 110 ++++----------------------------------- src/runtime/stringio.scm | 2 +- 10 files changed, 30 insertions(+), 145 deletions(-) diff --git a/src/edwin/dosfile.scm b/src/edwin/dosfile.scm index 536ce583f..64057c46b 100644 --- a/src/edwin/dosfile.scm +++ b/src/edwin/dosfile.scm @@ -113,7 +113,7 @@ Includes the new backup. Must be > 0." (let loop ((result '())) (let ((name (directory-channel-read channel))) (if name - (loop (cons (begin (string-downcase! name) name) result)) + (loop (cons (string-downcase name) result)) (begin (directory-channel-close channel) result)))))) @@ -123,7 +123,7 @@ Includes the new backup. Must be > 0." (let loop ((result '())) (let ((name (directory-channel-read-matching channel prefix))) (if name - (loop (cons (begin (string-downcase! name) name) result)) + (loop (cons (string-downcase name) result)) (begin (directory-channel-close channel) result)))))) diff --git a/src/edwin/info.scm b/src/edwin/info.scm index 4d52ae071..5aac3fb87 100644 --- a/src/edwin/info.scm +++ b/src/edwin/info.scm @@ -649,9 +649,7 @@ The name may be an abbreviation of the reference name." (%cref-item-keyword item (mark-1+ colon)))) (define (%cref-item-keyword item colon) - (let ((string (extract-string item colon))) - (string-replace! string #\newline #\Space) - (string-trim string))) + (string-trim (string-replace (extract-string item colon) #\newline #\space))) (define (cref-item-name item) (let ((colon (char-search-forward #\: item (group-end item) false))) diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm index 3dbdafbb6..49ae7b36c 100644 --- a/src/edwin/sendmail.scm +++ b/src/edwin/sendmail.scm @@ -1583,15 +1583,15 @@ the user from the mailer." (plen (string-length prefix))) (if (not (<= 1 length (- 70 plen))) (error:bad-range-argument length 'RANDOM-MIME-BOUNDARY-STRING)) - (string-head! (call-with-output-string - (lambda (port) - (write-string prefix port) - (let ((context (encode-base64:initialize port #f))) - (let ((n (* (integer-ceiling (- length 2) 4) 3))) - (encode-base64:update context - (random-byte-vector n) 0 n)) - (encode-base64:finalize context)))) - (+ plen length)))) + (string-head (call-with-output-string + (lambda (port) + (write-string prefix port) + (let ((context (encode-base64:initialize port #f))) + (let ((n (* (integer-ceiling (- length 2) 4) 3))) + (encode-base64:update context + (random-byte-vector n) 0 n)) + (encode-base64:finalize context)))) + (+ plen length)))) ;;;; Attachment browser diff --git a/src/edwin/texcom.scm b/src/edwin/texcom.scm index e090fd428..9c3d532c1 100644 --- a/src/edwin/texcom.scm +++ b/src/edwin/texcom.scm @@ -183,16 +183,10 @@ With negative argument, capitalize previous words but do not move." (if (positive? argument) (set-current-point! end)))) (define (downcase-region region) - (region-transform! region - (lambda (string) - (string-downcase! string) - string))) + (region-transform! region string-downcase)) (define (upcase-region region) - (region-transform! region - (lambda (string) - (string-upcase! string) - string))) + (region-transform! region string-upcase)) (define (capitalize-region region) (let ((end (region-end region))) @@ -203,14 +197,10 @@ With negative argument, capitalize previous words but do not move." (if m (begin (region-transform! (make-region start m) - (lambda (string) - (string-capitalize! string) - string)) + string-capitalize) (loop m)) (region-transform! (make-region start end) - (lambda (string) - (string-capitalize! string) - string))))))))) + string-capitalize)))))))) ;;;; Sentences diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index 78023c6b8..9690df2e5 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -139,9 +139,7 @@ USA. (cond ((string-ci=? "inbox" mailbox) "inbox") ((and (string-prefix-ci? "inbox/" mailbox) (not (string-prefix? "inbox/" mailbox))) - (let ((mailbox (string-copy mailbox))) - (substring-downcase! mailbox 0 5) - mailbox)) + (substring-downcase mailbox 0 5)) (else mailbox))) (define (compatible-imap-urls? url1 url2) diff --git a/src/runtime/input.scm b/src/runtime/input.scm index b78e538c2..ba4dd8de8 100644 --- a/src/runtime/input.scm +++ b/src/runtime/input.scm @@ -107,7 +107,7 @@ USA. a) (define-integrable (accum->string a) - (string-head! (car a) (cdr a))) + (string-head (car a) (cdr a))) (define-integrable (accum-count a) (cdr a)) diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index 072d67843..d177dd07c 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -300,7 +300,7 @@ USA. (define (escape-pgsql-string string) (guarantee-pgsql-available) (let ((escaped (make-string (fix:* 2 (string-length string))))) - (string-head! escaped (pq-escape-string string escaped)))) + (string-head escaped (pq-escape-string string escaped)))) (define (encode-pgsql-bytea bytes) (guarantee-pgsql-available) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 5e790b85f..1b06a3949 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1049,18 +1049,13 @@ USA. lisp-string->camel-case make-string reverse-string - reverse-string! reverse-substring - reverse-substring! set-string-length! string-allocate string-capitalize - string-capitalize! string-capitalized? string-compare string-compare-ci - string-downcase! - string-head! string-match-backward string-match-backward-ci string-match-forward @@ -1069,27 +1064,21 @@ USA. string-pad-left string-pad-right string-replace - string-replace! string-search-all string-search-backward string-search-forward string-trim string-trim-left string-trim-right - string-upcase! - substring-capitalize! substring-capitalized? - substring-downcase! substring-match-backward substring-match-backward-ci substring-match-forward substring-match-forward-ci substring-replace - substring-replace! substring-search-all substring-search-backward substring-search-forward - substring-upcase! substring?) (initialization (initialize-package!))) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 3e0ac7a87..0baf081d0 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -81,43 +81,6 @@ USA. (let ((result (string-allocate size))) (and (%ascii-substring-move! string 0 size result 0) result)))) - -(define (string-head! string end) - (declare (no-type-checks) (no-range-checks)) - (guarantee-string string 'STRING-HEAD!) - (guarantee-substring-end-index end (string-length string) 'STRING-HEAD!) - (%string-head! string end)) - -(define %string-head! - (let ((reuse - (named-lambda (%string-head! string end) - (declare (no-type-checks) (no-range-checks)) - (let ((mask (set-interrupt-enables! interrupt-mask/none))) - (if (fix:< end (string-length string)) - (begin - (string-set! string end #\nul) - (set-string-length! string end))) - (let ((new-gc-length (fix:+ 2 (fix:lsh end %octets->words-shift))) - (old-gc-length (system-vector-length string))) - (let ((delta (fix:- old-gc-length new-gc-length))) - (cond ((fix:= delta 1) - (system-vector-set! string new-gc-length #f)) - ((fix:> delta 1) - (system-vector-set! - string new-gc-length - ((ucode-primitive primitive-object-set-type 2) - (ucode-type manifest-nm-vector) (fix:-1+ delta))))) - (if (fix:> delta 0) - ((ucode-primitive primitive-object-set! 3) - string - 0 - ((ucode-primitive primitive-object-set-type 2) - (ucode-type manifest-nm-vector) new-gc-length))))) - (set-interrupt-enables! mask) - string)))) - (if (compiled-procedure? reuse) - reuse - string-head))) (define (string-maximum-length string) (guarantee-string string 'STRING-MAXIMUM-LENGTH) @@ -236,23 +199,6 @@ USA. ((fix:= i end)) (string-set! result j (string-ref string i))) result))) - -(define (reverse-string! string) - (guarantee-string string 'REVERSE-STRING!) - (%reverse-substring! string 0 (string-length string))) - -(define (reverse-substring! string start end) - (guarantee-substring string start end 'REVERSE-SUBSTRING!) - (%reverse-substring! string start end)) - -(define (%reverse-substring! string start end) - (let ((k (fix:+ start (fix:quotient (fix:- end start) 2)))) - (do ((i start (fix:+ i 1)) - (j (fix:- end 1) (fix:- j 1))) - ((fix:= i k)) - (let ((char (string-ref string j))) - (string-set! string j (string-ref string i)) - (string-set! string i char))))) (define (vector-8b->hexadecimal bytes) (define-integrable (hex-char k) @@ -298,32 +244,6 @@ USA. ;;;; Case -(define (string-upcase! string) - (guarantee-string string 'STRING-UPCASE!) - (%substring-upcase! string 0 (string-length string))) - -(define (substring-upcase! string start end) - (guarantee-substring string start end 'SUBSTRING-UPCASE!) - (%substring-upcase! string start 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 (string-downcase! string) - (guarantee-string string 'STRING-DOWNCASE!) - (substring-downcase! string 0 (string-length string))) - -(define (substring-downcase! string start end) - (guarantee-substring string start end 'SUBSTRING-DOWNCASE!) - (%substring-downcase! string start end)) - -(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))))) - (define (string-capitalized? string) (guarantee-string string 'STRING-CAPITALIZED?) (substring-capitalized? string 0 (string-length string))) @@ -371,14 +291,6 @@ USA. (%substring-capitalize! string 0 (string-length string)) string)) -(define (string-capitalize! string) - (guarantee-string string 'STRING-CAPITALIZE!) - (%substring-capitalize! string 0 (string-length string))) - -(define (substring-capitalize! string start end) - (guarantee-substring string start end 'SUBSTRING-CAPITALIZE!) - (%substring-capitalize! string start end)) - (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 @@ -391,6 +303,16 @@ USA. (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 @@ -448,18 +370,6 @@ USA. (%substring-replace! string start end char1 char2) string)) -(define (string-replace! string char1 char2) - (guarantee-string string 'STRING-REPLACE!) - (guarantee-char char1 'STRING-REPLACE!) - (guarantee-char char2 'STRING-REPLACE!) - (%substring-replace! string 0 (string-length string) char1 char2)) - -(define (substring-replace! string start end char1 char2) - (guarantee-substring string start end 'SUBSTRING-REPLACE!) - (guarantee-char char1 'SUBSTRING-REPLACE!) - (guarantee-char char2 'SUBSTRING-REPLACE!) - (%substring-replace! string start end char1 char2)) - (define (%substring-replace! string start end char1 char2) (let loop ((start start)) (let ((index (substring-find-next-char string start end char1))) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index dec384903..d6faebe04 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -335,7 +335,7 @@ USA. (define (octets-out/extract-output! port) (output-port/flush-output port) (let* ((os (output-octets-port/os port)) - (output (string-head! (ostate-buffer os) (ostate-index os)))) + (output (string-head (ostate-buffer os) (ostate-index os)))) (set-ostate-buffer! os (make-vector-8b 16)) (set-ostate-index! os 0) output)) -- 2.25.1