Chez Scheme: allowing loading from input paths that do not support seeking

Based on the approach by @rmolives in cisco/ChezScheme#966

Author: mflatt

racket/src/ChezScheme/c/externs.h

@@ -266,6 +266,7 @@ extern ptr S_put_byte(ptr file, INT byte, IBOOL gzflag);
 
 extern ptr S_get_fd_pos(ptr file, IBOOL gzflag);
 extern ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag);
+extern ptr S_fd_can_set_pos(ptr file);
 extern ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag);
 extern ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag);
 extern ptr S_get_fd_length(ptr file, IBOOL gzflag);

racket/src/ChezScheme/c/new-io.c

@@ -703,6 +703,20 @@ ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) {
   }
 }
 
+ptr S_fd_can_set_pos(ptr file) {
+  OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR);
+
+  if (offset != -1) {
+    if (LSEEK(GET_FD(file), offset, SEEK_SET) == offset)
+      return Strue;
+  }
+
+  if (errno == ESPIPE)
+    return Sfalse;
+
+  return S_strerror(errno);
+}
+
 ptr S_get_fd_non_blocking(WIN32_UNUSED ptr file, WIN32_UNUSED IBOOL gzflag) {
 #ifdef WIN32
   return Sfalse;

racket/src/ChezScheme/c/prim5.c

@@ -1828,6 +1828,7 @@ void S_prim5_init(void) {
     Sforeign_symbol("(cs)put_byte", (void*)S_put_byte);
     Sforeign_symbol("(cs)get_fd_pos", (void*)S_get_fd_pos);
     Sforeign_symbol("(cs)set_fd_pos", (void*)S_set_fd_pos);
+    Sforeign_symbol("(cs)fd_can_set_position", (void*)S_fd_can_set_pos);
     Sforeign_symbol("(cs)get_fd_non_blocking", (void*)S_get_fd_non_blocking);
     Sforeign_symbol("(cs)set_fd_non_blocking", (void*)S_set_fd_non_blocking);
     Sforeign_symbol("(cs)get_fd_length", (void*)S_get_fd_length);

racket/src/ChezScheme/s/7.ss

@@ -305,7 +305,12 @@
     (lambda (x) (run-outer x)))
 
   (define (do-load who fn situation for-import? importer ksrc)
-    (let ([ip ($open-file-input-port who fn)])
+    (let* ([file-ip ($open-file-input-port who fn)]
+           [ip (if ($fd-input-port-can-set-position? file-ip)
+                   file-ip
+                   (let ([bv-ip (open-bytevector-input-port (get-bytevector-all file-ip))])
+                     (close-port file-ip)
+                     bv-ip))])
       (on-reset (close-port ip)
         (let ([fp (let ([start-pos (port-position ip)])
                     (if (and (eqv? (get-u8 ip) (char->integer #\#))

racket/src/ChezScheme/s/io.ss

@@ -310,6 +310,9 @@ implementation notes:
   (define $get-fd-pos
     (foreign-procedure "(cs)get_fd_pos"
       (scheme-object boolean) scheme-object))
+  (define $fd-can-set-position
+    (foreign-procedure "(cs)fd_can_set_position"
+      (scheme-object) scheme-object))
   (define $get-fd-nonblocking
     (foreign-procedure "(cs)get_fd_non_blocking"
       (scheme-object boolean) scheme-object))
@@ -3259,6 +3262,13 @@ implementation notes:
                (transcoded-port binary-port maybe-transcoder)
                binary-port))]))
 
+    (set-who! $fd-input-port-can-set-position?
+      (lambda (ip)
+        (let ([r ($fd-can-set-position ($port-info ip))])
+          (if (boolean? r)
+              r
+              (port-oops who ip r)))))
+
     (let ()
       (define s-process (foreign-procedure "(cs)s_process" (string boolean) scheme-object))
       (define (subprocess-port who what fd pid b-mode maybe-transcoder)

racket/src/ChezScheme/s/primdata.ss

@@ -2016,6 +2016,7 @@
   ($fasl-table [flags single-valued])
   ($fasl-to-vfasl [flags single-valued])
   ($fasl-wrf-graph [flags single-valued])
+  ($fd-input-port-can-set-position? [flags single-valued])
   ($filter-conv [flags single-valued])
   ($filter-foreign-type [flags single-valued])
   ($fixed-path? [sig [(string) -> (boolean)]] [flags pure safeongoodargs])