From: Chris Hanson Date: Wed, 9 May 2001 03:17:14 +0000 (+0000) Subject: Implement new procedures FILE-TYPE-DIRECT and FILE-TYPE-INDIRECT. X-Git-Tag: 20090517-FFI~2839 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d06395099cf59c83505cd351ca4d6ad719911a62;p=mit-scheme.git 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 3885e6a0f..b7d1c200f 100644 --- 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)) -(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)))) (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) -(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 fd31058a7..0b18d2f57 100644 --- 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)) -(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) -(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 31393ae1a..0f80c61da 100644 --- 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)) + +(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 50a2b3f68..367a41aaa 100644 --- 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)) -(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)) - (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))))) (define (os/file-end-of-line-translation pathname) ;; This works because the line translation is harmless when not