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

string-input-ports in new IO work now.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-07 07:39:17 -05:00
parent 39e5c98476
commit 515101d188
2 changed files with 83 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
lab/io-spec.ss
View File

@ -109,6 +109,22 @@
#f ;;; close
)]))
(define (open-string-input-port str)
(unless (string? str)
(error 'open-string-input-port str))
($make-port 0 (string-length str) str 0
#t
#f ;;; closed?
(fxior fast-get-tag fast-get-char-tag)
"*string-input-port*"
(lambda (str i c) 0) ;;; read!
#f ;;; write!
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f ;;; close
))
(define (transcoded-port p transcoder)
(define who 'transcoded-port)
(unless (transcoder? transcoder)
@ -396,7 +412,6 @@
[else (get-char-utf8-mode p who)]))])]
[else (do-error p who)]))])))
(define-rrr get-char-char-mode)
(define (advance-utf8-bom p who)
(let ([i ($port-index p)]
@ -434,7 +449,21 @@
(define-rrr slow-lookahead-char)
(define-rrr lookahead-char-char-mode)
(define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(error who "invalid return value from read!" n))
(unless (<= 0 n (fxsub1 (string-length str)))
(error who "return value from read! is out of range" n))
($set-port-index! p 0)
($set-port-size! p n)
(cond
[(fx= n 0)
(eof-object)]
[else
(string-ref str 0)]))))
;;;
(define (lookahead-char p)
(define who 'lookahead-char)
@ -469,6 +498,23 @@
(speedup-input-port p who)
(lookahead-char p)])))
;;;
(define (get-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(error who "invalid return value from read!" n))
(unless (<= 0 n (fxsub1 (string-length str)))
(error who "return value from read! is out of range" n))
($set-port-size! p n)
(cond
[(fx= n 0)
($set-port-index! p 0)
(eof-object)]
[else
($set-port-index! p 1)
(string-ref str 0)]))))
(define (get-char p)
(define who 'get-char)
(let ([m ($port-get-mode p)])
@ -491,8 +537,7 @@
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(string-ref ($port-buffer p) i)]
[else
(get-char-char-mode p who)]))]
[else (get-char-char-mode p who)]))]
[(eq? m fast-get-latin-tag)
(let ([i ($port-index p)])
(cond

35
lab/io-test.ss
View File

@ -1,7 +1,8 @@
#!/usr/bin/env scheme-script
(import
(except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?)
(except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?
open-string-input-port)
(io-spec))
(define-syntax test
@ -329,6 +330,38 @@
(make-transcoder (utf-8-codec) 'none 'raise))
(make-utf8-string-range4)))
(test "utf8 range 2 string"
(test-port-string-output
(open-string-input-port (make-utf8-string-range2))
(make-utf8-string-range2)))
(test "utf8 range 3 string"
(test-port-string-output
(open-string-input-port (make-utf8-string-range3))
(make-utf8-string-range3)))
(test "utf8 range 4 string"
(test-port-string-output
(open-string-input-port (make-utf8-string-range4))
(make-utf8-string-range4)))
(test "utf8 peek range 2 string"
(test-port-string-peeking-output
(open-string-input-port (make-utf8-string-range2))
(make-utf8-string-range2)))
(test "utf8 peek range 3 string"
(test-port-string-peeking-output
(open-string-input-port (make-utf8-string-range3))
(make-utf8-string-range3)))
(test "utf8 peek range 4 string"
(test-port-string-peeking-output
(open-string-input-port (make-utf8-string-range4))
(make-utf8-string-range4)))