input ports now support "input-port-column-number" and
"input-port-row-number". These currently work for string ports, latin-1 ports, and utf-8 ports as long as only ascii chars are read.
This commit is contained in:
parent
9e764c76b4
commit
7961405db7
|
@ -63,6 +63,7 @@
|
||||||
reset-output-port!
|
reset-output-port!
|
||||||
port-id
|
port-id
|
||||||
input-port-byte-position
|
input-port-byte-position
|
||||||
|
input-port-column-number input-port-row-number
|
||||||
process process-nonblocking
|
process process-nonblocking
|
||||||
|
|
||||||
tcp-connect tcp-connect-nonblocking
|
tcp-connect tcp-connect-nonblocking
|
||||||
|
@ -133,6 +134,7 @@
|
||||||
close-tcp-server-socket
|
close-tcp-server-socket
|
||||||
register-callback
|
register-callback
|
||||||
input-socket-buffer-size output-socket-buffer-size
|
input-socket-buffer-size output-socket-buffer-size
|
||||||
|
input-port-column-number input-port-row-number
|
||||||
|
|
||||||
open-directory-stream directory-stream?
|
open-directory-stream directory-stream?
|
||||||
read-directory-stream close-directory-stream
|
read-directory-stream close-directory-stream
|
||||||
|
@ -256,9 +258,9 @@
|
||||||
(import (ikarus system $fx))
|
(import (ikarus system $fx))
|
||||||
($fxlogand ($port-tag x) fast-attrs-mask))))
|
($fxlogand ($port-tag x) fast-attrs-mask))))
|
||||||
|
|
||||||
(define-struct cookie (dest mode pos reader))
|
(define-struct cookie (dest mode pos row-num newline-pos))
|
||||||
|
|
||||||
(define (default-cookie fd) (make-cookie fd 'ikarus-mode 0 #f))
|
(define (default-cookie fd) (make-cookie fd 'ikarus-mode 0 0 0))
|
||||||
|
|
||||||
(define (port-id p)
|
(define (port-id p)
|
||||||
(if (port? p)
|
(if (port? p)
|
||||||
|
@ -271,6 +273,25 @@
|
||||||
(+ (cookie-pos cookie) (fx+ ($port-index p) 1)))
|
(+ (cookie-pos cookie) (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 (mark/return-newline p)
|
||||||
|
(let ([cookie ($port-cookie p)])
|
||||||
|
(set-cookie-row-num! cookie (+ (cookie-row-num cookie) 1))
|
||||||
|
(set-cookie-newline-pos! cookie
|
||||||
|
(+ (cookie-pos cookie) ($port-index p))))
|
||||||
|
#\newline)
|
||||||
|
|
||||||
|
(define (input-port-column-number p)
|
||||||
|
(if (input-port? p)
|
||||||
|
(let ([cookie ($port-cookie p)])
|
||||||
|
(- (+ (cookie-pos cookie) ($port-index p))
|
||||||
|
(cookie-newline-pos cookie)))
|
||||||
|
(die 'input-port-column-number "not an input port" p)))
|
||||||
|
|
||||||
|
(define (input-port-row-number p)
|
||||||
|
(if (input-port? p)
|
||||||
|
(cookie-row-num ($port-cookie p))
|
||||||
|
(die 'input-port-row-number "not an input port" p)))
|
||||||
|
|
||||||
(define (port-position p)
|
(define (port-position p)
|
||||||
(define who 'port-position)
|
(define who 'port-position)
|
||||||
(if (port? p)
|
(if (port? p)
|
||||||
|
@ -1310,7 +1331,9 @@
|
||||||
(cond
|
(cond
|
||||||
[(fx< b 128)
|
[(fx< b 128)
|
||||||
($set-port-index! p (fx+ i 1))
|
($set-port-index! p (fx+ i 1))
|
||||||
(integer->char b)]
|
(if (eqv? b (char->integer #\newline))
|
||||||
|
(mark/return-newline p)
|
||||||
|
(integer->char b))]
|
||||||
[else (get-char-utf8-mode p who)]))]
|
[else (get-char-utf8-mode p who)]))]
|
||||||
[else
|
[else
|
||||||
(get-char-utf8-mode p who)]))]
|
(get-char-utf8-mode p who)]))]
|
||||||
|
@ -1319,15 +1342,20 @@
|
||||||
(cond
|
(cond
|
||||||
[(fx< i ($port-size p))
|
[(fx< i ($port-size p))
|
||||||
($set-port-index! p (fx+ i 1))
|
($set-port-index! p (fx+ i 1))
|
||||||
(string-ref ($port-buffer p) i)]
|
(let ([c (string-ref ($port-buffer p) i)])
|
||||||
|
(if (eqv? c #\newline)
|
||||||
|
(mark/return-newline p)
|
||||||
|
c))]
|
||||||
[else (get-char-char-mode p who)]))]
|
[else (get-char-char-mode p who)]))]
|
||||||
[(eq? m fast-get-latin-tag)
|
[(eq? m fast-get-latin-tag)
|
||||||
(let ([i ($port-index p)])
|
(let ([i ($port-index p)])
|
||||||
(cond
|
(cond
|
||||||
[(fx< i ($port-size p))
|
[(fx< i ($port-size p))
|
||||||
($set-port-index! p (fx+ i 1))
|
($set-port-index! p (fx+ i 1))
|
||||||
(integer->char
|
(let ([b (bytevector-u8-ref ($port-buffer p) i)])
|
||||||
(bytevector-u8-ref ($port-buffer p) i))]
|
(if (eqv? b (char->integer #\newline))
|
||||||
|
(mark/return-newline p)
|
||||||
|
(integer->char b)))]
|
||||||
[else
|
[else
|
||||||
(get-char-latin-mode p who 1)]))]
|
(get-char-latin-mode p who 1)]))]
|
||||||
[(eq? m fast-get-utf16le-tag) (get-utf16 p who 'little)]
|
[(eq? m fast-get-utf16le-tag) (get-utf16 p who 'little)]
|
||||||
|
@ -1337,6 +1365,7 @@
|
||||||
(eof-object)
|
(eof-object)
|
||||||
(do-get-char p who))]))))
|
(do-get-char p who))]))))
|
||||||
|
|
||||||
|
|
||||||
;;; ----------------------------------------------------------
|
;;; ----------------------------------------------------------
|
||||||
(define (assert-binary-input-port p who)
|
(define (assert-binary-input-port p who)
|
||||||
(unless (port? p) (die who "not a port" p))
|
(unless (port? p) (die who "not a port" p))
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1827
|
1828
|
||||||
|
|
|
@ -1204,6 +1204,8 @@
|
||||||
[port-has-port-position? i r ip]
|
[port-has-port-position? i r ip]
|
||||||
[port-has-set-port-position!? i r ip]
|
[port-has-set-port-position!? i r ip]
|
||||||
[port-position i r ip]
|
[port-position i r ip]
|
||||||
|
[input-port-column-number i]
|
||||||
|
[input-port-row-number i]
|
||||||
[port-transcoder i r ip]
|
[port-transcoder i r ip]
|
||||||
[port? i r ip]
|
[port? i r ip]
|
||||||
[put-bytevector i r ip]
|
[put-bytevector i r ip]
|
||||||
|
|
Loading…
Reference in New Issue