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

scheme/ikarus.io.ss

@@ -36,9 +36,8 @@
     get-u8 lookahead-u8 
     get-bytevector-n get-bytevector-n!
     get-bytevector-some get-bytevector-all 
-    port-has-port-position? 
+    port-position port-has-port-position? 
-    port-position
+    set-port-position! port-has-set-port-position!? 
-    ;port-has-set-port-position!? set-port-position!
     call-with-port
     flush-output-port
     put-u8 put-bytevector
@@ -96,9 +95,8 @@
       get-u8 lookahead-u8 
       get-bytevector-n get-bytevector-n!
       get-bytevector-some get-bytevector-all 
-      port-has-port-position? 
+      port-position port-has-port-position? 
-      port-position
+      set-port-position! port-has-set-port-position!? 
-      ;port-has-set-port-position!? set-port-position!
       call-with-port
       flush-output-port
       put-u8 put-bytevector
@@ -281,11 +279,39 @@
              (die who "port does not support port-position operation" p)]))
         (die who "not a port" p)))
 
+
+  (define (set-port-position! p pos)
+    (define who 'set-port-position!)
+    (define (set-input-port-position! p pos) (error who "not yet"))
+    (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)
+        (setpos! pos) 
+        ($set-port-index! p 0)
+        ($set-port-size! p 0)
+        (let ([pos-vec ($port-position p)])
+          (vector-set! pos-vec 0 pos))))
+    (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)]
+      [(input-port? p) (set-input-port-position! p pos)]
+      [else (die who "not a port" p)]))
+
+
   (define (port-has-port-position? p)
     (define who 'port-has-port-position?)
     (if (port? p)
         (and ($port-get-position p) #t)
         (die who "not a port" p)))
+
+  (define (port-has-set-port-position!? p)
+    (define who 'port-has-set-port-position!?)
+    (if (port? p)
+        (and ($port-set-position! p) #t)
+        (die who "not a port" p)))
+
    
   (define guarded-port
     (let ([G (make-guardian)])
@@ -1463,7 +1489,11 @@
                                     (make-i/o-write-error))])))])
                   refill)
                 #t ;;; get-position
-                #f ;;; set-position!
+                (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)))))
                 (cond
                   [(procedure? close) close]
                   [(eqv? close #t) (file-close-proc id fd)]

scheme/ikarus.not-yet-implemented.ss

@@ -6,10 +6,7 @@
     make-custom-binary-input/output-port
     make-custom-textual-input/output-port
     open-file-input/output-port output-port-buffer-mode
-    port-has-set-port-position!?
+    equal-hash)
-    set-port-position!  
-    equal-hash
-    )
 
   (import (except (ikarus) 
     bitwise-reverse-bit-field
@@ -17,10 +14,7 @@
     make-custom-binary-input/output-port
     make-custom-textual-input/output-port
     open-file-input/output-port output-port-buffer-mode
-    port-has-set-port-position!?
+    equal-hash))
-    set-port-position! 
-    equal-hash
-    ))
   
   (define-syntax not-yet
     (syntax-rules ()
@@ -55,6 +49,6 @@
     make-custom-textual-input/output-port
     open-file-input/output-port
     output-port-buffer-mode
-    port-has-set-port-position!? set-port-position!  ))
+    ))
 
 

scheme/last-revision

@@ -1 +1 @@
-1707
+1708

scheme/run-tests.ss

@@ -22,7 +22,7 @@
   lists strings bytevectors hashtables fixnums bignums numerics
   bitwise enums pointers sorting io fasl reader case-folding
   parse-flonums string-to-number bignum-to-flonum div-and-mod
-  fldiv-and-mod unicode normalization repl))
+  fldiv-and-mod unicode normalization repl set-position))
 
 (define (run-test-from-library x)
   (printf "[testing ~a] ..." x)

scheme/tests/set-position.ss

@@ -0,0 +1,33 @@
+
+(library (tests set-position)
+  (export run-tests)
+  (import (ikarus))
+
+  (define fname "temp-test-file")
+
+  (define (test-setting-position-for-binary-output-files)
+    (let ([pos-list '([500 12] [720 34] [12  180] [400 4])])
+      (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))
+      (let ([bv 
+             (let ([p (open-file-input-port fname)])
+               (let ([bv (get-bytevector-all p)])
+                 (close-input-port p)
+                 bv))])
+        (assert (= (bytevector-length bv)
+                   (add1 (apply max (map car pos-list)))))
+        (for-each 
+          (lambda (x)
+            (assert (= (bytevector-u8-ref bv (car x)) (cadr x))))
+          pos-list))
+      (delete-file fname)))
+
+  (define (run-tests)
+    (test-setting-position-for-binary-output-files)))
+

src/ikarus-data.h

@@ -213,6 +213,7 @@ ikptr normalize_bignum(long int limbs, int sign, ikptr r);
 ikptr s_to_number(signed long x, ikpcb* pcb);
 ikptr d_to_number(double x, ikpcb* pcb);
 ikptr make_pointer(long x, ikpcb* pcb);
+long long extract_num_longlong(ikptr x);
 
 #define IK_HEAP_EXT_SIZE  (32 * 4096)
 #define IK_HEAPSIZE       (1024 * ((wordsize==4)?1:2) * 4096) /* 4/8 MB */

src/ikarus-io.c

@@ -41,6 +41,18 @@ ikrt_close_fd(ikptr fd /*, ikpcb* pcb */){
   }
 }
 
+ikptr
+ikrt_set_position(ikptr fd, ikptr pos /*, ikpcb* pcb */){
+  off_t offset = extract_num_longlong(pos);
+  off_t err = lseek(unfix(fd), offset, SEEK_SET);
+  if(err == -1){
+    return ik_errno_to_code();
+  } else {
+    return false_object;;
+  }
+}
+
+
 ikptr
 ikrt_open_input_fd(ikptr fn /*, ikpcb* pcb */){
   int fh = open((char*)(long)(fn+off_bytevector_data), O_RDONLY, 0);