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

input-port-byte-position works for input files.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-18 17:25:48 -05:00
parent 64e54de392
commit 945e8473fc
5 changed files with 24 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

37
scheme/ikarus.io.ss
View File

@ -58,6 +58,7 @@
port-mode set-port-mode!
reset-input-port!
port-id
input-port-byte-position
)
@ -105,6 +106,7 @@
port-mode set-port-mode!
reset-input-port!
port-id
input-port-byte-position
))
(module UNSAFE
@ -215,6 +217,12 @@
($port-id p)
(die 'port-id "not a port" p)))
(define (input-port-byte-position p)
(if (input-port? p)
(let ([pos ($port-position p)])
(and pos (fx+ pos ($port-index p))))
(error 'input-port-byte-position "not an input port" p)))
(define guarded-port
(let ([G (make-guardian)])
(define (clean-up)
@ -605,27 +613,14 @@
;;; ----------------------------------------------------------
(module (read-char get-char lookahead-char)
(import UNSAFE)
(define (refill-bv-start p who)
(when ($port-closed? p) (die who "port is closed" p))
(let* ([bv ($port-buffer p)]
[n (bytevector-length bv)])
(let ([j (($port-read! p) bv 0 n)])
(unless (fixnum? j)
(die who "invalid return value from read! procedure" j))
(cond
[(fx>= j 0)
(unless (fx<= j n)
(die who "read! returned a value out of range" j))
($set-port-index! p 0)
($set-port-size! p j)
j]
[else
(die who "read! returned a value out of range" j)]))))
(define (refill-bv-buffer p who)
(when ($port-closed? p) (die who "port is closed" p))
(let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)])
(let ([c0 (fx- j i)])
(bytevector-copy! bv i bv 0 c0)
(let ([pos ($port-position p)])
(when pos
($set-port-position! p (fx+ pos i))))
(let* ([max (fx- (bytevector-length bv) c0)]
[c1 (($port-read! p) bv c0 max)])
(unless (fixnum? c1)
@ -639,14 +634,14 @@
c1]
[else
(die who "read! returned a value out of range" c1)])))))
(define (get-char-latin-mode p who idx)
(let ([n (refill-bv-start p who)])
(define (get-char-latin-mode p who inc)
(let ([n (refill-bv-buffer p who)])
(cond
[(fx= n 0) (eof-object)]
[else
($set-port-index! p idx)
(integer->char (bytevector-u8-ref ($port-buffer p) 0))])))
(let ([idx ($port-index p)])
($set-port-index! p (fx+ idx inc))
(integer->char (bytevector-u8-ref ($port-buffer p) idx)))])))
(define (get-char-utf8-mode p who)
(define (do-error p who)
(case (transcoder-error-handling-mode ($port-transcoder p))

2
scheme/last-revision
View File

@ -1 +1 @@
1259
1260

3
scheme/makefile.ss
View File

@ -1301,6 +1301,9 @@
[$set-port-size! $io]
[$port-attrs $io]
[$set-port-attrs! $io]
[$port-position $io]
[$set-port-position! $io]
[input-port-byte-position i]
;;;
[&condition-rtd]
[&condition-rcd]

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

@ -1797,6 +1797,8 @@
[(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))])
(define-primop $port-cookie unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-cookie vector-tag)))])
(define-primop $port-position unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-position vector-tag)))])
(define-primop $port-attrs unsafe
[(V x)
(prm 'sra
@ -1818,6 +1820,8 @@
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
(define-primop $set-port-size! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i))])
(define-primop $set-port-position! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-position vector-tag)) (T i))])
(define-primop $set-port-attrs! unsafe
[(E x i)
(prm 'mset (T x)