From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 21 Dec 1999 18:50:47 +0000 (+0000)
Subject: Define new primitive FILE-EXISTS-DIRECT?.
X-Git-Tag: 20090517-FFI~4400
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=478319db946ace3424843d641c0f683d7f414b2b;p=mit-scheme.git

Define new primitive FILE-EXISTS-DIRECT?.
---

diff --git a/v7/src/microcode/ntfs.c b/v7/src/microcode/ntfs.c
index 01198b331..ea62dc773 100644
--- a/v7/src/microcode/ntfs.c
+++ b/v7/src/microcode/ntfs.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ntfs.c,v 1.24 1999/01/02 06:11:34 cph Exp $
+$Id: ntfs.c,v 1.25 1999/12/21 18:48:25 cph Exp $
 
 Copyright (c) 1992-1999 Massachusetts Institute of Technology
 
@@ -152,7 +152,7 @@ create_file_for_info (const char * namestring)
 }
 
 enum file_existence
-DEFUN (OS_file_existence_test, (name), CONST char * name)
+OS_file_existence_test (const char * name)
 {
   BY_HANDLE_FILE_INFORMATION info;
   return
@@ -161,6 +161,12 @@ DEFUN (OS_file_existence_test, (name), CONST char * name)
      : file_doesnt_exist);
 }
 
+enum file_existence
+OS_file_existence_test_direct (const char * name)
+{
+  return (OS_file_existence_test (name));
+}
+
 #define R_OK 4
 #define W_OK 2
 #define X_OK 1
diff --git a/v7/src/microcode/os2fs.c b/v7/src/microcode/os2fs.c
index 6f866316a..ceb760fce 100644
--- a/v7/src/microcode/os2fs.c
+++ b/v7/src/microcode/os2fs.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2fs.c,v 1.10 1999/01/02 06:11:34 cph Exp $
+$Id: os2fs.c,v 1.11 1999/12/21 18:48:32 cph Exp $
 
 Copyright (c) 1994-1999 Massachusetts Institute of Technology
 
@@ -90,9 +90,16 @@ OS2_write_file_status (const char * filename, FILESTATUS3 * info)
 enum file_existence
 OS_file_existence_test (const char * filename)
 {
-  return ((OS2_read_file_status (filename))
-	  ? file_does_exist
-	  : file_doesnt_exist);
+  return
+    ((OS2_read_file_status (filename))
+     ? file_does_exist
+     : file_doesnt_exist);
+}
+
+enum file_existence
+OS_file_existence_test_direct (const char * filename)
+{
+  return (OS_file_existence_test (filename));
 }
 
 #define R_OK 4
diff --git a/v7/src/microcode/osfs.h b/v7/src/microcode/osfs.h
index 07416142c..07d85eb3c 100644
--- a/v7/src/microcode/osfs.h
+++ b/v7/src/microcode/osfs.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: osfs.h,v 1.7 1999/01/02 06:11:34 cph Exp $
+$Id: osfs.h,v 1.8 1999/12/21 18:48:47 cph Exp $
 
 Copyright (c) 1990-1999 Massachusetts Institute of Technology
 
@@ -27,6 +27,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 enum file_existence { file_does_exist, file_doesnt_exist, file_is_link };
 
 extern enum file_existence EXFUN (OS_file_existence_test, (CONST char * name));
+extern enum file_existence EXFUN
+  (OS_file_existence_test_direct, (CONST char * name));
 extern int EXFUN (OS_file_access, (CONST char * name, unsigned int mode));
 extern int EXFUN (OS_file_directory_p, (CONST char * name));
 extern CONST char * EXFUN (OS_file_soft_link_p, (CONST char * name));
diff --git a/v7/src/microcode/prosfs.c b/v7/src/microcode/prosfs.c
index 790e7c513..57d21f3e4 100644
--- a/v7/src/microcode/prosfs.c
+++ b/v7/src/microcode/prosfs.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: prosfs.c,v 1.13 1999/01/02 06:11:34 cph Exp $
+$Id: prosfs.c,v 1.14 1999/12/21 18:48:29 cph Exp $
 
 Copyright (c) 1987-1999 Massachusetts Institute of Technology
 
@@ -63,6 +63,25 @@ Signal an error if the file's existence is indeterminate.")
   }
 }
 
+DEFINE_PRIMITIVE ("FILE-EXISTS-DIRECT?", Prim_file_exists_direct_p, 1, 1,
+  "Return #T iff FILENAME refers to an existing file.\n\
+Return #F if the file doesn't exist.\n\
+Return zero if it's a symbolic link.\n\
+Signal an error if the file's existence is indeterminate.")
+{
+  PRIMITIVE_HEADER (1);
+  {
+    enum file_existence result
+      = (OS_file_existence_test_direct (STRING_ARG (1)));
+    PRIMITIVE_RETURN
+      ((result == file_doesnt_exist)
+       ? SHARP_F
+       : (result == file_does_exist)
+       ? SHARP_T
+       : FIXNUM_ZERO);
+  }
+}
+
 DEFINE_PRIMITIVE ("FILE-ACCESS", Prim_file_access, 2, 2,
   "Return #T iff FILENAME exists and is accessible according to MODE.\n\
 MODE is an integer between 0 and 7 inclusive, bitwise encoded:\n\
diff --git a/v7/src/microcode/uxfs.c b/v7/src/microcode/uxfs.c
index de8ce3fdf..3f215e591 100644
--- a/v7/src/microcode/uxfs.c
+++ b/v7/src/microcode/uxfs.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: uxfs.c,v 1.17 1999/01/02 06:11:34 cph Exp $
+$Id: uxfs.c,v 1.18 1999/12/21 18:48:34 cph Exp $
 
 Copyright (c) 1990-1999 Massachusetts Institute of Technology
 
@@ -152,12 +152,31 @@ enum file_existence
 DEFUN (OS_file_existence_test, (name), CONST char * name)
 {
   struct stat s;
-  return
-    ((UX_read_file_status_indirect (name, (&s)))
-     ? file_does_exist
-     : (UX_read_file_status (name, (&s)))
-     ? file_is_link
-     : file_doesnt_exist);
+  if (!UX_read_file_status (name, (&s)))
+    return (file_doesnt_exist);
+#ifdef HAVE_SYMBOLIC_LINKS
+  if (((s . st_mode) & S_IFMT) == S_IFLNK)
+    {
+      if (UX_read_file_status_indirect (name, (&s)))
+	return (file_does_exist);
+      else
+	return (file_is_link);
+    }
+#endif
+  return (file_does_exist);
+}
+
+enum file_existence
+DEFUN (OS_file_existence_test_direct, (name), CONST char * name)
+{
+  struct stat s;
+  if (!UX_read_file_status (name, (&s)))
+    return (file_doesnt_exist);
+#ifdef HAVE_SYMBOLIC_LINKS
+  if (((s . st_mode) & S_IFMT) == S_IFLNK)
+    return (file_is_link);
+#endif
+  return (file_does_exist);
 }
 
 CONST char *
diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 2d60e401f..31393ae1a 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.22 1999/11/19 14:12:53 cph Exp $
+$Id: sfile.scm,v 14.23 1999/12/21 18:50:47 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -24,8 +24,23 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (declare (usual-integrations))
 
-(define (file-exists? filename)
-  ((ucode-primitive file-exists? 1) (->namestring (merge-pathnames filename))))
+(define (file-exists-direct? filename)
+  (let ((result
+	 ((ucode-primitive file-exists-direct? 1)
+	  (->namestring (merge-pathnames filename)))))
+    (if (eq? 0 result)
+	#t
+	result)))
+
+(define (file-exists-indirect? filename)
+  (let ((result
+	 ((ucode-primitive file-exists? 1)
+	  (->namestring (merge-pathnames filename)))))
+    (if (eq? 0 result)
+	#f
+	result)))
+
+(define file-exists? file-exists-indirect?)
 
 (define (rename-file from to)
   ((ucode-primitive file-rename) (->namestring (merge-pathnames from))