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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
scheme/ikarus.io.ss
View File

@ -63,6 +63,7 @@
reset-output-port!
port-id
input-port-byte-position
input-port-column-number input-port-row-number
process process-nonblocking
tcp-connect tcp-connect-nonblocking
@ -133,6 +134,7 @@
close-tcp-server-socket
register-callback
input-socket-buffer-size output-socket-buffer-size
input-port-column-number input-port-row-number
open-directory-stream directory-stream?
read-directory-stream close-directory-stream
@ -256,9 +258,9 @@
(import (ikarus system $fx))
($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)
(if (port? p)
@ -271,6 +273,25 @@
(+ (cookie-pos cookie) (fx+ ($port-index p) 1)))
(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 who 'port-position)
(if (port? p)
@ -1310,7 +1331,9 @@
(cond
[(fx< b 128)
($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)]))]
@ -1319,15 +1342,20 @@
(cond
[(fx< i ($port-size p))
($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)]))]
[(eq? m fast-get-latin-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(integer->char
(bytevector-u8-ref ($port-buffer p) i))]
(let ([b (bytevector-u8-ref ($port-buffer p) i)])
(if (eqv? b (char->integer #\newline))
(mark/return-newline p)
(integer->char b)))]
[else
(get-char-latin-mode p who 1)]))]
[(eq? m fast-get-utf16le-tag) (get-utf16 p who 'little)]
@ -1337,6 +1365,7 @@
(eof-object)
(do-get-char p who))]))))
;;; ----------------------------------------------------------
(define (assert-binary-input-port p who)
(unless (port? p) (die who "not a port" p))

2
scheme/last-revision
View File

@ -1 +1 @@
1827
1828

2
scheme/makefile.ss
View File

@ -1204,6 +1204,8 @@
[port-has-port-position? i r ip]
[port-has-set-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? i r ip]
[put-bytevector i r ip]