Fix logic in STRING-HEAD!. Also some small tweaks.

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 8d0edddaefe1c2fd5324865f6d61d8b5aa1e76cc..79ed06249651a98085c2c9a077de6b5e422718c2 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -162,15 +162,17 @@ USA.
   (let ((reuse
         (lambda (string end)
           (let ((mask (set-interrupt-enables! interrupt-mask/none)))
+            (declare (no-type-checks) (no-range-checks))
+            (if (fix:< end (string-length string))
+                (begin
+                  (string-set! string end #\nul)
+                  (set-string-length! string end)))
             ((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)
@@ -185,11 +187,13 @@ USA.
   (fix:- (%octets-maximum-length string) 1))
 
 (define-integrable (%octets-maximum-length octets)
-  (fix:lsh (fix:- (system-vector-length octets) 1)
-          %words->octets-shift))
+  (%words->octets (fix:- (system-vector-length octets) 1)))
+
+(define-integrable (%words->octets n-words)
+  (fix:lsh n-words %words->octets-shift))
 
 (define-integrable (%octets->words n-octets)
-  (fix:lsh (fix:+ n-octets (fix:not (fix:lsh -1 %words->octets-shift)))
+  (fix:lsh (fix:+ n-octets (fix:- (fix:lsh 1 %words->octets-shift) 1))
           %octets->words-shift))
 
 (define-integrable %octets->words-shift
@@ -1724,4 +1728,4 @@ USA.
 
 (define-integrable (guarantee-char-set object procedure)
   (if (not (char-set? object))
-      (error:wrong-type-argument object "character set" procedure)))
+      (error:wrong-type-argument object "character set" procedure)))
\ No newline at end of file

diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index c8acd063e04d9ed70311a5ae256e0b2f38909b79..aefac3147fd3247cbf93a7411e4b67e71aad9533 100644 (file)
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -423,10 +423,9 @@ USA.
 
 (define (narrow-out/extract-output! port)
   (let* ((os (port/state port))
-        (string (ostate-buffer os))
-        (length (ostate-index os)))
+        (output (string-head! (ostate-buffer os) (ostate-index os))))
     (reset-buffer! os)
-    (string-head! string length)))
+    output))
 
 (define (make-wide-output-type)
   (make-string-out-type wide-out/write-char
@@ -604,11 +603,10 @@ USA.
 (define (octets-out/extract-output! port)
   (output-port/flush-output port)
   (let* ((os (output-octets-port/os port))
-        (octets (ostate-buffer os))
-        (length (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)
-    (string-head! octets length)))
+    output))
 
 (define (octets-out/position port)
   (output-port/flush-output port)
@@ -636,4 +634,4 @@ USA.
   (set! wide-output-type (make-wide-output-type))
   (set! octets-output-type (make-octets-output-type))
   (set! output-octets-port/os (generic-i/o-port-accessor 0))
-  unspecific)
+  unspecific)
\ No newline at end of file