From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 25 Apr 1989 01:04:43 +0000 (+0000)
Subject: Fix stupid bug in `file-writable?'.
X-Git-Tag: 20090517-FFI~12123
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4f758d25389560fa3fecd6e8741af78db7264fd5;p=mit-scheme.git

Fix stupid bug in `file-writable?'.
---

diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 237d5daca..7bc108ba7 100644
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.3 1989/04/24 23:45:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.4 1989/04/25 01:04:43 cph Rel $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -60,9 +60,12 @@ MIT in each case. |#
 
 (define (file-writable? filename)
   (let ((pathname (pathname->absolute-pathname (->pathname filename))))
-    (or ((ucode-primitive file-access) (pathname->string pathname) 2)
-	((ucode-primitive file-access) (pathname-directory-string pathname)
-				       2))))
+    (let ((filename (pathname->string pathname)))
+      (or ((ucode-primitive file-access) filename 2)
+	  (and (not ((ucode-primitive file-exists?) filename))
+	       ((ucode-primitive file-access)
+		(pathname-directory-string pathname)
+		2))))))
 
 (define (file-attributes filename)
   ((ucode-primitive file-attributes)