This patch replaces ##sys#file-info with a cleaner file/directory exists check. It checks for errors (except ENOENT) and can later be extended to handle EOVERFLOW on those platforms that support some workaround or large file support. "fifo?" was also changed to use stat(3) and checks for errors instead of using ##sys#file-info.
The patch was done in collaboration with Christian, but I post it here once more in case someone wants to comment. cheers, felix
>From 71eb0e713084f670d9f2cebc1f475ba25d779b3a Mon Sep 17 00:00:00 2001 From: felix <[email protected]> Date: Fri, 30 Sep 2011 09:17:01 +0200 Subject: [PATCH 1/2] replaced ##sys#file-info with ##sys#file-exists? --- c-platform.scm | 3 +- chicken.h | 2 +- eval.scm | 20 +++++--------- library.scm | 22 ++++++++++++--- posixunix.scm | 31 +++++++++++++++++++--- posixwin.scm | 9 +------ runtime.c | 77 ++++++++++++++++---------------------------------------- 7 files changed, 77 insertions(+), 87 deletions(-) diff --git a/c-platform.scm b/c-platform.scm index efeb48e..7f27937 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -183,7 +183,8 @@ ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double - ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) ) + ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte + ##sys#file-exists?) ) (define non-foldable-bindings '(vector diff --git a/chicken.h b/chicken.h index 8c6eff3..d888730 100644 --- a/chicken.h +++ b/chicken.h @@ -1673,7 +1673,6 @@ C_fctexport void C_ccall C_make_pointer(C_word c, C_word closure, C_word k) C_no C_fctexport void C_ccall C_make_tagged_pointer(C_word c, C_word closure, C_word k, C_word tag) C_noret; C_fctexport void C_ccall C_ensure_heap_reserve(C_word c, C_word closure, C_word k, C_word n) C_noret; C_fctexport void C_ccall C_return_to_host(C_word c, C_word closure, C_word k) C_noret; -C_fctexport void C_ccall C_file_info(C_word c, C_word closure, C_word k, C_word port) C_noret; C_fctexport void C_ccall C_get_environment_variable(C_word c, C_word closure, C_word k, C_word name) C_noret; C_fctexport void C_ccall C_get_symbol_table_info(C_word c, C_word closure, C_word k) C_noret; C_fctexport void C_ccall C_get_memory_info(C_word c, C_word closure, C_word k) C_noret; @@ -1816,6 +1815,7 @@ C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm; C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm; C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm; C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm; +C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm; C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm; C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm; diff --git a/eval.scm b/eval.scm index 445df6e..d0b27ee 100644 --- a/eval.scm +++ b/eval.scm @@ -919,25 +919,20 @@ (lambda (input evaluator pf #!optional timer printer) (when (string? input) (set! input (##sys#expand-home-path input)) ) - (let* ([isdir #f] - [fname + (let* ((fname (cond [(port? input) #f] [(not (string? input)) (badfile input)] - [(and-let* ([info (##sys#file-info input)] - [id (##sys#slot info 4)] ) - (set! isdir (eq? 1 id)) - (not isdir) ) - input] - [else + ((##sys#file-exists? input #t #f 'load) input) + (else (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)]) (if (and (not ##sys#dload-disabled) (##sys#fudge 24) ; dload? - (##sys#file-info fname2)) + (##sys#file-exists? fname2 #t #f 'load)) fname2 (let ([fname3 (##sys#string-append input source-file-extension)]) - (if (##sys#file-info fname3) + (if (##sys#file-exists? fname3 #t #f 'load) fname3 - (and (not isdir) input) ) ) ) ) ] ) ] + input) ) ) ) ))) [evproc (or evaluator eval)] ) (cond [(and (string? input) (not fname)) (##sys#signal-hook #:file-error 'load "cannot open file" input) ] @@ -1414,8 +1409,7 @@ (define ##sys#resolve-include-filename (let ((string-append string-append) ) (define (exists? fname) - (let ([info (##sys#file-info fname)]) - (and info (not (eq? 1 (##sys#slot info 4)))) ) ) + (##sys#file-exists? fname #t #f #f)) (lambda (fname prefer-source #!optional repo) (define (test2 fname lst) (if (null? lst) diff --git a/library.scm b/library.scm index 4cf975c..5a2d44c 100644 --- a/library.scm +++ b/library.scm @@ -190,7 +190,6 @@ EOF (define (##sys#fudge index) (##core#inline "C_fudge" index)) (define ##sys#call-host (##core#primitive "C_return_to_host")) (define return-to-host ##sys#call-host) -(define ##sys#file-info (##core#primitive "C_file_info")) (define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info")) (define ##sys#memory-info (##core#primitive "C_get_memory_info")) (define (current-milliseconds) (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)) @@ -1974,12 +1973,24 @@ EOF (set! ##sys#standard-output old) (apply ##sys#values results) ) ) ) ) ) ) +(define (##sys#file-exists? name file? dir? loc) + (case (##core#inline "C_i_file_exists_p" (##sys#make-c-string name loc) file? dir?) + ((#f) #f) + ((#t) #t) + (else + (##sys#signal-hook + #:file-error loc "system error while trying to access file" + name)))) + (define (file-exists? name) (##sys#check-string name 'file-exists?) (##sys#pathname-resolution name (lambda (name) - (and (##sys#file-info (##sys#platform-fixup-pathname name)) name) ) + (and (##sys#file-exists? + (##sys#platform-fixup-pathname name) + #f #f 'file-exists?) + name) ) #:exists?) ) (define (directory-exists? name) @@ -1987,9 +1998,10 @@ EOF (##sys#pathname-resolution name (lambda (name) - (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name))) - ((eq? 1 (vector-ref info 4)))) - name)) + (and (##sys#file-exists? + (##sys#platform-fixup-pathname name) + #f #t 'directory-exists?) + name) ) #:exists?) ) (define (##sys#flush-output port) diff --git a/posixunix.scm b/posixunix.scm index a9e4565..5cde5b8 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -468,6 +468,26 @@ static int set_file_mtime(char *filename, C_word tm) return utime(filename, &tb); } +static C_word C_i_fifo_p(C_word name) +{ + struct stat buf; + int res; + + res = stat(C_c_string(name), &buf); + + if(res != 0) { +#ifdef __CYGWIN__ + return C_SCHEME_FALSE; +#else + if((buf.st_mode & S_IFMT) == S_IFIFO) return C_SCHEME_TRUE; + else return C_SCHEME_FALSE; +#endif + } + + if(errno == ENOENT) return C_fix(0); + else return C_fix(res); +} + EOF ) ) @@ -1539,10 +1559,13 @@ EOF (define fifo? (lambda (filename) (##sys#check-string filename 'fifo?) - (let ([v (##sys#file-info (##sys#expand-home-path filename))]) - (if v - (fx= 3 (##sys#slot v 4)) - (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) ) + (case (##core#inline + "C_i_fifo_p" + (##sys#make-c-string (##sys#expand-home-path filename) 'fifo?)) + ((#t) #t) + ((#f) #f) + ((0) (##sys#signal-hook #:file-error 'fifo? "file does not exist" filename) ) ) ) ) + (else (posix-error #:file-error 'fifo? "system error while trying to access file" filename) ) ) ) ) ;;; Environment access: diff --git a/posixwin.scm b/posixwin.scm index 0430876..d253b7c 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -1083,15 +1083,8 @@ EOF (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name))) -(define-inline (create-directory-check name) - (if (file-exists? name) - (let ((i (##sys#file-info name))) - (and i - (fx= 1 (##sys#slot i 4)))) - #f)) - (define-inline (create-directory-helper-silent name) - (unless (create-directory-check name) + (unless (##sys#file-exists? name #f #t #f) (create-directory-helper name))) (define-inline (create-directory-helper-parents name) diff --git a/runtime.c b/runtime.c index c0c91bc..f58144e 100644 --- a/runtime.c +++ b/runtime.c @@ -7766,61 +7766,6 @@ void C_ccall C_return_to_host(C_word c, C_word closure, C_word k) } -void C_ccall C_file_info(C_word c, C_word closure, C_word k, C_word name) -{ - C_save(k); - C_save(name); - - if(!C_demand(FILE_INFO_SIZE + 1 + C_SIZEOF_FLONUM * 3)) C_reclaim((void *)file_info_2, NULL); - - file_info_2(NULL); -} - - -void file_info_2(void *dummy) -{ - C_word name = C_restore, - k = C_restore, - *a = C_alloc(FILE_INFO_SIZE + 1 + C_SIZEOF_FLONUM * 3), - v = C_SCHEME_FALSE, - t, f1, f2, f3; - int len = C_header_size(name); - char *buffer2; - struct stat buf; - - buffer2 = buffer; - if(len >= sizeof(buffer)) { - if((buffer2 = (char *)C_malloc(len + 1)) == NULL) - barf(C_OUT_OF_MEMORY_ERROR, "stat"); - } - C_strncpy(buffer2, C_c_string(name), len); - buffer2[ len ] = '\0'; - - if(stat(buffer2, &buf) != 0) v = C_SCHEME_FALSE; - else { - switch(buf.st_mode & S_IFMT) { - case S_IFDIR: t = 1; break; - case S_IFIFO: t = 3; break; -#if !defined(__MINGW32__) - case S_IFSOCK: t = 4; break; -#endif - default: t = 0; - } - - f1 = C_flonum(&a, buf.st_atime); - f2 = C_flonum(&a, buf.st_ctime); - f3 = C_flonum(&a, buf.st_mtime); - v = C_vector(&a, FILE_INFO_SIZE, f1, f2, f3, - C_fix(buf.st_size), C_fix(t), C_fix(buf.st_mode), C_fix(buf.st_uid) ); - } - - if (buffer2 != buffer) - free(buffer2); - - C_kontinue(k, v); -} - - #define C_do_getenv(v) C_getenv(v) #define C_free_envbuf() {} @@ -9229,3 +9174,25 @@ C_filter_heap_objects(C_word c, C_word closure, C_word k, C_word func, C_word ve C_fromspace_top = C_fromspace_limit; /* force major GC */ C_reclaim((void *)filter_heap_objects_2, NULL); } + + +C_regparm C_word C_fcall +C_i_file_exists_p(C_word name, C_word file, C_file dir) +{ + struct stat buf; + int res; + + res = stat(C_c_string(name), &buf); + + if(res != 0) { + if(errno == ENOENT) return C_SCHEME_FALSE; + else return C_fix(res); + } + + switch(buf.st_mode & S_IFMT) { + case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE; + default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE; + } +} + + -- 1.7.6.msysgit.0 >From 8ef1105d85e6e652c96e88a71b711b0ef75588b0 Mon Sep 17 00:00:00 2001 From: felix <[email protected]> Date: Fri, 30 Sep 2011 09:54:27 +0200 Subject: [PATCH 2/2] fixed type name and adjusted initial ptable --- runtime.c | 5 ++--- 1 files changed, 2 insertions(+), 3 deletions(-) diff --git a/runtime.c b/runtime.c index f58144e..ee3bac3 100644 --- a/runtime.c +++ b/runtime.c @@ -720,7 +720,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel) static C_PTABLE_ENTRY *create_initial_ptable() { /* hardcoded table size - this must match the number of C_pte calls! */ - C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 61); + C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 60); int i = 0; if(pt == NULL) @@ -736,7 +736,6 @@ static C_PTABLE_ENTRY *create_initial_ptable() C_pte(C_make_structure); C_pte(C_ensure_heap_reserve); C_pte(C_return_to_host); - C_pte(C_file_info); C_pte(C_get_symbol_table_info); C_pte(C_get_memory_info); C_pte(C_decode_seconds); @@ -9177,7 +9176,7 @@ C_filter_heap_objects(C_word c, C_word closure, C_word k, C_word func, C_word ve C_regparm C_word C_fcall -C_i_file_exists_p(C_word name, C_word file, C_file dir) +C_i_file_exists_p(C_word name, C_word file, C_word dir) { struct stat buf; int res; -- 1.7.6.msysgit.0
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
