From 18e5988bbfa37a5e015bb1498c3a218b0343fa3b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 7 Sep 2009 16:12:11 -0700 Subject: [PATCH] Eliminate remaining uses of SET-STRING-MAXIMUM-LENGTH!. Fix some bugs in implementation of STRING-HEAD!. Use similar technique to implement STRING-MAXIMUM-LENGTH. --- src/edwin/sendmail.scm | 21 ++++---- src/edwin/utils.scm | 28 ----------- src/runtime/runtime.pkg | 3 +- src/runtime/string.scm | 105 ++++++++++++++++++++++------------------ 4 files changed, 68 insertions(+), 89 deletions(-) diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm index 251e48e1e..4238bce78 100644 --- a/src/edwin/sendmail.scm +++ b/src/edwin/sendmail.scm @@ -1582,18 +1582,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)) - (let ((s - (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))))) - (n (+ plen length))) - (if (fix:> (string-length s) n) - (set-string-maximum-length! s n)) - s))) + (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/utils.scm b/src/edwin/utils.scm index 511e34886..e686f9217 100644 --- a/src/edwin/utils.scm +++ b/src/edwin/utils.scm @@ -124,38 +124,10 @@ USA. (set-interrupt-enables! mask) result))))) -(define (edwin-set-string-maximum-length! string n-chars) - (if (not (string? string)) - (error:wrong-type-argument string "string" 'SET-STRING-MAXIMUM-LENGTH!)) - (if (not (fix:fixnum? n-chars)) - (error:wrong-type-argument n-chars "fixnum" 'SET-STRING-MAXIMUM-LENGTH!)) - (if (not (and (fix:>= n-chars 0) - (fix:< n-chars - (fix:lsh (fix:- (system-vector-length string) 1) - (fix:- 0 (chars-to-words-shift)))))) - (error:bad-range-argument n-chars 'SET-STRING-MAXIMUM-LENGTH!)) - (let ((mask (set-interrupt-enables! interrupt-mask/none))) - ((ucode-primitive primitive-object-set! 3) - string - 0 - ((ucode-primitive primitive-object-set-type 2) - (ucode-type manifest-nm-vector) - (fix:+ 1 (chars->words (fix:+ n-chars 1))))) - (set-string-length! string (fix:+ n-chars 1)) - (string-set! string n-chars #\nul) - (set-string-length! string n-chars) - (set-interrupt-enables! mask) - unspecific)) - (define string-allocate (if (compiled-procedure? edwin-string-allocate) edwin-string-allocate (ucode-primitive string-allocate))) - -(define set-string-maximum-length! - (if (compiled-procedure? edwin-set-string-maximum-length!) - edwin-set-string-maximum-length! - (ucode-primitive set-string-maximum-length!))) (define (%substring-move! source start-source end-source target start-target) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 95907d045..1b9935761 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -772,7 +772,6 @@ USA. (export () (guarantee-vector-8b guarantee-string) (set-vector-8b-length! set-string-length!) - (set-vector-8b-maximum-length! set-string-maximum-length!) (vector-8b-length string-length) (vector-8b-maximum-length string-maximum-length) (vector-8b? string?) @@ -802,7 +801,6 @@ USA. reverse-substring reverse-substring! set-string-length! - set-string-maximum-length! string string->list string-allocate @@ -831,6 +829,7 @@ USA. string-hash string-hash-mod string-head + string-head! string-length string-lower-case? string-match-backward diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 079966d6e..8d0edddae 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -46,7 +46,6 @@ USA. (string-allocate 1) (string-hash-mod 2) (string-length 1) - (string-maximum-length 1) (string-ref 2) (string-set! 3) (string? 1) @@ -133,58 +132,15 @@ USA. (define (string-head string end) (guarantee-string string 'STRING-HEAD) - (guarantee-string-index end 'STRING-HEAD) + (guarantee-substring-end-index end (string-length string) 'STRING-HEAD) (%string-head string end)) -(declare (integrate-operator %string-head)) -(define (%string-head string end) +(define-integrable (%string-head string end) (%substring string 0 end)) -(define (%truncate-string! string end) - (let-syntax ((chars-to-words-shift - (sc-macro-transformer - (lambda (form environment) - form environment - ;; This is written as a macro so that the shift will be a constant - ;; in the compiled code. - ;; It does not work when cross-compiled! - (let ((chars-per-word (vector-ref (gc-space-status) 0))) - (case chars-per-word - ((4) -2) - ((8) -3) - (else (error "Can't support this word size:" chars-per-word)))))))) - - (if (not (and (fix:>= end 0) - (fix:< end - (fix:lsh (fix:- (system-vector-length string) 1) - (fix:- 0 (chars-to-words-shift)))))) - (error:bad-range-argument end 'STRING-HEAD!)) - (let ((mask (set-interrupt-enables! interrupt-mask/none))) - ((ucode-primitive primitive-object-set! 3) - string - 0 - ((ucode-primitive primitive-object-set-type 2) - (ucode-type manifest-nm-vector) - (fix:+ 1 (chars->words (fix:+ end 1))))) - (set-string-length! string (fix:+ end 1)) - (string-set! string end #\nul) - (set-string-length! string end) - (set-interrupt-enables! mask) - string))) - -(define %string-head! - (if (compiled-procedure? %truncate-string!) - %truncate-string! - %string-head)) - -(define (string-head! string end) - (guarantee-string string 'STRING-HEAD!) - (guarantee-string-index end 'STRING-HEAD!) - (%string-head! string end)) - (define (string-tail string start) (guarantee-string string 'STRING-TAIL) - (guarantee-string-index start 'STRING-TAIL) + (guarantee-substring-start-index start (string-length string) 'STRING-TAIL) (%substring string start (string-length string))) (define (string-copy string) @@ -197,6 +153,61 @@ USA. (%substring-move! string 0 size result 0) result))) +(define (string-head! string end) + (guarantee-string string 'STRING-HEAD!) + (guarantee-substring-end-index end (string-length string) 'STRING-HEAD!) + (%string-head! string end)) + +(define %string-head! + (let ((reuse + (lambda (string end) + (let ((mask (set-interrupt-enables! interrupt-mask/none))) + ((ucode-primitive primitive-object-set! 3) + string + 0 + ((ucode-primitive primitive-object-set-type 2) + (ucode-type manifest-nm-vector) + (fix:+ 1 (%octets->words (fix:+ end 1))))) + (set-string-length! string (fix:+ end 1)) + (string-set! string end #\nul) + (set-string-length! string end) + (set-interrupt-enables! mask) + string)))) + (if (compiled-procedure? reuse) + reuse + %string-head))) + +(define (string-maximum-length string) + (guarantee-string string 'STRING-MAXIMUM-LENGTH) + (%string-maximum-length string)) + +(define-integrable (%string-maximum-length string) + (fix:- (%octets-maximum-length string) 1)) + +(define-integrable (%octets-maximum-length octets) + (fix:lsh (fix:- (system-vector-length octets) 1) + %words->octets-shift)) + +(define-integrable (%octets->words n-octets) + (fix:lsh (fix:+ n-octets (fix:not (fix:lsh -1 %words->octets-shift))) + %octets->words-shift)) + +(define-integrable %octets->words-shift + ((sc-macro-transformer + (lambda (form environment) + form environment + ;; This is written as a macro so that the shift will be a + ;; constant in the compiled code. It does not work when + ;; cross-compiled! + (let ((chars-per-word (vector-ref (gc-space-status) 0))) + (case chars-per-word + ((4) -2) + ((8) -3) + (else (error "Can't support this word size:" chars-per-word)))))))) + +(define-integrable %words->octets-shift + (fix:- 0 %octets->words-shift)) + (define (string . objects) (%string-append (map ->string objects))) -- 2.25.1