From aba76624b26844def85c3d44334db86a74c33088 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 9 Dec 2008 03:00:44 -0500
Subject: [PATCH] added set-port-position! for binary output files.

---
 scheme/ikarus.io.ss                  | 44 +++++++++++++++++++++++-----
 scheme/ikarus.not-yet-implemented.ss | 12 ++------
 scheme/last-revision                 |  2 +-
 scheme/run-tests.ss                  |  2 +-
 scheme/tests/set-position.ss         | 33 +++++++++++++++++++++
 src/ikarus-data.h                    |  1 +
 src/ikarus-io.c                      | 12 ++++++++
 7 files changed, 88 insertions(+), 18 deletions(-)
 create mode 100644 scheme/tests/set-position.ss

diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 3838b3b..f4eee39 100644
--- a/scheme/ikarus.io.ss
+++ b/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-set-port-position!? set-port-position!
+    port-position port-has-port-position? 
+    set-port-position! port-has-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-set-port-position!? set-port-position!
+      port-position port-has-port-position? 
+      set-port-position! port-has-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)]
diff --git a/scheme/ikarus.not-yet-implemented.ss b/scheme/ikarus.not-yet-implemented.ss
index 88965e0..446b425 100644
--- a/scheme/ikarus.not-yet-implemented.ss
+++ b/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!?
-    set-port-position!  
-    equal-hash
-    )
+    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!?
-    set-port-position! 
-    equal-hash
-    ))
+    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!  ))
+    ))
 
 
diff --git a/scheme/last-revision b/scheme/last-revision
index 31afa2f..5ceb2bc 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1707
+1708
diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss
index 77ab1c5..ac38dfb 100755
--- a/scheme/run-tests.ss
+++ b/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)
diff --git a/scheme/tests/set-position.ss b/scheme/tests/set-position.ss
new file mode 100644
index 0000000..532d5a9
--- /dev/null
+++ b/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)))
+
diff --git a/src/ikarus-data.h b/src/ikarus-data.h
index e7b88be..a0602b6 100644
--- a/src/ikarus-data.h
+++ b/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 */
diff --git a/src/ikarus-io.c b/src/ikarus-io.c
index 86f7084..5ce0802 100644
--- a/src/ikarus-io.c
+++ b/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);