added set-port-position! for string and bytevector input ports.

scheme/ikarus.io.ss

@@ -286,13 +286,20 @@
     (define who 'set-port-position!)
     (define (set-position! p pos flush?)
       (let ([setpos! ($port-set-position! p)])
-        (unless setpos! (die who "port does not support port position" p))
+        (cond
+          [(procedure? setpos!)
            (when flush? (flush-output-port p))
            (setpos! pos)
            ($set-port-index! p 0)
            ($set-port-size! p 0)
            (let ([pos-vec ($port-position p)])
-          (vector-set! pos-vec 0 pos))))
+             (vector-set! pos-vec 0 pos))]
+          [(eqv? setpos! #t)
+           (if (<= pos ($port-size p))
+               ($set-port-index! p pos)
+               (die who "position out of range" pos))]
+          [else
+           (die who "port does not support port position" p)])))
     (unless (and (or (fixnum? pos) (bignum? pos)) (>= pos 0))
       (die who "position must be a nonnegative exact integer" pos))
     (cond
@@ -474,7 +481,7 @@
           (lambda (bv i c) 0) ;;; read!
           #f ;;; write!
           #t ;;; get-position
-          #f ;;; set-position!
+          #t ;;; set-position!
           #f ;;; close
           #f
           (vector 0))]))
@@ -644,7 +651,7 @@
        (lambda (str i c) 0) ;;; read!
        #f ;;; write!
        #t ;;; get-position
-       #f ;;; set-position!
+       #t ;;; set-position!
        #f ;;; close
        #f ;;; cookie
        (vector 0)))

scheme/last-revision

@@ -1 +1 @@
-1711
+1712

scheme/tests/set-position.ss

@@ -47,7 +47,27 @@
       (close-input-port p))
     (delete-file fname))
 
+  (define (test-fixed-input-ports)
+    (assert (eof-object? 
+              (let ([p (open-string-input-port "Hello")])
+                (set-port-position! p 5) 
+                (get-char p))))
+    (assert (char=? #\o 
+              (let ([p (open-string-input-port "Hello")])
+                (set-port-position! p 4) 
+                (get-char p))))
+    (assert (eof-object? 
+               (let ([p (open-bytevector-input-port #vu8(1 2 3 4 5))])
+                 (set-port-position! p 5)
+                 (get-u8 p))))
+    (assert (= 5
+               (let ([p (open-bytevector-input-port #vu8(1 2 3 4 5))])
+                 (set-port-position! p 4)
+                 (get-u8 p)))))
+
+
   (define (run-tests)
     (test-setting-position-for-binary-output-files)
-    (test-setting-position-for-binary-input-files)))
+    (test-setting-position-for-binary-input-files)
+    (test-fixed-input-ports)))