input-port-byte-position works for input files.
This commit is contained in:
parent
64e54de392
commit
945e8473fc
Binary file not shown.
|
@ -58,6 +58,7 @@
|
||||||
port-mode set-port-mode!
|
port-mode set-port-mode!
|
||||||
reset-input-port!
|
reset-input-port!
|
||||||
port-id
|
port-id
|
||||||
|
input-port-byte-position
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
|
@ -105,6 +106,7 @@
|
||||||
port-mode set-port-mode!
|
port-mode set-port-mode!
|
||||||
reset-input-port!
|
reset-input-port!
|
||||||
port-id
|
port-id
|
||||||
|
input-port-byte-position
|
||||||
))
|
))
|
||||||
|
|
||||||
(module UNSAFE
|
(module UNSAFE
|
||||||
|
@ -215,6 +217,12 @@
|
||||||
($port-id p)
|
($port-id p)
|
||||||
(die 'port-id "not a port" 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
|
(define guarded-port
|
||||||
(let ([G (make-guardian)])
|
(let ([G (make-guardian)])
|
||||||
(define (clean-up)
|
(define (clean-up)
|
||||||
|
@ -605,27 +613,14 @@
|
||||||
;;; ----------------------------------------------------------
|
;;; ----------------------------------------------------------
|
||||||
(module (read-char get-char lookahead-char)
|
(module (read-char get-char lookahead-char)
|
||||||
(import UNSAFE)
|
(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)
|
(define (refill-bv-buffer p who)
|
||||||
(when ($port-closed? p) (die who "port is closed" p))
|
(when ($port-closed? p) (die who "port is closed" p))
|
||||||
(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)])
|
||||||
(bytevector-copy! bv i bv 0 c0)
|
(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)]
|
(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)
|
||||||
|
@ -639,14 +634,14 @@
|
||||||
c1]
|
c1]
|
||||||
[else
|
[else
|
||||||
(die who "read! returned a value out of range" c1)])))))
|
(die who "read! returned a value out of range" c1)])))))
|
||||||
(define (get-char-latin-mode p who idx)
|
(define (get-char-latin-mode p who inc)
|
||||||
(let ([n (refill-bv-start p who)])
|
(let ([n (refill-bv-buffer p who)])
|
||||||
(cond
|
(cond
|
||||||
[(fx= n 0) (eof-object)]
|
[(fx= n 0) (eof-object)]
|
||||||
[else
|
[else
|
||||||
($set-port-index! p idx)
|
(let ([idx ($port-index p)])
|
||||||
(integer->char (bytevector-u8-ref ($port-buffer p) 0))])))
|
($set-port-index! p (fx+ idx inc))
|
||||||
|
(integer->char (bytevector-u8-ref ($port-buffer p) idx)))])))
|
||||||
(define (get-char-utf8-mode p who)
|
(define (get-char-utf8-mode p who)
|
||||||
(define (do-error p who)
|
(define (do-error p who)
|
||||||
(case (transcoder-error-handling-mode ($port-transcoder p))
|
(case (transcoder-error-handling-mode ($port-transcoder p))
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1259
|
1260
|
||||||
|
|
|
@ -1301,6 +1301,9 @@
|
||||||
[$set-port-size! $io]
|
[$set-port-size! $io]
|
||||||
[$port-attrs $io]
|
[$port-attrs $io]
|
||||||
[$set-port-attrs! $io]
|
[$set-port-attrs! $io]
|
||||||
|
[$port-position $io]
|
||||||
|
[$set-port-position! $io]
|
||||||
|
[input-port-byte-position i]
|
||||||
;;;
|
;;;
|
||||||
[&condition-rtd]
|
[&condition-rtd]
|
||||||
[&condition-rcd]
|
[&condition-rcd]
|
||||||
|
|
|
@ -1797,6 +1797,8 @@
|
||||||
[(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))])
|
[(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))])
|
||||||
(define-primop $port-cookie unsafe
|
(define-primop $port-cookie unsafe
|
||||||
[(V x) (prm 'mref (T x) (K (- disp-port-cookie vector-tag)))])
|
[(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
|
(define-primop $port-attrs unsafe
|
||||||
[(V x)
|
[(V x)
|
||||||
(prm 'sra
|
(prm 'sra
|
||||||
|
@ -1818,6 +1820,8 @@
|
||||||
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
|
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
|
||||||
(define-primop $set-port-size! unsafe
|
(define-primop $set-port-size! unsafe
|
||||||
[(E x i) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i))])
|
[(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
|
(define-primop $set-port-attrs! unsafe
|
||||||
[(E x i)
|
[(E x i)
|
||||||
(prm 'mset (T x)
|
(prm 'mset (T x)
|
||||||
|
|
Loading…
Reference in New Issue