[Chicken-hackers] [PATCH] drop ##sys#file-info

[Felix]

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 <address@hidden>
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 <address@hidden>
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