From 1bd699349a9fc1dd0a9501c8d183197b5510011b Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 17 Jun 2008 21:05:01 -0700 Subject: [PATCH] Fixed a problem with port position accounting which was using fixnum arithmetic instead of generic arithmetic. --- scheme/ikarus.io.ss | 34 ++++++++++++++++----------- scheme/last-revision | 2 +- scheme/pass-specify-rep-primops.ss | 37 +++++++++++++++--------------- 3 files changed, 40 insertions(+), 33 deletions(-) diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index 353ae5c..d98e575 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -234,8 +234,8 @@ (define (input-port-byte-position p) (if (input-port? p) - (let ([pos ($port-position p)]) - (and pos (fx+ pos (fx+ ($port-index p) 1)))) + (let ([pos-vec ($port-position p)]) + (+ (vector-ref pos-vec 0) (fx+ ($port-index p) 1))) (error 'input-port-byte-position "not an input port" p))) (define guarded-port @@ -256,13 +256,13 @@ read! write! get-position set-position! close buffer-size) (let ([bv (make-bytevector buffer-size)]) ($make-port attrs 0 init-size bv #f id read! write! - #f #f close #f))) + #f #f close #f (vector 0)))) (define ($make-custom-textual-port attrs init-size id read! write! get-position set-position! close buffer-size) (let ([bv (make-string buffer-size)]) ($make-port attrs 0 init-size bv #t id read! write! - #f #f close #f))) + #f #f close #f (vector 0)))) (define (make-custom-binary-input-port id read! get-position set-position! close) @@ -378,7 +378,8 @@ #f ;;; FIXME: get-position #f ;;; FIXME: set-position! #f ;;; close - #f)])) + #f + (vector 0))])) (define open-bytevector-output-port (case-lambda @@ -405,7 +406,8 @@ #f ;;; FIXME: get-position #f ;;; FIXME: set-position! #f - #f)]) + #f + (vector 0))]) (values p (lambda () @@ -491,7 +493,8 @@ #f ;;; FIXME: get-position #f ;;; FIXME: set-position! #f - cookie))) + cookie + (vector 0)))) (define (open-string-output-port) (let ([p (open-output-string)]) @@ -545,7 +548,8 @@ #f ;;; FIXME: get-position #f ;;; FIXME: set-position! #f ;;; close - #f)) + #f + (vector 0))) (define (open-string-input-port str) (open-string-input-port/id str "*string-input-port*")) @@ -580,7 +584,8 @@ ($port-get-position p) ($port-set-position! p) ($port-close p) - ($port-cookie p))))) + ($port-cookie p) + (vector 0))))) (define (reset-input-port! p) (if (input-port? p) @@ -702,9 +707,8 @@ (let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)]) (let ([c0 (fx- j i)]) (unless (fx= c0 0) (bytevector-copy! bv i bv 0 c0)) - (let ([pos ($port-position p)]) - (when pos - ($set-port-position! p (fx+ pos i)))) + (let ([pos-vec ($port-position p)]) + (vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) i))) (let* ([max (fx- (bytevector-length bv) c0)] [c1 (($port-read! p) bv c0 max)]) (unless (fixnum? c1) @@ -1275,7 +1279,8 @@ [(procedure? close) close] [(eqv? close #t) (file-close-proc id fd)] [else #f]) - fd)]) + fd + (vector 0))]) (guarded-port port))) (define (fh->output-port fd id size transcoder close who) @@ -1315,7 +1320,8 @@ [(procedure? close) close] [(eqv? close #t) (file-close-proc id fd)] [else #f]) - fd)]) + fd + (vector 0))]) (guarded-port port))) (define (file-close-proc id fd) diff --git a/scheme/last-revision b/scheme/last-revision index c2257e8..522e1e9 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1516 +1517 diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index d354a86..442e521 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -1990,24 +1990,25 @@ (define port-attrs-shift 6) (define-primop $make-port unsafe - [(V attrs idx sz buf tr id read write getp setp cl cookie) - (with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))]) - (prm 'mset p (K (- vector-tag)) - (prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag))) - (prm 'mset p (K (- disp-port-index vector-tag)) (T idx)) - (prm 'mset p (K (- disp-port-size vector-tag)) (T sz)) - (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf)) - (prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr)) - (prm 'mset p (K (- disp-port-id vector-tag)) (T id)) - (prm 'mset p (K (- disp-port-read! vector-tag)) (T read)) - (prm 'mset p (K (- disp-port-write! vector-tag)) (T write)) - (prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp)) - (prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp)) - (prm 'mset p (K (- disp-port-close vector-tag)) (T cl)) - (prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie)) - (prm 'mset p (K (- disp-port-position vector-tag)) (K 0)) - (prm 'mset p (K (- disp-port-unused vector-tag)) (K 0)) - p)]) + [(V attrs idx sz buf tr id read write getp setp cl cookie pos) + (with-tmp ([pos (T pos)]) + (with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))]) + (prm 'mset p (K (- vector-tag)) + (prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag))) + (prm 'mset p (K (- disp-port-index vector-tag)) (T idx)) + (prm 'mset p (K (- disp-port-size vector-tag)) (T sz)) + (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf)) + (prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr)) + (prm 'mset p (K (- disp-port-id vector-tag)) (T id)) + (prm 'mset p (K (- disp-port-read! vector-tag)) (T read)) + (prm 'mset p (K (- disp-port-write! vector-tag)) (T write)) + (prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp)) + (prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp)) + (prm 'mset p (K (- disp-port-close vector-tag)) (T cl)) + (prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie)) + (prm 'mset p (K (- disp-port-position vector-tag)) pos) + (prm 'mset p (K (- disp-port-unused vector-tag)) (K 0)) + p))]) (define-primop $port-index unsafe [(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])