From ca7e28d94eeca2ea0ac99a68ee137f8f26d2f858 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 19 Sep 2009 00:18:49 -0700
Subject: [PATCH] Fix logic in STRING-HEAD!. Also some small tweaks.
---
src/runtime/string.scm | 18 +++++++++++-------
src/runtime/stringio.scm | 12 +++++-------
2 files changed, 16 insertions(+), 14 deletions(-)
diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 8d0edddae..79ed06249 100644
--- 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 c8acd063e..aefac3147 100644
--- 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
--
2.25.1