added set-port-position! for binary input files.

scheme/ikarus.io.ss

@@ -282,11 +282,10 @@
 
   (define (set-port-position! p pos)
     (define who 'set-port-position!)
-    (define (set-input-port-position! p pos) (error who "not yet"))
+    (define (set-position! p pos flush?)
-    (define (set-output-port-position! p pos)
       (let ([setpos! ($port-set-position! p)])
         (unless setpos! (die who "port does not support port position" p))
-        (flush-output-port p)
+        (when flush? (flush-output-port p))
         (setpos! pos) 
         ($set-port-index! p 0)
         ($set-port-size! p 0)
@@ -295,8 +294,8 @@
     (unless (and (or (fixnum? pos) (bignum? pos)) (>= pos 0))
       (die who "position must be a nonnegative exact integer" pos))
     (cond
-      [(output-port? p) (set-output-port-position! p pos)]
+      [(output-port? p) (set-position! p pos #t)]
-      [(input-port? p) (set-input-port-position! p pos)]
+      [(input-port? p)  (set-position! p pos #f)]
       [else (die who "not a port" p)]))
 
 
@@ -1421,6 +1420,13 @@
               "buffer size should be a positive fixnum"
               x)))))
 
+  (define (make-file-set-position-handler fd id)
+    (lambda (pos) ;;; set-position!
+      (let ([err (foreign-call "ikrt_set_position" fd pos)])
+        (when err
+          (io-error 'set-position! id err
+             (make-i/o-invalid-position-error pos))))))
+
   (define (fh->input-port fd id size transcoder close who)
     (letrec ([port
               ($make-port 
@@ -1450,7 +1456,7 @@
                   refill)
                 #f ;;; write!
                 #t ;;; get-position
-                #f ;;; set-position!
+                (make-file-set-position-handler fd id)
                 (cond
                   [(procedure? close) close]
                   [(eqv? close #t) (file-close-proc id fd)]
@@ -1459,6 +1465,7 @@
                 (vector 0))])
     (guarded-port port)))
 
+
   (define (fh->output-port fd id size transcoder close who)
     (letrec ([port
               ($make-port 
@@ -1489,11 +1496,7 @@
                                     (make-i/o-write-error))])))])
                   refill)
                 #t ;;; get-position
-                (lambda (pos) ;;; set-position!
+                (make-file-set-position-handler fd id)
-                  (let ([err (foreign-call "ikrt_set_position" fd pos)])
-                    (when err
-                      (io-error 'set-position! id err 
-                         (make-i/o-invalid-position-error pos)))))
                 (cond
                   [(procedure? close) close]
                   [(eqv? close #t) (file-close-proc id fd)]

scheme/last-revision

@@ -1 +1 @@
-1708
+1709

scheme/tests/set-position.ss

@@ -4,30 +4,47 @@
   (import (ikarus))
 
   (define fname "temp-test-file")
+  (define pos-list '([500 12] [720 34] [12  180] [400 4]))
+
+  (define (write-bytes)
+    (when (file-exists? fname) (delete-file fname))
+    (let ([p (open-file-output-port fname)])
+      (for-each
+        (lambda (x)
+          (set-port-position! p (car x))
+          (put-u8 p (cadr x)))
+        pos-list)
+      (close-output-port p)))
+
+  (define (get-bytes)
+    (let ([p (open-file-input-port fname)])
+      (let ([bv (get-bytevector-all p)])
+        (close-input-port p)
+        bv)))
 
   (define (test-setting-position-for-binary-output-files)
-    (let ([pos-list '([500 12] [720 34] [12  180] [400 4])])
+    (write-bytes)
-      (when (file-exists? fname) (delete-file fname))
+    (let ([bv (get-bytes)])
-      (let ([p (open-file-output-port fname)])
+      (assert (= (bytevector-length bv)
-        (for-each
+                 (add1 (apply max (map car pos-list)))))
-          (lambda (x)
+      (for-each 
-            (set-port-position! p (car x))
+        (lambda (x)
-            (put-u8 p (cadr x)))
+          (assert (= (bytevector-u8-ref bv (car x)) (cadr x))))
-          pos-list)
+        pos-list))
-        (close-output-port p))
+    (delete-file fname))
-      (let ([bv 
+
-             (let ([p (open-file-input-port fname)])
+  (define (test-setting-position-for-binary-input-files)
-               (let ([bv (get-bytevector-all p)])
+    (write-bytes)
-                 (close-input-port p)
+    (let ([p (open-file-input-port fname)])
-                 bv))])
+      (define (check-pos x)
-        (assert (= (bytevector-length bv)
+        (set-port-position! p (car x))
-                   (add1 (apply max (map car pos-list)))))
+        (assert (= (get-u8 p) (cadr x))))
-        (for-each 
+      (for-each check-pos pos-list)
-          (lambda (x)
+      (for-each check-pos (reverse pos-list))
-            (assert (= (bytevector-u8-ref bv (car x)) (cadr x))))
+      (close-input-port p))
-          pos-list))
+    (delete-file fname))
-      (delete-file fname)))
 
   (define (run-tests)
-    (test-setting-position-for-binary-output-files)))
+    (test-setting-position-for-binary-output-files)
+    (test-setting-position-for-binary-input-files)))