Implement new procedures FILE-TYPE-DIRECT and FILE-TYPE-INDIRECT.

Several procedures in the OS-dependent files were identical for all
operating-systems; move them to "sfile.scm".

diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm
index 3885e6a0fb566fa06d65e213c3f04fbdd666edbf..b7d1c200fe71d7ba55a64b0f44f7e82184a30831 100644 (file)
--- a/v7/src/runtime/ntprm.scm
+++ b/v7/src/runtime/ntprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ntprm.scm,v 1.35 2001/03/21 05:39:50 cph Exp $
+$Id: ntprm.scm,v 1.36 2001/05/09 03:17:05 cph Exp $
 
 Copyright (c) 1992-2001 Massachusetts Institute of Technology
 
@@ -16,8 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; Miscellaneous Win32 Primitives
@@ -25,36 +25,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 \f
-(define (file-directory? filename)
-  ((ucode-primitive file-directory? 1)
-   (->namestring (merge-pathnames filename))))
-
-(define (file-symbolic-link? filename)
-  ((ucode-primitive file-symlink? 1)
-   (->namestring (merge-pathnames filename))))
-
-(define (file-access filename amode)
-  ((ucode-primitive file-access 2)
-   (->namestring (merge-pathnames filename))
-   amode))
-
-(define (file-readable? filename)
-  (file-access filename 4))
-
-(define (file-writeable? filename)
-  ((ucode-primitive file-access 2)
-   (let ((pathname (merge-pathnames filename)))
-     (let ((filename (->namestring pathname)))
-       (if ((ucode-primitive file-exists? 1) filename)
-          filename
-          (directory-namestring pathname))))
-   2))
-;; upwards compatability
-(define file-writable? file-writeable?)
-
-(define (file-executable? filename)
-  (file-access filename 1))
-
 (define (file-modes filename)
   ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
 
@@ -136,10 +106,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (file-time->universal-time time) (+ time epoch))
 (define (universal-time->file-time time) (- time epoch))
-
-(define (file-touch filename)
-  ((ucode-primitive file-touch 1)
-   (->namestring (merge-pathnames filename))))
 \f
 (define get-environment-variable)
 (define set-environment-variable!)
@@ -291,14 +257,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define dos/current-user-name current-user-name)
 (define dos/current-home-directory current-home-directory)
 \f
-(define (make-directory name)
-  ((ucode-primitive directory-make 1)
-   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
-
-(define (delete-directory name)
-  ((ucode-primitive directory-delete 1)
-   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
-
 (define (temporary-file-pathname #!optional directory)
   (let ((root
         (merge-pathnames "_scm_tmp"

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index fd31058a7a8a6887f067a0c442167a2282b9a16a..0b18d2f57dc5b002c1d90f30a64bb0baba3c22c0 100644 (file)
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.46 2001/03/21 05:39:56 cph Exp $
+$Id: os2prm.scm,v 1.47 2001/05/09 03:17:08 cph Exp $
 
 Copyright (c) 1994-2001 Massachusetts Institute of Technology
 
@@ -16,8 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; Miscellaneous OS/2 Primitives
@@ -25,44 +25,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 \f
-(define (file-directory? filename)
-  ((ucode-primitive file-directory? 1)
-   (->namestring (merge-pathnames filename))))
-
-(define (file-symbolic-link? filename)
-  ((ucode-primitive file-symlink? 1)
-   (->namestring (merge-pathnames filename))))
-
-(define (file-access filename amode)
-  ((ucode-primitive file-access 2)
-   (->namestring (merge-pathnames filename))
-   amode))
-
-(define (file-readable? filename)
-  (file-access filename 4))
-
-(define (file-writeable? filename)
-  ((ucode-primitive file-access 2)
-   (let ((pathname (merge-pathnames filename)))
-     (let ((filename (->namestring pathname)))
-       (if ((ucode-primitive file-exists? 1) filename)
-          filename
-          (directory-namestring pathname))))
-   2))
-;; upwards compatability
-(define file-writable? file-writeable?)
-
-(define (file-executable? filename)
-  (file-access filename 1))
-
-(define (make-directory name)
-  ((ucode-primitive directory-make 1)
-   (->namestring (pathname-as-directory (merge-pathnames name)))))
-
-(define (delete-directory name)
-  ((ucode-primitive directory-delete 1)
-   (->namestring (pathname-as-directory (merge-pathnames name)))))
-
 (define (file-modes filename)
   ((ucode-primitive file-attributes 1)
    (->namestring (merge-pathnames filename))))
@@ -152,9 +114,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (file-attributes/n-links attributes) attributes 1)
 \f
-(define (file-touch filename)
-  ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
-
 (define (get-environment-variable name)
   ((ucode-primitive get-environment-variable 1) name))
 

diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 31393ae1aa77e6ddc83540e579d60e066de76b40..0f80c61dafea98ef28e906ef0705d0a73e08dd75 100644 (file)
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.23 1999/12/21 18:50:47 cph Exp $
+$Id: sfile.scm,v 14.24 2001/05/09 03:17:11 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; Simple File Operations
@@ -42,6 +43,69 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define file-exists? file-exists-indirect?)
 
+(define file-type-direct)
+(define file-type-indirect)
+(let ((make-file-type
+       (lambda (procedure)
+        (lambda (filename)
+          (let ((n (procedure (->namestring (merge-pathnames filename)))))
+            (and n
+                 (let ((types
+                        '#(REGULAR
+                           DIRECTORY
+                           UNIX-SYMBOLIC-LINK
+                           UNIX-CHARACTER-DEVICE
+                           UNIX-BLOCK-DEVICE
+                           UNIX-NAMED-PIPE
+                           UNIX-SOCKET
+                           OS2-NAMED-PIPE
+                           WIN32-NAMED_PIPE)))
+                   (if (fix:< n (vector-length types))
+                       (vector-ref types n)
+                       'UNKNOWN))))))))
+  (set! file-type-direct
+       (make-file-type (ucode-primitive file-type-direct 1)))
+  (set! file-type-indirect
+       (make-file-type (ucode-primitive file-type-indirect 1))))
+
+(define (file-directory? filename)
+  (eq? 'DIRECTORY (file-type-indirect filename)))
+
+(define (file-symbolic-link? filename)
+  (eq? 'UNIX-SYMBOLIC-LINK (file-type-direct filename)))
+
+(define (file-access filename amode)
+  ((ucode-primitive file-access 2)
+   (->namestring (merge-pathnames filename))
+   amode))
+
+(define (file-readable? filename)
+  (file-access filename 4))
+
+(define (file-writeable? filename)
+  ((ucode-primitive file-access 2)
+   (let ((pathname (merge-pathnames filename)))
+     (let ((filename (->namestring pathname)))
+       (if ((ucode-primitive file-exists? 1) filename)
+          filename
+          (directory-namestring pathname))))
+   2))
+(define file-writable? file-writeable?) ;upwards compatability
+
+(define (file-executable? filename)
+  (file-access filename 1))
+\f
+(define (file-touch filename)
+  ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
+
+(define (make-directory name)
+  ((ucode-primitive directory-make 1)
+   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+
+(define (delete-directory name)
+  ((ucode-primitive directory-delete 1)
+   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+
 (define (rename-file from to)
   ((ucode-primitive file-rename) (->namestring (merge-pathnames from))
                                 (->namestring (merge-pathnames to))))

diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 50a2b3f684c60155ce6b9b97f5b8c4e7d3ff1b1b..367a41aaadfa9a4554e687b95985669ded29e0d0 100644 (file)
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.60 2001/03/16 21:37:48 cph Exp $
+$Id: unxprm.scm,v 1.61 2001/05/09 03:17:14 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -16,8 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-;;; 02111-1307, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; Miscellaneous Unix Primitives
@@ -25,14 +25,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 \f
-(define (file-directory? filename)
-  ((ucode-primitive file-directory? 1)
-   (->namestring (merge-pathnames filename))))
-
-(define (file-symbolic-link? filename)
-  ((ucode-primitive file-symlink? 1)
-   (->namestring (merge-pathnames filename))))
-
 (define (file-modes filename)
   ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
 
@@ -41,27 +33,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
    (->namestring (merge-pathnames filename))
    modes))
 
-(define (file-access filename amode)
-  ((ucode-primitive file-access 2) (->namestring (merge-pathnames filename))
-                                  amode))
 (define unix/file-access file-access)  ;upwards compatability
 
-(define (file-readable? filename)
-  (file-access filename 4))
-
-(define (file-writeable? filename)
-  ((ucode-primitive file-access 2)
-   (let ((pathname (merge-pathnames filename)))
-     (let ((filename (->namestring pathname)))
-       (if ((ucode-primitive file-exists? 1) filename)
-          filename
-          (directory-namestring pathname))))
-   2))
-(define file-writable? file-writeable?)        ;upwards compatability
-
-(define (file-executable? filename)
-  (file-access filename 1))
-\f
 (define (temporary-file-pathname #!optional directory)
   (let ((root-string
         (string-append
@@ -277,17 +250,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
        (set-thread-timer-interval! ti-outside)
        (set! ti-outside)
        unspecific))))
-
-(define (file-touch filename)
-  ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
-
-(define (make-directory name)
-  ((ucode-primitive directory-make 1)
-   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
-
-(define (delete-directory name)
-  ((ucode-primitive directory-delete 1)
-   (->namestring (directory-pathname-as-file (merge-pathnames name)))))
 \f
 (define (os/file-end-of-line-translation pathname)
   ;; This works because the line translation is harmless when not