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:
Abdulaziz Ghuloum 2009-07-23 16:35:05 +03:00
parent 9e764c76b4
commit 7961405db7
3 changed files with 38 additions and 7 deletions

View File

@ -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))

View File

@ -1 +1 @@
1827 1828

View File

@ -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]