string-input-ports in new IO work now.

lab/io-spec.ss

@@ -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
+               [else (get-char-char-mode p who)]))]
-                (get-char-char-mode p who)]))]
           [(eq? m fast-get-latin-tag)
            (let ([i ($port-index p)])
              (cond

lab/io-test.ss

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