conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixed a problem with port position accounting which was using fixnum 

arithmetic instead of generic arithmetic.
This commit is contained in:
Abdulaziz Ghuloum 2008-06-17 21:05:01 -07:00
parent 333dc03f8f
commit 1bd699349a
3 changed files with 40 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
scheme/ikarus.io.ss
View File

@ -234,8 +234,8 @@
(define (input-port-byte-position p) (define (input-port-byte-position p)
(if (input-port? p) (if (input-port? p)
(let ([pos ($port-position p)]) (let ([pos-vec ($port-position p)])
(and pos (fx+ pos (fx+ ($port-index p) 1)))) (+ (vector-ref pos-vec 0) (fx+ ($port-index p) 1)))
(error 'input-port-byte-position "not an input port" p))) (error 'input-port-byte-position "not an input port" p)))
(define guarded-port (define guarded-port
@ -256,13 +256,13 @@
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)]) (let ([bv (make-bytevector buffer-size)])
($make-port attrs 0 init-size bv #f id read! write! ($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 (define ($make-custom-textual-port attrs init-size id
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(let ([bv (make-string buffer-size)]) (let ([bv (make-string buffer-size)])
($make-port attrs 0 init-size bv #t id read! write! ($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 (define (make-custom-binary-input-port id
read! get-position set-position! close) read! get-position set-position! close)
@ -378,7 +378,8 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f ;;; close #f ;;; close
#f)])) #f
(vector 0))]))
(define open-bytevector-output-port (define open-bytevector-output-port
(case-lambda (case-lambda
@ -405,7 +406,8 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f #f
#f)]) #f
(vector 0))])
(values (values
p p
(lambda () (lambda ()
@ -491,7 +493,8 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f #f
cookie))) cookie
(vector 0))))
(define (open-string-output-port) (define (open-string-output-port)
(let ([p (open-output-string)]) (let ([p (open-output-string)])
@ -545,7 +548,8 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f ;;; close #f ;;; close
#f)) #f
(vector 0)))
(define (open-string-input-port str) (define (open-string-input-port str)
(open-string-input-port/id str "*string-input-port*")) (open-string-input-port/id str "*string-input-port*"))
@ -580,7 +584,8 @@
($port-get-position p) ($port-get-position p)
($port-set-position! p) ($port-set-position! p)
($port-close p) ($port-close p)
($port-cookie p))))) ($port-cookie p)
(vector 0)))))
(define (reset-input-port! p) (define (reset-input-port! p)
(if (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 ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)])
(let ([c0 (fx- j i)]) (let ([c0 (fx- j i)])
(unless (fx= c0 0) (bytevector-copy! bv i bv 0 c0)) (unless (fx= c0 0) (bytevector-copy! bv i bv 0 c0))
(let ([pos ($port-position p)]) (let ([pos-vec ($port-position p)])
(when pos (vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) i)))
($set-port-position! p (fx+ pos i))))
(let* ([max (fx- (bytevector-length bv) c0)] (let* ([max (fx- (bytevector-length bv) c0)]
[c1 (($port-read! p) bv c0 max)]) [c1 (($port-read! p) bv c0 max)])
(unless (fixnum? c1) (unless (fixnum? c1)
@ -1275,7 +1279,8 @@
[(procedure? close) close] [(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)] [(eqv? close #t) (file-close-proc id fd)]
[else #f]) [else #f])
fd)]) fd
(vector 0))])
(guarded-port port))) (guarded-port port)))
(define (fh->output-port fd id size transcoder close who) (define (fh->output-port fd id size transcoder close who)
@ -1315,7 +1320,8 @@
[(procedure? close) close] [(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)] [(eqv? close #t) (file-close-proc id fd)]
[else #f]) [else #f])
fd)]) fd
(vector 0))])
(guarded-port port))) (guarded-port port)))
(define (file-close-proc id fd) (define (file-close-proc id fd)

2
scheme/last-revision
View File

@ -1 +1 @@
1516 1517

37
scheme/pass-specify-rep-primops.ss
View File

@ -1990,24 +1990,25 @@
(define port-attrs-shift 6) (define port-attrs-shift 6)
(define-primop $make-port unsafe (define-primop $make-port unsafe
[(V attrs idx sz buf tr id read write getp setp cl cookie) [(V attrs idx sz buf tr id read write getp setp cl cookie pos)
(with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))]) (with-tmp ([pos (T pos)])
(prm 'mset p (K (- vector-tag)) (with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))])
(prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag))) (prm 'mset p (K (- vector-tag))
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx)) (prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag)))
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz)) (prm 'mset p (K (- disp-port-index vector-tag)) (T idx))
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf)) (prm 'mset p (K (- disp-port-size vector-tag)) (T sz))
(prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr)) (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf))
(prm 'mset p (K (- disp-port-id vector-tag)) (T id)) (prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr))
(prm 'mset p (K (- disp-port-read! vector-tag)) (T read)) (prm 'mset p (K (- disp-port-id vector-tag)) (T id))
(prm 'mset p (K (- disp-port-write! vector-tag)) (T write)) (prm 'mset p (K (- disp-port-read! vector-tag)) (T read))
(prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp)) (prm 'mset p (K (- disp-port-write! vector-tag)) (T write))
(prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp)) (prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp))
(prm 'mset p (K (- disp-port-close vector-tag)) (T cl)) (prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp))
(prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie)) (prm 'mset p (K (- disp-port-close vector-tag)) (T cl))
(prm 'mset p (K (- disp-port-position vector-tag)) (K 0)) (prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie))
(prm 'mset p (K (- disp-port-unused vector-tag)) (K 0)) (prm 'mset p (K (- disp-port-position vector-tag)) pos)
p)]) (prm 'mset p (K (- disp-port-unused vector-tag)) (K 0))
p))])
(define-primop $port-index unsafe (define-primop $port-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])