~ chicken-core (chicken-5) 5b62a076ff6dce3faa2f979e33290bbd0197d44f
commit 5b62a076ff6dce3faa2f979e33290bbd0197d44f
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Fri May 2 12:47:22 2014 +0200
Commit: Christian Kellermann <ck@pestilenz.org>
CommitDate: Mon May 12 12:02:16 2014 +0200
Allow negative arguments to set-file-position! for seek/cur. This is done by ignoring the argument altogether, and letting POSIX handle the error instead.
Thanks to Seth Alves for reporting the restriction.
Also move several duplicated file position accessor procedures from
posixwin and posixunix to posix-common.
Signed-off-by: Christian Kellermann <ck@pestilenz.org>
diff --git a/NEWS b/NEWS
index 3ddaa965..719eaba5 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,10 @@
- Unit lolevel:
- Restore long-lost but still documented "vector-like?" procedure (#983)
+- Unit "posix":
+ - set-file-position! now allows negative positions for seek/cur (thanks
+ to Seth Alves).
+
4.9.0
- Security fixes
diff --git a/posix-common.scm b/posix-common.scm
index 0a04ccc2..9bcda4f3 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -96,6 +96,11 @@ static char C_time_string [TIME_STRING_MAXLENGTH + 1];
#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
#define C_foundfile(e,b,l) (C_strlcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name, l), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
+/* It is assumed that 'int' is-a 'long' */
+#define C_ftell(p) C_fix(ftell(C_port_file(p)))
+#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
+#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
+
#ifdef HAVE_SETENV
# define C_unsetenv(s) (unsetenv((char *)C_data_pointer(s)), C_SCHEME_TRUE)
# define C_setenv(x, y) C_fix(setenv((char *)C_data_pointer(x), (char *)C_data_pointer(y), 1))
@@ -295,6 +300,48 @@ EOF
(eq? 'directory (file-type file #f #f)))
+;;; File position access:
+
+(define-foreign-variable _seek_set int "SEEK_SET")
+(define-foreign-variable _seek_cur int "SEEK_CUR")
+(define-foreign-variable _seek_end int "SEEK_END")
+
+(define seek/set _seek_set)
+(define seek/end _seek_end)
+(define seek/cur _seek_cur)
+
+(define set-file-position!
+ (lambda (port pos . whence)
+ (let ((whence (if (pair? whence) (car whence) _seek_set)))
+ (##sys#check-exact pos 'set-file-position!)
+ (##sys#check-exact whence 'set-file-position!)
+ (unless (cond ((port? port)
+ (and (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_fseek" port pos whence) ) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port pos whence))
+ (else
+ (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
+ (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
+
+(define file-position
+ (getter-with-setter
+ (lambda (port)
+ (let ((pos (cond ((port? port)
+ (if (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_ftell" port)
+ -1) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port 0 _seek_cur) )
+ (else
+ (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
+ (when (< pos 0)
+ (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
+ pos) )
+ set-file-position! ; doesn't accept WHENCE
+ "(file-position port)"))
+
+
;;; Using file-descriptors:
(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
diff --git a/posixunix.scm b/posixunix.scm
index 224e9b02..7e0a71ba 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -266,11 +266,6 @@ static C_TLS sigset_t C_sigset;
#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))
-/* It is assumed that 'int' is-a 'long' */
-#define C_ftell(p) C_fix(ftell(C_port_file(p)))
-#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
-#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
-
#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
#if defined(__SVR4) || defined(C_MACOSX) || defined(__ANDROID__) || defined(_AIX)
@@ -614,50 +609,6 @@ EOF
(and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl)))))))))
-;;; File attribute access:
-
-(define-foreign-variable _seek_set int "SEEK_SET")
-(define-foreign-variable _seek_cur int "SEEK_CUR")
-(define-foreign-variable _seek_end int "SEEK_END")
-
-(define seek/set _seek_set)
-(define seek/end _seek_end)
-(define seek/cur _seek_cur)
-
-(define set-file-position!
- (lambda (port pos . whence)
- (let ((whence (if (pair? whence) (car whence) _seek_set)))
- (##sys#check-exact pos 'set-file-position!)
- (##sys#check-exact whence 'set-file-position!)
- (when (negative? pos)
- (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
- (unless (cond ((port? port)
- (and (eq? (##sys#slot port 7) 'stream)
- (##core#inline "C_fseek" port pos whence) ) )
- ((fixnum? port)
- (##core#inline "C_lseek" port pos whence))
- (else
- (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
- (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
-
-(define file-position
- (getter-with-setter
- (lambda (port)
- (let ((pos (cond ((port? port)
- (if (eq? (##sys#slot port 7) 'stream)
- (##core#inline "C_ftell" port)
- -1) )
- ((fixnum? port)
- (##core#inline "C_lseek" port 0 _seek_cur) )
- (else
- (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
- (when (< pos 0)
- (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
- pos) )
- set-file-position! ; doesn't accept WHENCE
- "(file-position port)"))
-
-
;;; Directory stuff:
(define-inline (*create-directory loc name)
diff --git a/posixwin.scm b/posixwin.scm
index 00c86e82..c1778f0f 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -258,11 +258,6 @@ C_free_arg_string(char **where) {
#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
#define C_mkstemp(t) C_fix(mktemp(C_c_string(t)))
-/* It is assumed that 'int' is-a 'long' */
-#define C_ftell(p) C_fix(ftell(C_port_file(p)))
-#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
-#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
-
#define C_flushall() C_fix(_flushall())
#define C_umask(m) C_fix(_umask(C_unfix(m)))
@@ -792,64 +787,6 @@ EOF
(values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
-;;; File attribute access:
-
-(define-foreign-variable _seek_set int "SEEK_SET")
-(define-foreign-variable _seek_cur int "SEEK_CUR")
-(define-foreign-variable _seek_end int "SEEK_END")
-
-(define seek/set _seek_set)
-(define seek/end _seek_end)
-(define seek/cur _seek_cur)
-
-(define (symbolic-link? fname)
- (##sys#check-string fname 'symbolic-link?)
- #f)
-
-(let ((stat-type
- (lambda (name)
- (lambda (fname)
- (##sys#check-string fname name)
- #f))))
- (set! character-device? (stat-type 'character-device?))
- (set! block-device? (stat-type 'block-device?))
- (set! fifo? (stat-type 'fifo?))
- (set! socket? (stat-type 'socket?)))
-
-(define set-file-position!
- (lambda (port pos . whence)
- (let ((whence (if (pair? whence) (car whence) _seek_set)))
- (##sys#check-exact pos 'set-file-position!)
- (##sys#check-exact whence 'set-file-position!)
- (when (negative? pos)
- (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
- (unless (cond ((port? port)
- (and (eq? (##sys#slot port 7) 'stream)
- (##core#inline "C_fseek" port pos whence) ) )
- ((fixnum? port)
- (##core#inline "C_lseek" port pos whence))
- (else
- (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
- (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
-
-(define file-position
- (getter-with-setter
- (lambda (port)
- (let ((pos (cond ((port? port)
- (if (eq? (##sys#slot port 7) 'stream)
- (##core#inline "C_ftell" port)
- -1) )
- ((fixnum? port)
- (##core#inline "C_lseek" port 0 _seek_cur))
- (else
- (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
- (when (< pos 0)
- (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
- pos) )
- set-file-position!
- "(file-position port)") ) ; doesn't accept WHENCE
-
-
;;; Directory stuff:
(define-inline (create-directory-helper name)
Trap