From 4e5114add398cc7ac8ee6ffd86c5c579403b696b Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 16 Dec 1991 12:50:25 +0000
Subject: [PATCH] Fixed various places that needed to take into account the
 fact that UNIX-NAMESTRING might return NIL now.

---
 code/filesys.lisp | 65 +++++++++++++++++++++++++++++------------------
 1 file changed, 40 insertions(+), 25 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index d7e4f0f29..af11ccaf6 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.16 1991/12/16 10:31:59 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.17 1991/12/16 12:50:25 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -666,6 +666,10 @@
 	 (original-namestring (unix-namestring original t))
 	 (new-name (merge-pathnames new-name original))
 	 (new-namestring (unix-namestring new-name nil)))
+    (unless original-namestring
+      (error "~S doesn't exist." file))
+    (unless new-namestring
+      (error "~S can't be created." new-name))
     (multiple-value-bind (res error)
 			 (mach:unix-rename original-namestring
 					   new-namestring)
@@ -708,22 +712,27 @@
 ;;;
 (defun file-write-date (file)
   "Return file's creation date, or NIL if it doesn't exist."
-  (multiple-value-bind (res dev ino mode nlink uid gid
-			    rdev size atime mtime)
-		       (mach:unix-stat (unix-namestring file t))
-    (declare (ignore dev ino mode nlink uid gid rdev size atime))
-    (when res
-      (+ unix-to-universal-time mtime))))
+  (let ((name (unix-namestring file t)))
+    (when name
+      (multiple-value-bind
+	  (res dev ino mode nlink uid gid rdev size atime mtime)
+	  (mach:unix-stat name)
+	(declare (ignore dev ino mode nlink uid gid rdev size atime))
+	(when res
+	  (+ unix-to-universal-time mtime))))))
 
 ;;; File-Author  --  Public
 ;;;
 (defun file-author (file)
   "Returns the file author as a string, or nil if the author cannot be
    determined.  Signals an error if file doesn't exist."
-  (multiple-value-bind (winp dev ino mode nlink uid)
-		       (mach:unix-stat (unix-namestring (pathname file) t))
-    (declare (ignore dev ino mode nlink))
-    (if winp (lookup-login-name uid))))
+  (let ((name (unix-namestring (pathname file) t)))
+    (unless name
+      (error "~S doesn't exist." file))
+    (multiple-value-bind (winp dev ino mode nlink uid)
+			 (mach:unix-stat file)
+      (declare (ignore dev ino mode nlink))
+      (if winp (lookup-login-name uid)))))
 
 
 
@@ -1056,14 +1065,17 @@
   "File-writable accepts a pathname and returns T if the current
   process can write it, and NIL otherwise."
   (let ((name (unix-namestring name nil)))
-    (values
-     (if (mach:unix-file-kind name)
-	 (mach:unix-access name mach:w_ok)
-	 (mach:unix-access (subseq name
-				   0
-				   (or (position #\/ name :from-end t)
-				       0))
-			   (logior mach:w_ok mach:x_ok))))))
+    (cond ((null name)
+	   nil)
+	  ((mach:unix-file-kind name)
+	   (values (mach:unix-access name mach:w_ok)))
+	  (t
+	   (values
+	    (mach:unix-access (subseq name
+				      0
+				      (or (position #\/ name :from-end t)
+					  0))
+			      (logior mach:w_ok mach:x_ok)))))))
 
 
 ;;; Pathname-Order  --  Internal
@@ -1098,12 +1110,15 @@
 ;;; %Set-Default-Directory  --  Internal
 ;;; 
 (defun %set-default-directory (new-val)
-  (multiple-value-bind (gr error)
-		       (mach:unix-chdir (unix-namestring new-val t))
-    (if gr
-	(setf (search-list "default:") (default-directory))
-	(error (mach:get-unix-error-msg error))))
-  new-val)
+  (let ((namestring (unix-namestring new-val t)))
+    (unless namestring
+      (error "~S doesn't exist." new-val))
+    (multiple-value-bind (gr error)
+			 (mach:unix-chdir namestring)
+      (if gr
+	  (setf (search-list "default:") (default-directory))
+	  (error (mach:get-unix-error-msg error))))
+    new-val))
 ;;;
 (defsetf default-directory %set-default-directory)
 
-- 
GitLab