From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 14 Mar 1989 02:17:20 +0000 (+0000)
Subject: Add new operations to support Edwin:
X-Git-Tag: 20090517-FFI~12239
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ac8f3d7f3bd8bb0aede9c550a15d1209ee63b2e8;p=mit-scheme.git

Add new operations to support Edwin:
    file-modes
    set-file-modes!
    unix/file-access
    file-writable?
    unix/current-uid
    unix/current-gid
---

diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index 3fe0fa473..c611c1aef 100644
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.2 1988/10/17 12:10:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.3 1989/03/14 02:17:20 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -64,11 +64,47 @@ MIT in each case. |#
     (and truename
 	 ((ucode-primitive file-attributes) (pathname->string truename)))))
 
+(define-structure (file-attributes
+		   (type vector)
+		   (constructor false)
+		   (conc-name file-attributes/))
+  (type false read-only true)
+  (n-links false read-only true)
+  (uid false read-only true)
+  (gid false read-only true)
+  (access-time false read-only true)
+  (modification-time false read-only true)
+  (change-time false read-only true)
+  (length false read-only true)
+  (mode-string false read-only true)
+  (inode-number false read-only true))
+
 (define (file-modification-time filename)
   (let ((attributes (file-attributes filename)))
     (and attributes
 	 (vector-ref attributes 5))))
 
+(define (file-modes filename)
+  (let ((truename (pathname->input-truename (->pathname filename))))
+    (and truename
+	 ((ucode-primitive file-modes) (pathname->string truename)))))
+
+(define-integrable (set-file-modes! filename modes)
+  ((ucode-primitive set-file-modes!) (canonicalize-input-filename filename)
+				     modes))
+
+(define (unix/file-access filename amode)
+  (let ((truename (pathname->input-truename (->pathname filename))))
+    (and truename
+	 ((ucode-primitive file-access) (pathname->string truename) amode))))
+
+(define (file-writable? filename)
+  (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+    ((ucode-primitive file-access)
+     (pathname->string (or (pathname->input-truename pathname)
+			   (pathname-directory-path pathname)))
+     2)))
+
 (define (get-environment-variable name)
   (or ((ucode-primitive get-environment-variable) name)
       (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name)))
@@ -80,6 +116,12 @@ MIT in each case. |#
 (define unix/current-user-name
   (ucode-primitive current-user-name))
 
+(define unix/current-uid
+  (ucode-primitive current-uid))
+
+(define unix/current-gid
+  (ucode-primitive current-gid))
+
 (define unix/current-file-time
   (ucode-primitive current-user-name))