From ca7e28d94eeca2ea0ac99a68ee137f8f26d2f858 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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