~ chicken-core (chicken-5) ee1a502ed3ca4bd165875f1bae3cc9a7787c2d9b
commit ee1a502ed3ca4bd165875f1bae3cc9a7787c2d9b
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Oct 4 08:00:04 2011 +0200
Commit: Christian Kellermann <ck@emlix.com>
CommitDate: Tue Oct 4 15:05:07 2011 +0200
Squashed commit of the following:
commit 8220b82dfdb4e422c0ab03cfbf0866e03cd29e01
Author: felix <felix@call-with-current-continuation.org>
Date: Tue Oct 4 07:59:15 2011 +0200
fixed completely broken implementation of fifo? - thanks to Alan Post
commit 8ef1105d85e6e652c96e88a71b711b0ef75588b0
Author: felix <felix@call-with-current-continuation.org>
Date: Fri Sep 30 09:54:27 2011 +0200
fixed type name and adjusted initial ptable
commit 71eb0e713084f670d9f2cebc1f475ba25d779b3a
Author: felix <felix@call-with-current-continuation.org>
Date: Fri Sep 30 09:17:01 2011 +0200
replaced ##sys#file-info with ##sys#file-exists?
Signed-off-by: Christian Kellermann <ck@emlix.com>
diff --git a/c-platform.scm b/c-platform.scm
index e8452d67..0e987546 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -185,7 +185,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 d52e925f..5524bc4b 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1678,7 +1678,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;
@@ -1822,6 +1821,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 445df6e7..d0b27eeb 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 52888d07..8075c2fd 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))
@@ -1991,12 +1990,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)
@@ -2004,9 +2015,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 ef0d6806..ee173252 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(errno == ENOENT) return C_fix(0);
+ else return C_fix(res);
+#endif
+ }
+
+ if((buf.st_mode & S_IFMT) == S_IFIFO) return C_SCHEME_TRUE;
+ else return C_SCHEME_FALSE;
+}
+
EOF
) )
@@ -1546,10 +1566,16 @@ 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 de0286da..64c544ea 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 1f5a9c23..a6d7919f 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);
@@ -7828,61 +7827,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() {}
@@ -9291,3 +9235,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_word 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;
+ }
+}
+
+
Trap