Eliminate remaining uses of SET-STRING-MAXIMUM-LENGTH!. Fix some bugs

in implementation of STRING-HEAD!.  Use similar technique to implement
STRING-MAXIMUM-LENGTH.

diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm
index 251e48e1e3d96503055bbb27af36e0484ac21159..4238bce78a1c3da96c13de2f46875e7591fc8ae3 100644 (file)
--- 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))))
 \f
 ;;;; Attachment browser
 

diff --git a/src/edwin/utils.scm b/src/edwin/utils.scm
index 511e34886094269886dde2f50edc87f25c53b43b..e686f92172a5b1787ea2bb2ab35f2bce6a966aee 100644 (file)
--- 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!)))
 \f
 (define (%substring-move! source start-source end-source
                          target start-target)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 95907d0454649e5a9c12bd983560cf5f472e991c..1b99357610ea980cbff7f2325f725317580f87fe 100644 (file)
--- 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 079966d6e358b9c64d6b606e8c5bc127175cd419..8d0edddaefe1c2fd5324865f6d61d8b5aa1e76cc 100644 (file)
--- 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)))
 \f
+(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))
+\f
 (define (string . objects)
   (%string-append (map ->string objects)))