diff --git a/c/externs.h b/c/externs.h index e5a5be697..157b023b1 100644 --- a/c/externs.h +++ b/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); diff --git a/c/new-io.c b/c/new-io.c index e4234f86b..7a0118e70 100644 --- a/c/new-io.c +++ b/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; diff --git a/c/prim5.c b/c/prim5.c index 23692d719..e0fe02ecd 100644 --- a/c/prim5.c +++ b/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); diff --git a/s/7.ss b/s/7.ss index 080bad449..165a82d5c 100644 --- a/s/7.ss +++ b/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 #\#)) diff --git a/s/io.ss b/s/io.ss index 63a5e4085..87d099130 100644 --- a/s/io.ss +++ b/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) diff --git a/s/primdata.ss b/s/primdata.ss index 4aef41181..73d5a05e9 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -2014,6 +2014,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])