From dfc94f8a8f06e8f3f0e06b03a59cdef2eb7b1c2a Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 3 Nov 1990 00:23:13 +0000
Subject: [PATCH] Rewrote large chunks to get rid of Dave code.  Do pattern
 matching in directory instead of expecting the lower level code to handle it.
 Changed the names of routines like %ses-get-useful-part to something
 reasonable.

---
 code/filesys.lisp | 629 +++++++++++++++++++++-------------------------
 1 file changed, 287 insertions(+), 342 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index 0f9e00828..319f18a0b 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.3 1990/08/24 18:11:00 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.4 1990/11/03 00:23:13 wlott Exp $
 ;;;
 ;;; Ugly pathname functions for Spice Lisp.
 ;;;    these functions are part of the standard Spice Lisp environment.
@@ -338,8 +338,8 @@
 
 (defun namestring (pathname)
   "Returns the full form of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (directory (%pathname-directory pathname))
 	 (name (%pathname-name pathname))
 	 (type (%pathname-type pathname))
 	 (result (%device-string (%pathname-device pathname))))
@@ -355,10 +355,10 @@
 				(the simple-string type))))
     result))
 
-(defun %ses-get-useful-name (pathname)
+(defun namestring-without-device (pathname)
   "NAMESTRING of pathname ignoring the device slot."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (directory (%pathname-directory pathname))
 	 (name (%pathname-name pathname))
 	 (type (%pathname-type pathname))
 	 (result ""))
@@ -379,8 +379,8 @@
 ;;;
 (defun file-namestring (pathname)
   "Returns the name, type, and version of PATHNAME as a string."
-  (unless (pathnamep pathname) (setq pathname (pathname pathname)))
-  (let* ((name (%pathname-name pathname))
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (name (%pathname-name pathname))
 	 (type (%pathname-type pathname))
 	 (result (or name "")))
     (declare (simple-string result))
@@ -390,8 +390,8 @@
 
 (defun directory-namestring (pathname)
   "Returns the device & directory parts of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (directory (%pathname-directory pathname))
  	 (result (%device-string (%pathname-device pathname))))
     (declare (simple-string result))
     (when directory
@@ -401,8 +401,41 @@
 
 (defun host-namestring (pathname)
   "Returns the host part of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (%pathname-host pathname))
+  (%pathname-host (if (pathnamep pathname) pathname (pathname pathname))))
+
+
+;;; Do-Search-List  --  Internal
+;;;
+;;;    Bind var in turn to each element of search list with the specifed
+;;; name.
+;;;
+(defmacro do-search-list ((var name &optional exit-form) . body)
+  "Do-Search-List (Var Name [Exit-Form]) {Form}*"
+  `(dolist (,var (resolve-search-list ,name nil) ,exit-form)
+     (declare (simple-string ,var))
+     ,@body))
+
+(defun unix-namestring (pathname for-input)
+  "Convert PATHNAME into a string that can be used with UNIX system calls."
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (device (%pathname-device pathname)))
+    (cond ((or (eq device :absolute)
+	       (null device)
+	       (string= device "Default"))
+	   (namestring pathname))
+	  (for-input
+	   (let ((remainder (namestring-without-device pathname))
+		 (first nil))
+	     (do-search-list (entry device first)
+	       (let ((name (concatenate 'simple-string entry remainder)))
+		 (unless first
+		   (setf first name))
+		 (when (mach:unix-file-kind name)
+		   (return name))))))
+	  (t
+	   (concatenate 'simple-string
+			(car (resolve-search-list device t))
+			(namestring-without-device pathname))))))
 
 
 
@@ -442,7 +475,7 @@
 
 ;;; Truename  --  Public
 ;;;
-;;;    Another silly file function trivially different from another function.
+;;; Another silly file function trivially different from another function.
 ;;;
 (defun truename (pathname)
   "Return the pathname for the actual file described by the pathname
@@ -452,100 +485,24 @@
       (error "The file ~S does not exist." (namestring pathname)))
     result))
 
-;;; Do-Search-List  --  Internal
-;;;
-;;;    Bind var in turn to each element of search list with the specifed
-;;; name.
-;;;
-(defmacro do-search-list ((var name &optional exit-form) . body)
-  "Do-Search-List (Var Name [Exit-Form]) {Form}*"
-  `(dolist (,var (resolve-search-list ,name nil) ,exit-form)
-     (declare (simple-string ,var))
-     ,@body))
-
-
-;;; Sub-Probe-File  --  Internal
-;;;
-;;;    Does the work of Probe-File, returning an additional value which
-;;; indicates whether the name is really a file.
-;;;
-(defun sub-probe-file (pathname)
-  (setq pathname (pathname pathname))
-  (flet ((pathnamify (ns etype)
-	   (declare (simple-string ns))
-	   (case etype
-	     (:entry_remote
-	      (values (parse-namestring (concatenate 'simple-string ns "/"))
-		      :entry_directory))
-	     (t
-	      (values (parse-namestring ns) etype)))))
-    (let ((log-name (or (%pathname-device pathname) "default")))
-      (if (eq log-name :absolute)
-	  (let ((namestring (namestring pathname)))
-	    (multiple-value-bind (name etype)
-				 (mach:unix-subtestname namestring)
-	      (if (null name) NIL
-		  (pathnamify name etype))))
-	  (if (null (%pathname-device pathname))
-	      (multiple-value-bind (name etype)
-				   (mach:unix-subtestname
-				    (%ses-get-useful-name pathname))
-		(if (null name) NIL (pathnamify name etype)))
-	      (let ((namestring (%ses-get-useful-name pathname)))
-		(do-search-list (entry log-name)
-		  (let ((str (concatenate 'simple-string entry namestring)))
-		    (declare (simple-string str))
-		    (multiple-value-bind (name etype)
-					 (mach:unix-subtestname str)
-		      (when name
-			(return (pathnamify name etype))))))))))))
-
-
 ;;; Probe-File  --  Public
 ;;;
-;;;    Just call Sub-Probe-File and return nil when it isn't a file.
+;;; If PATHNAME exists, return it's truename, otherwise NIL.
 ;;;
 (defun probe-file (pathname)
   "Return a pathname which is the truename of the file if it exists, NIL
   otherwise.  Returns NIL for directories and other non-file entries."
-  (multiple-value-bind (pn f)
-		       (sub-probe-file pathname)
-    (if (eq f :entry_file) pn)))
-
+  (let ((namestring (unix-namestring pathname t)))
+    (when (mach:unix-file-kind namestring)
+      (let ((truename (mach:unix-resolve-links
+		       (mach:unix-maybe-prepend-current-directory
+			namestring))))
+	(when truename
+	  (pathname (mach:unix-simplify-pathname truename)))))))
 
 
-;;; Predict-Name  --  Internal
-;;;
-;;;    Predict-Name is a function used by Open to get an absolute pathname 
-;;; for a file being opened.  Returns the truename of the file and
-;;; whether it really exists or not.
-;;;
-(defun predict-name (file-name for-input)
-  (let* ((pathname (pathname file-name))
-	 (device (%pathname-device pathname))
-	 (truename (probe-file pathname)))
-    (cond ((eq device :absolute)
-	   (if truename
-	       (values (namestring truename) t)
-	       ;; Try again in case file-name is a directory.
-	       (predict-name-with-subtest (namestring pathname))))
-	  ((and for-input truename)
-	   (values (namestring truename) t))
-	  (t
-	   (let ((expansion (resolve-search-list (or device "default") t)))
-	     (let ((name (concatenate 'simple-string (car expansion)
-				      (%ses-get-useful-name pathname))))
-	       (declare (simple-string name))
-	       (predict-name-with-subtest name)))))))
-
-(defun predict-name-with-subtest (name)
-  (let ((gr (mach:unix-subtestname name)))
-    (if gr
-	(values gr t)
-	(values (mach::simplify-file-name name) nil))))
-
+;;;; Other random operations.
 
-
 ;;; Rename-File  --  Public
 ;;;
 ;;;    If File is a File-Stream, then rename the associated file if it exists,
@@ -556,25 +513,19 @@
   "Rename File to have the specified New-Name.  If file is a stream open to a
   file, then the associated file is renamed.  If the file does not yet exist
   then the file is created with the New-Name when the stream is closed."
-  (if (streamp file)
-      (let* ((name (file-name file))
-	     (pn (parse-namestring name))
-	     (npn (merge-pathnames new-name pn))
-	     (new (predict-name npn nil)))
-	(when (mach:quick-subtestname name)
-	  (multiple-value-bind (res err) (mach:Unix-rename name new)
-	    (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A."
-				  name new (mach:get-unix-error-msg err)))))
-	(file-name file new)
-	(values npn pn (parse-namestring new)))
-      (let* ((pn (or (sub-probe-file file)
-		     (error "File to rename does not exist: ~S" file)))
-	     (npn (merge-pathnames new-name pn))
-	     (new (predict-name npn nil)))
-	(multiple-value-bind (res err) (mach:unix-rename (namestring pn) new)
-	  (if res (values npn pn (parse-namestring new))
-	      (error "Failed to rename ~A to ~A, unix error: ~A."
-		     (namestring pn) new (mach:get-unix-error-msg err)))))))
+  (let* ((original (truename file))
+	 (original-namestring (namestring original))
+	 (new-name (merge-pathnames new-name original))
+	 (new-namestring (unix-namestring new-name nil)))
+    (multiple-value-bind (res error)
+			 (mach:unix-rename original-namestring
+					   new-namestring)
+      (unless res
+	(error "Failed to rename ~A to ~A: ~A"
+	       original new-name (mach:get-unix-error-msg error)))
+      (when (streamp file)
+	(file-name file new-namestring))
+      (values new-name original (truename new-namestring)))))
 
 ;;; Delete-File  --  Public
 ;;;
@@ -582,18 +533,17 @@
 ;;;
 (defun delete-file (file)
   "Delete the specified file."
-  (let ((tn (sub-probe-file file)))
+  (let ((namestring (unix-namestring file t)))
     (when (streamp file)
       (close file :abort t))
-    (if tn
-	(let ((ns (namestring tn)))
-	  (multiple-value-bind (res err) (mach:unix-unlink ns)
-	    (if (null res)
-		(error "Failed to delete ~A, unix error: ~A."
-		       ns (mach:get-unix-error-msg err)))))
-	(unless (streamp file)
-	  (error "File to be deleted does not exist: ~S" file)))) 
+    (when namestring
+      (multiple-value-bind (res err) (mach:unix-unlink namestring)
+	(unless res
+	  (error "Could not delete ~A: ~A."
+		 namestring
+		 (mach:get-unix-error-msg err))))))
   t)
+
 
 ;;; User-Homedir-Pathname  --  Public
 ;;;
@@ -620,120 +570,171 @@
 ;;;
 (defun file-write-date (file)
   "Return file's creation date, or NIL if it doesn't exist."
-  (let ((tn (sub-probe-file file)))
-    (when tn
-      (multiple-value-bind (res dev ino mode nlink uid gid
-				rdev size atime mtime)
-			   (mach:unix-stat (namestring tn))
-	(declare (ignore dev ino mode nlink uid gid rdev size atime))
-	(if (null res) 0
-	    (+ unix-to-universal-time mtime))))))
+  (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))))
 
 ;;; 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."
-  (let ((filename (truename file)))
-    (multiple-value-bind (winp dev ino mode nlink uid)
-			 (mach:unix-stat (namestring filename))
-      (declare (ignore dev ino mode nlink))
-      (if winp (lookup-login-name uid)))))
+  (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))))
 
 
 
 ;;;; DIRECTORY.
 
-;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry
-;;; type.  Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY.
+;;; PARSE-PATTERN  --  internal.
+;;;
+;;; Parse-pattern extracts the name portion of pathname and converts it into
+;;; a pattern usable in match-pattern-p.
+;;; 
+(defun parse-pattern (pathname)
+  (let ((string (file-namestring pathname))
+	(pattern nil)
+	(last-regular-char nil)
+	(index 0))
+    (flet ((flush-pending-regulars ()
+	     (when last-regular-char
+	       (push (subseq string last-regular-char index) pattern))
+	     (setf last-regular-char nil)))
+      (loop
+	(when (>= index (length string))
+	  (return))
+	(let ((char (schar string index)))
+	  (cond ((char= char #\?)
+		 (flush-pending-regulars)
+		 (push :single-char-wild pattern)
+		 (incf index))
+		((char= char #\*)
+		 (flush-pending-regulars)
+		 (push :multi-char-wild pattern)
+		 (incf index))
+		((char= char #\[)
+		 (flush-pending-regulars)
+		 (let ((close-bracket (position #\] string :start index)))
+		   (unless close-bracket
+		     (error "``['' with no corresponding ``]'': ~S" string))
+		   (push :character-set pattern)
+		   (push (subseq string (1+ index) close-bracket)
+			 pattern)
+		   (setf index (1+ close-bracket))))
+		(t
+		 (unless last-regular-char
+		   (setf last-regular-char index))
+		 (incf index)))))
+      (flush-pending-regulars))
+    (nreverse pattern)))
+
+;;; MATCH-PATTERN-P  --  internal.
 ;;;
-(defmacro do-directory ((name-var etype-var pattern &optional (all t) result)
-			. body)
-  "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*.
-   If All is non-nil (the default), then Unix dot files to be processed.
-   Unix dot and dot-dot are never processed."
-  (let ((file (gensym))
-	(res (gensym))
-	(type (gensym))
-	(p (gensym)))
-    `(dolist (,file (mach:unix-search-directory ,pattern ,all)
-		    ,result)
-       (declare (simple-string ,file))
-       (let* ((,p (position #\/ ,file :from-end t))
-	      (,name-var
-	       (if ,p
-		   (subseq ,file (the fixnum (1+ (the fixnum ,p))))
-		   ,file)))
-	 (declare (simple-string ,name-var))
-	 (unless (or (string= "." ,name-var) (string= ".." ,name-var))
-	   (let ((,etype-var (multiple-value-bind (,res ,type)
-						  (mach:quick-subtestname ,file)
-			       (declare (ignore ,res))
-			       ,type)))
-	     ,@body))))))
-
-(defun directory (pathname &key (all t))
+;;; Determine if string (starting at start) matches pattern.
+;;; 
+(defun match-pattern-p (string pattern &optional (start 0))
+  (cond ((null pattern)
+	 (= start (length string)))
+	((eq (car pattern) :single-char-wild)
+	 (and (> (length string) start)
+	      (match-pattern-p string (cdr pattern) (1+ start))))
+	((eq (car pattern) :character-set)
+	 (and (> (length string) start)
+	      (find (schar string start) (cadr pattern))
+	      (match-pattern-p string (cddr pattern) (1+ start))))
+	((eq (car pattern) :multi-char-wild)
+	 (do ((new-start (length string) (1- new-start)))
+	     ((< new-start start) nil)
+	   (when (match-pattern-p string (cdr pattern) new-start)
+	     (return t))))
+	((stringp (car pattern))
+	 (let* ((expected (car pattern))
+		(len (length expected))
+		(new-start (+ start len)))
+	   (and (>= (length string) new-start)
+		(string= string expected :start1 start :end1 new-start)
+		(match-pattern-p string (cdr pattern) new-start))))
+	(t
+	 (error "Bogus thing in pattern: ~S" (car pattern)))))
+
+;;; MATCHING-FILES-IN-DIR  --  internal
+;;;
+;;; Return a list of all the files in the directory dirname that match
+;;; pattern.  If all is nil, ignore files starting with a ``.''.
+;;; 
+(defun matching-files-in-dir (dirname pattern all)
+  (let ((dir (mach:open-dir dirname)))
+    (if dir
+	(unwind-protect
+	    (let ((results nil))
+	      (loop
+		(let ((name (mach:read-dir dir)))
+		  (cond ((null name)
+			 (return))
+			((or (string= name ".")
+			     (string= name "..")
+			     (and (not all)
+				  (char= (schar name 0) #\.))))
+			((or (null pattern)
+			     (match-pattern-p name pattern))
+			 (if (zerop (length dirname))
+			     (push name results)
+			     (push (concatenate 'string dirname name)
+				   results))))))
+	      (values results t))
+	  (mach:close-dir dir))
+	(values nil nil))))
+
+;;; DIRECTORY  --  public.
+;;; 
+(defun directory (pathname &key (all t) (check-for-subdirs t))
   "Returns a list of pathnames, one for each file that matches the given
    pathname.  Supplying :all as nil causes this to ignore Unix dot files.  This
    never includes Unix dot and dot-dot in the result."
-  (setq pathname (pathname pathname))
-  (multiple-value-bind (dir pattern) (find-directory pathname)
-    (let ((res ()))
-      (do-directory (name etype pattern all)
-	(if (eq etype :entry_file)
-	    (let ((last-dot (position #\. name :from-end t)))
-	      (push
-	       (%make-pathname
-		"Mach" :absolute dir
-		(if last-dot (subseq name 0 last-dot) name)
-		(if last-dot (subseq name (1+ last-dot)))
-		nil)
-	       res))
-	    (push
-	     (%make-pathname
-	      "Mach" :absolute
-	      (concatenate 'simple-vector dir (vector name))
-	      nil nil nil)
-	     res)))
-      (nreverse res))))
-
-;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a
-;;; first argument and an absolute namestring.  The namestring includes a
-;;; trailing asterisk, wildcard, when the given pathname is immediately
-;;; probe-able as a directory.
-;;;
-(defun find-directory (pathname)
-  (multiple-value-bind (pn type)
-		       (sub-probe-file pathname)
-    (if pn
-	(let ((ns (namestring pn)))
-	  (declare (simple-string ns))
-	  (case type
-	    (:entry_directory
-	     (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/)
-	       (setq ns (concatenate 'simple-string ns "/")))
-	     (values (%pathname-directory (pathname ns))
-		     (concatenate 'simple-string ns "*")))
-	    (t (values (%pathname-directory pn) ns))))
-	(multiple-value-bind (pn type)
-			     (sub-probe-file
-			      (make-pathname
-			       :directory (%pathname-directory pathname)
-			       :device (%pathname-device pathname)))
-	  (unless pn
-	    (error "Directory does not exist: ~S" pathname))
-	  (let ((ns (namestring pn)))
-	    (case type
-	      (:entry_directory
-	       (values
-		(%pathname-directory pn)
-		(concatenate 'simple-string ns (file-namestring pathname))))
-	      (t
-	       (error "~S is not a directory." pathname))))))))
-
+  (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
+	 (device (%pathname-device pathname))
+	 (pattern (parse-pattern pathname))
+	 (results nil)
+	 (really-won nil))
+    (if (or (eq device :absolute)
+	    (null device)
+	    (string= device "Default"))
+	(multiple-value-setq (results really-won)
+	  (matching-files-in-dir (directory-namestring pathname) pattern all))
+	(let ((remainder (namestring-without-device
+			  (directory-namestring pathname))))
+	  (do-search-list (dir device)
+	    (multiple-value-bind
+		(files won)
+		(matching-files-in-dir (concatenate 'simple-string
+						    dir
+						    remainder)
+				       pattern
+				       all)
+	      (when won
+		(setf really-won t))
+	      (setf results (append results files))))))
+    (unless really-won
+      (error "Could not find ~S." pathname))
+    (setf results
+	  (sort (delete-duplicates results :test #'string=)
+		#'string<))
+    (mapcar #'(lambda (name)
+		(if (and check-for-subdirs
+			 (eq (mach:unix-file-kind name) :directory))
+		    (pathname (concatenate 'string name "/"))
+		    (pathname name)))
+	    results)))
 
 
-;;;; Printing directories and determining file owner names.
+;;;; Printing directories.
+
+#|
 
 ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
 ;;; 
@@ -864,6 +865,7 @@
 	  (terpri))))
     (when return-list (nreverse result))))
 
+|#
 
 
 ;;;; Translating uid's and gid's.
@@ -939,93 +941,64 @@
 				      :start2 id-start :end2 id-end))
 		    (return (subseq entry 0 name-end))))))))))))
 
-
 
-;;; Complete-One-File  --  Internal
-;;;
-;;;    Return as values a string and the greatest common prefix of all
-;;; the files corresponding to pattern.
-;;;
-(defun complete-one-file (pattern default-type ignore-types)
-  (let ((first nil)
-	(length nil))
-    (do-directory (name etype pattern nil)
-      (declare (ignore etype))
-      (let* ((last-dot (position #\. name :from-end t))
-	     (type (if last-dot (subseq name (1+ last-dot)))))
-	(cond ((and (not (string= type default-type))
-		    (member type ignore-types :test #'string=)))
-	      (first
-	       (let ((msm (string-not-equal name first :end2 length)))
-		 (when (and msm (< msm length))
-		   (setq length msm))))
-	      (t
-	       (setq first name)
-	       (setq length (length name))))))
-    (values first length)))
-
-
-;;; Complete-File  --  Public
-;;;
-;;;    If the pathname is absolute, just call Complete-One-File on and test
-;;; whether the result is a file.  If a relative pathname, do it on each
-;;; directory, accumulating the result.
+;;;; File completion.
+
+(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
+			       ignore-types)
+  ;; Find all possible pathnames.
+  (let ((files
+	 (directory (concatenate 'string
+				 (namestring (merge-pathnames pathname
+							      defaults))
+				 "*")
+		    :check-for-subdirs nil)))
+    (cond ((null files)
+	   (values nil nil))
+	  ((null (cdr files))
+	   (values (merge-pathnames (file-namestring (car files))
+				    pathname)
+		   t))
+	  (t
+	   (let ((good-files
+		  (delete-if #'(lambda (pathname)
+				 (and (pathname-type pathname)
+				      (member (pathname-type pathname)
+					      ignore-types
+					      :test #'string=)))
+			     files)))
+	     (cond ((null good-files))
+		   ((null (cdr good-files))
+		    (return-from complete-file
+				 (values (merge-pathnames (file-namestring
+							   (car good-files))
+							  pathname)
+					 t)))
+		   (t
+		    (setf files good-files)))
+	     (let ((common (file-namestring (car files))))
+	       (dolist (file (cdr files))
+		 (let ((name (file-namestring file)))
+		   (dotimes (i (min (length common) (length name))
+			       (when (< (length name) (length common))
+				 (setf common name)))
+		     (unless (char= (schar common i) (schar name i))
+		       (setf common (subseq common 0 i))
+		       (return)))))
+	       (values (merge-pathnames common pathname)
+		       nil)))))))
+
+;;; Ambiguous-Files  --  Public
 ;;;
-(defun complete-file (pathname &key defaults ignore-types)
-  "Attempt to complete Pathname as the name of a file.  If the resulting
-  completion is unique, return T as the second value.  If there is no
-  possible completion, return both values NIL."
-  (setq pathname (pathname pathname))
-  (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*))
-  (flet ((pathnamify (res len ambiguous pathname)
-		     (values 
-		      (make-pathname :device (%pathname-device pathname)
-				     :directory (%pathname-directory pathname)
-				     :defaults (parse-namestring (subseq res 0 len)))
-		      (not ambiguous))))
-    (let ((dev (or (%pathname-device pathname) "default"))
-	  (default-type (%pathname-type defaults)))
-      (if (eq dev :absolute)
-	  (multiple-value-bind
-	      (res len)
-	      (complete-one-file (concatenate 'simple-string
-					      (namestring pathname)
-					      "*")
-				 default-type ignore-types)
-	    (declare (fixnum len))
-	    (if res
-		(pathnamify res len
-			    (/= (the fixnum (length res)) len)
-			    pathname)
-		(values nil nil)))
-	  (let ((namestring (%ses-get-useful-name pathname))		 
-		(dirs (if (and (%pathname-directory defaults)
-			       (string-equal dev "default"))
-			  (list (directory-namestring defaults))
-			  ()))
-		(max most-positive-fixnum)
-		(max-str nil)
-		(ambiguous nil))
-	    (declare (simple-string namestring))
-	    (do-search-list (entry dev)
-			    (pushnew entry dirs :test #'string-equal))
-	    (dolist (entry dirs)
-	      (let ((str (concatenate 'simple-string entry namestring "*")))
-		(declare (simple-string str))
-		(multiple-value-bind
-		    (res len)
-		    (complete-one-file str default-type ignore-types)
-		  (when res
-		    (unless ambiguous
-		      (setq ambiguous (or max-str (/= (length res) len))))
-		    (if max-str
-			(setq max (or (string-not-equal res max-str :end1 len
-							:end2 max)
-				      max))
-			(setq max len  max-str res))))))
-	    (if max-str
-		(pathnamify max-str max ambiguous pathname)
-		(values nil nil)))))))
+(defun ambiguous-files (pathname &optional defaults)
+  "Return a list of all files which are possible completions of Pathname.
+  We look in the directory specified by Defaults as well as looking down
+  the search list."
+  (directory (concatenate 'string
+			  (namestring (merge-pathnames pathname defaults))
+			  "*")
+	     :check-for-subdirs nil))
+
 
 ;;; File-writable -- exported from extensions.
 ;;;
@@ -1035,11 +1008,11 @@
 (defun file-writable (name)
   "File-writable accepts a pathname and returns T if the current
   process can write it, and NIL otherwise."
-  (multiple-value-bind (tn exists) (predict-name name nil)
-    (if exists
-	(values (mach:unix-access tn mach:w_ok))
-	(values (mach:unix-access (directory-namestring tn)
-				  (logior mach:w_ok mach:x_ok))))))
+  (let ((truename (probe-file name)))
+    (values
+     (mach:unix-access
+      (unix-namestring (or truename (directory-namestring name)) t)
+      (if truename mach:w_ok (logior mach:w_ok mach:x_ok))))))
 
 
 ;;; Pathname-Order  --  Internal
@@ -1057,34 +1030,6 @@
 		(t t)))
 	xn)))
 
-;;; Ambiguous-Files  --  Public
-;;;
-;;;    If the pathname is absolute, just do a directory.  If it is relative,
-;;; do a directory on each directory in the search-list and merge the results.
-;;;
-(defun ambiguous-files (pathname &optional defaults)
-  "Return a list of all files which are possible completions of Pathname.
-  We look in the directory specified by Defaults as well as looking down
-  the search list."
-  (setq pathname (pathname pathname)
-	defaults (if defaults (pathname defaults) *default-pathname-defaults*))
-  (let ((dev (or (%pathname-device pathname) "default")))
-    (if (eq dev :absolute)
-	(directory (concatenate 'simple-string (namestring pathname) "*"))
-	(let ((namestring (%ses-get-useful-name pathname))		 
-	      (dirs (if (and (%pathname-directory defaults)
-			     (string-equal dev "default"))
-			(list (directory-namestring defaults))
-			()))
-	      (res ()))
-	  (declare (simple-string namestring))
-	  (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal))
-	  (dolist (entry dirs)
-	    (let ((str (concatenate 'simple-string entry namestring "*")))
-	      (declare (simple-string str))
-	      (setq res (merge 'list res (directory str)
-			       #'pathname-order))))
-	  res))))
 
 ;;; Default-Directory  --  Public
 ;;;
@@ -1112,7 +1057,7 @@
 ;;; 
 (defun %set-default-directory (new-val)
   (multiple-value-bind (gr error)
-		       (mach:unix-chdir (predict-name new-val nil))
+		       (mach:unix-chdir (unix-namestring new-val t))
     (if gr
 	(car (setf (search-list "default:")
 		   (list (default-directory))))
-- 
GitLab