Seekable IO Interface (#1097)

Adds seekable interface and implementation for file io

src/std/io/file-test.ss

@@ -63,4 +63,28 @@
            (check (BufferedWriter-write bwr (string->utf8 text)) => text-length)
            (BufferedWriter-close bwr))
          ;; read the file and make sure it matches the expected text
-         (check (read-file-string tmp) => text))))))
+         (check (read-file-string tmp) => text))))
+
+    (test-case "file seek"
+      (call-with-temporary-file-name "text"
+        (lambda (tmp)
+          (let* ((wr (open-file-writer tmp))
+                 (re (open-file-reader tmp))
+                 (buf (make-u8vector 3)))
+            (Seeker-seek wr 8)
+            (check (Writer-write wr #u8(1 123 255)) => 3)
+            (Reader-read re buf)
+            (check buf => #u8(0 0 0))
+            (Seeker-seek re 8)
+            (Reader-read re buf)
+            (check buf => #u8(1 123 255))
+            (Seeker-seek wr -1 'current)
+            (Writer-write wr #u8(55))
+            (Seeker-seek re 8)
+            (Reader-read re buf)
+            (check buf => #u8(1 123 55))
+            (Seeker-seek re -3 'current)
+            (Seeker-seek wr -2 'current)
+            (Writer-write wr #u8(6))
+            (Reader-read re buf)
+            (check buf => #u8(1 6 55))))))))

src/std/io/file.ss

@@ -53,7 +53,7 @@
       (let (fd self.fd)
         (let lp ((input-start input-start) (result 0))
           (when self.closed?
-            (raise-io-closed file-io-wrte "file is closed"))
+            (raise-io-closed output-file-io "file is closed"))
           (if (fx< input-start input-end)
             (let (wrote (fdwrite fd input input-start input-end))
               (cond
@@ -71,6 +71,13 @@
         (set! self.closed? #t)
         (close-port self.fd)))))
 
+(defmethod {seek file-io}
+  (lambda (self position from)
+    (using (self :- file-io)
+      (when self.closed?
+        (raise-io-closed file-io "file is closed"))
+      (fdseek self.fd position from))))
+
 (defrule (open-file-io path flags mode make)
   (let (fd (open path flags mode))
     (make fd #f)))

src/std/io/interface.ss

@@ -11,6 +11,16 @@
 (interface Closer
   (close))
 
+;; Cursor-based IO
+(interface Seeker
+  ;; Seek to a particular position in the backing IO source.
+  ;; - position denotes where, relative to `from` that the cursor should be moved to.
+  ;;   When `'start` is supplied, `position` must be positive.
+  ;;   When `'end` `'current` is supplied, `position` may be positive or negative
+  ;; - from is one of 3 possible origins to seek about. Defaults to `'start`.
+  (seek (position :~ fixnum?)
+        (from :~ whence? := 'start)))
+
 ;; generic binary IO
 (interface (Reader Closer)
   ;; read into a buffer; it _must_ be a u8vector.
@@ -216,3 +226,6 @@
   (lambda (o)
     (or (type? o)
         ((list-of? type?) o))))
+
+(defrule (whence? p)
+  (cut <> memq '(start end current)))

src/std/os/fdio.ss

@@ -43,6 +43,23 @@
     (do-retry-nonblock (_close raw)
       (close raw))))
 
+(def (fdsync raw)
+  (if (fd? raw)
+    (let (fd (if (fd? raw) (fd-e raw) raw))
+      (check-os-error (_fsync fd)
+        (fdsync raw)))))
+
+; TODO: this should probably use the port position functions instead of C FFI
+(def (fdseek raw position from)
+  (let ((fd (if (fd? raw) (fd-e raw) raw))
+        (whence (case from
+                  ((start) SEEK_SET)
+                  ((current) SEEK_CUR)
+                  ((end) SEEK_END)
+                  (else (error "Unknown from to seek about" from)))))
+    (check-os-error (_seek fd position whence)
+      (seek fd position whence))))
+
 (def (file-direction flags)
   (cond
    ((##fx= (##fxand flags O_RDWR) O_RDWR)
@@ -55,10 +72,11 @@
     (raise-bad-argument fdio "file direction: unspecified" flags))))
 
 ;;; FFI impl
-(begin-ffi (_read _write _open _close
+(begin-ffi (_read _write _open _close _seek _fsync
             S_IRWXU S_IWUSR S_IRUSR S_IXUSR
             S_IRWXG S_IRGRP S_IWGRP S_IXGRP
-            S_IRWXO S_IROTH S_IWOTH S_IXOTH)
+            S_IRWXO S_IROTH S_IWOTH S_IXOTH
+            SEEK_SET SEEK_CUR SEEK_END)
 
   (c-declare "#include <unistd.h>")
   (c-declare "#include <sys/types.h>")
@@ -77,9 +95,12 @@
   (define-const S_IROTH)
   (define-const S_IWOTH)
   (define-const S_IXOTH)
+  (define-const SEEK_SET)
+  (define-const SEEK_CUR)
+  (define-const SEEK_END)
 
   ;; private
-  (namespace ("std/os/fdio#" __read __write __open __close))
+  (namespace ("std/os/fdio#" __read __write __open __close __seek __fsync))
 
   (c-declare "static int ffi_fdio_read (int fd, ___SCMOBJ bytes, int start, int end);")
   (c-declare "static int ffi_fdio_write (int fd, ___SCMOBJ bytes, int start, int end);")
@@ -92,10 +113,16 @@
     "open")
   (define-c-lambda __close (int) int
     "close")
+  (define-c-lambda __fsync (int) int
+    "fsync")
+  (define-c-lambda __seek (int int int) int
+    "lseek")
 
   (define-with-errno _read __read (fd bytes start end))
   (define-with-errno _write __write (fd bytes start end))
   (define-with-errno _open __open (path flags mode))
+  (define-with-errno _seek __seek (fd offset whence))
+  (define-with-errno _fsync __fsync (fd))
   (define-with-errno _close __close (fd))
 
   (c-declare #<<END-C