Changeset 16117 in project for chicken


Ignore:
Timestamp:
10/02/09 03:23:39 (10 years ago)
Author:
kon
Message:

Fix for file position wider than a fixnum.

Location:
chicken/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/distribution/manifest

    r16091 r16117  
    216216tests/fixnum-tests.scm
    217217tests/path-tests.scm
     218tests/posix-tests.scm
    218219tests/r4rstest.out
    219220tests/port-tests.scm
  • chicken/trunk/posixunix.scm

    r15913 r16117  
    112112#endif
    113113
     114#ifndef FILENAME_MAX
     115# define FILENAME_MAX          1024
     116#endif
     117
    114118static C_TLS char *C_exec_args[ ARG_MAX ];
    115119static C_TLS char *C_exec_env[ ENV_MAX ];
     
    139143#define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
    140144
    141 #define C_opendir(x,h)          C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
    142 #define C_closedir(h)           (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
    143 #define C_readdir(h,e)          C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
    144 #define C_foundfile(e,b)        (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
     145#define C_opendir(x,h)      C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
     146#define C_closedir(h)       (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
     147#define C_readdir(h,e)      C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
     148#define C_foundfile(e,b)    (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
    145149
    146150#define C_curdir(buf)       (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
     
    297301#define C_flock_lockw(p)    C_fix(fcntl(fileno(C_port_file(p)), F_SETLKW, &C_flock))
    298302
    299 #ifndef FILENAME_MAX
    300 # define FILENAME_MAX          1024
    301 #endif
    302 
    303303static C_TLS sigset_t C_sigset;
    304304#define C_sigemptyset(d)    (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)
     
    315315#define C_mkstemp(t)        C_fix(mkstemp(C_c_string(t)))
    316316
    317 #define C_ftell(p)            C_fix(ftell(C_port_file(p)))
    318 #define C_fseek(p, n, w)      C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
    319 #define C_lseek(fd, o, w)     C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
     317/* It is assumed that 'int' is-a 'long' */
     318#define C_ftell(p)          (C_temporary_flonum = ftell(C_port_file(p)), C_SCHEME_UNDEFINED)
     319#define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
     320#define C_ftello(p)         (C_temporary_flonum = ftello(C_port_file(p)), C_SCHEME_UNDEFINED)
     321#define C_fseeko(p, n, w)   C_mk_nbool(fseeko(C_port_file(p), C_num_to_int64(n), C_unfix(w)))
     322#ifdef _POSIX_V6_ILP32_OFF32
     323# define C_ftellX(p)        C_ftell(p)
     324# define C_fseekX(p, n, w)  C_fseek(p, n, w)
     325# define C_lseekX(fd, o, w) (C_temporary_flonum = lseek(C_unfix(fd), C_num_to_int(o), C_unfix(w)), C_SCHEME_UNDEFINED)
     326#else
     327# define C_ftellX(p)        C_ftello(p)
     328# define C_fseekX(p, n, w)  C_fseeko(p, n, w)
     329# define C_lseekX(fd, o, w) (C_temporary_flonum = lseek(C_unfix(fd), C_num_to_int64(o), C_unfix(w)), C_SCHEME_UNDEFINED)
     330#endif
    320331
    321332#define C_zero_fd_set(i)      FD_ZERO(&C_fd_sets[ i ])
     
    832843(define set-file-position!
    833844   (lambda (port pos . whence)
    834      (let ([whence (if (pair? whence) (car whence) _seek_set)])
    835        (##sys#check-exact pos 'set-file-position!)
     845     (let ((whence (if (pair? whence) (car whence) _seek_set)))
     846       (##sys#check-number pos 'set-file-position!)
    836847       (##sys#check-exact whence 'set-file-position!)
    837        (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
    838        (unless (cond [(port? port)
     848       (when (negative? pos)
     849         (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
     850       (unless (cond ((port? port)
    839851                      (and (eq? (##sys#slot port 7) 'stream)
    840                            (##core#inline "C_fseek" port pos whence) ) ]
    841                      [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
    842                      [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
     852                           (##core#inline "C_fseekX" port pos whence) ) )
     853                     ((fixnum? port)
     854                      (##core#inline "C_lseekX" port pos whence))
     855                     (else
     856                      (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
    843857         (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
    844858
     
    846860  (getter-with-setter
    847861   (lambda (port)
    848      (let ([pos (cond [(port? port)
     862     (let ((pos (cond ((port? port)
    849863                       (if (eq? (##sys#slot port 7) 'stream)
    850                            (##core#inline "C_ftell" port)
    851                            -1) ]
    852                       [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
    853                       [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
    854        (when (fx< pos 0)
     864                           (begin (##core#inline "C_ftellX" port) (##sys#cons-flonum))
     865                           -1) )
     866                      ((fixnum? port)
     867                       (##core#inline "C_lseekX" port 0 _seek_cur)
     868                       (##sys#cons-flonum))
     869                      (else
     870                       (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
     871       (when (< pos 0)
    855872         (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
    856873       pos) )
     
    859876
    860877;;; Directory stuff:
    861 
    862 #| ;has a problem w/ absolute-pathname (inf loop) & uses string-null?
    863 (define-inline (create-directory-helper name)
    864     (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
    865             (posix-error #:file-error 'create-directory
    866                          "cannot create directory" name)))
    867 
    868 
    869 (define-inline (create-directory-check name)
    870     (if (file-exists? name)
    871         (if (fx< (##core#inline "C_stat" (##sys#make-c-string name)) 0)
    872             (posix-error #:file-error 'create-directory
    873                          "cannot stat file" name)
    874             (or (foreign-value "C_isdir" bool)
    875                 (posix-error #:file-error 'create-directory
    876                              "path segment is a file" name)))
    877         #f))
    878 
    879 
    880 (define-inline (make-parents name)
    881   (let ((name (normalize-pathname name)))
    882     (let loop ((cur (pathname-directory name))
    883                (lst (list)))
    884       (if (or (not cur) (string-null? cur))
    885           lst
    886           (let ((next (pathname-directory cur)))
    887             (loop next (cons cur lst)))))))
    888 
    889 
    890 (define create-directory
    891   (let ((string-length string-length))
    892     (lambda (name #!optional parents?)
    893       (##sys#check-string name 'create-directory)
    894       (if (fx< 0 (string-length name))
    895           (let ((b (create-directory-check name)))
    896             (if (not b)
    897                 (let ((parents
    898                        (or (and parents? (make-parents name))
    899                            '())))
    900                   (for-each create-directory parents)
    901                   (create-directory-helper name))
    902                 ))
    903           ))))
    904 |#
    905878
    906879(define-inline (*directory? loc name)
  • chicken/trunk/posixwin.scm

    r15813 r16117  
    319319#define C_mkstemp(t)        C_fix(mktemp(C_c_string(t)))
    320320
    321 #define C_ftell(p)          C_fix(ftell(C_port_file(p)))
    322 #define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
    323 #define C_lseek(fd, o, w)   C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
     321/* It is assumed that 'int' is-a 'long' */
     322#define C_ftell(p)          (C_temporary_flonum = ftell(C_port_file(p)), C_SCHEME_UNDEFINED)
     323#define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
     324#define C_ftello(p)         (C_temporary_flonum = _ftelli64(C_port_file(p)), C_SCHEME_UNDEFINED)
     325#define C_fseeko(p, n, w)   C_mk_nbool(_fseeki64(C_port_file(p), C_num_to_int64(n), C_unfix(w)))
     326#define C_ftellX(p)         C_ftello(p)
     327#define C_fseekX(p, n, w)   C_fseeko(p, n, w)
     328#define C_lseekX(fd, o, w)  (C_temporary_flonum = _lseeki64(C_unfix(fd), C_num_to_int64(o), C_unfix(w)), C_SCHEME_UNDEFINED)
    324329
    325330#define C_flushall()        C_fix(_flushall())
     
    11261131
    11271132(define set-file-position!
    1128   (lambda (port pos . whence)
    1129     (let ([whence (if (pair? whence) (car whence) _seek_set)])
    1130       (##sys#check-exact pos 'set-file-position!)
    1131       (##sys#check-exact whence 'set-file-position!)
    1132       (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
    1133       (unless (cond [(port? port)
    1134                      (and (eq? (##sys#slot port 7) 'stream)
    1135                           (##core#inline "C_fseek" port pos whence) ) ]
    1136                     [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
    1137                     [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
    1138         (##sys#update-errno)
    1139         (##sys#signal-hook #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
     1133   (lambda (port pos . whence)
     1134     (let ((whence (if (pair? whence) (car whence) _seek_set)))
     1135       (##sys#check-number pos 'set-file-position!)
     1136       (##sys#check-exact whence 'set-file-position!)
     1137       (when (negative? pos)
     1138         (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
     1139       (unless (cond ((port? port)
     1140                      (and (eq? (##sys#slot port 7) 'stream)
     1141                           (##core#inline "C_fseekX" port pos whence) ) )
     1142                     ((fixnum? port)
     1143                      (##core#inline "C_lseekX" port pos whence))
     1144                     (else
     1145                      (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
     1146         (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
    11401147
    11411148(define file-position
    11421149  (getter-with-setter
    11431150   (lambda (port)
    1144      (let ([pos (cond [(port? port)
     1151     (let ((pos (cond ((port? port)
    11451152                       (if (eq? (##sys#slot port 7) 'stream)
    1146                            (##core#inline "C_ftell" port)
    1147                            -1) ]
    1148                       [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
    1149                       [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
    1150        (when (fx< pos 0)
    1151          (##sys#update-errno)
    1152          (##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
     1153                           (begin (##core#inline "C_ftellX" port) (##sys#cons-flonum))
     1154                           -1) )
     1155                      ((fixnum? port)
     1156                       (##core#inline "C_lseekX" port 0 _seek_cur)
     1157                       (##sys#cons-flonum))
     1158                      (else
     1159                       (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
     1160       (when (< pos 0)
     1161         (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
    11531162       pos) )
    1154    set-file-position!) )                ; doesn't accept WHENCE argument
     1163   set-file-position!) )                ; doesn't accept WHENCE
    11551164
    11561165
Note: See TracChangeset for help on using the changeset viewer.