X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=849d66ed4baaa9a4e7ca1b9699e18e0b9fd5a4a2;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=b4d48c63fe7af178b2bcd963ab2a75a1645aa223;hpb=0f3d47226b4c3f9fcc350e681443534701d56aa4;p=sbcl.git

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index b4d48c6..849d66e 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -54,7 +54,7 @@
    checked for whatever they may have protected."
   (declare (type simple-base-string namestr)
 	   (type index start end))
-  (let* ((result (make-string (- end start)))
+  (let* ((result (make-string (- end start) :element-type 'base-char))
 	 (dst 0)
 	 (quoted nil))
     (do ((src start (1+ src)))
@@ -521,9 +521,9 @@
 	(let ((piece (car tail)))
 	  (etypecase piece
 	    (simple-string
-	     (let ((head (concatenate 'string head piece)))
+	     (let ((head (concatenate 'base-string head piece)))
 	       (with-directory-node-noted (head)
-		 (%enumerate-directories (concatenate 'string head "/")
+		 (%enumerate-directories (concatenate 'base-string head "/")
 					 (cdr tail) pathname
 					 verify-existence follow-links
 					 nodes function))))
@@ -532,7 +532,7 @@
 				     verify-existence follow-links
 				     nodes function)
 	     (dolist (name (ignore-errors (directory-lispy-filenames head)))
-	       (let ((subdir (concatenate 'string head name)))
+	       (let ((subdir (concatenate 'base-string head name)))
 		 (multiple-value-bind (res dev ino mode)
 		     (unix-xstat subdir)
 		   (declare (type (or fixnum null) mode))
@@ -543,14 +543,14 @@
 					  (eql (cdr dir) ino))
 				 (return t)))
 		       (let ((nodes (cons (cons dev ino) nodes))
-			     (subdir (concatenate 'string subdir "/")))
+			     (subdir (concatenate 'base-string subdir "/")))
 			 (%enumerate-directories subdir tail pathname
 						 verify-existence follow-links
 						 nodes function))))))))
 	    ((or pattern (member :wild))
 	     (dolist (name (directory-lispy-filenames head))
 	       (when (or (eq piece :wild) (pattern-matches piece name))
-		 (let ((subdir (concatenate 'string head name)))
+		 (let ((subdir (concatenate 'base-string head name)))
 		   (multiple-value-bind (res dev ino mode)
 		       (unix-xstat subdir)
 		     (declare (type (or fixnum null) mode))
@@ -558,15 +558,15 @@
 				(eql (logand mode sb!unix:s-ifmt)
 				     sb!unix:s-ifdir))
 		       (let ((nodes (cons (cons dev ino) nodes))
-			     (subdir (concatenate 'string subdir "/")))
+			     (subdir (concatenate 'base-string subdir "/")))
 			 (%enumerate-directories subdir (rest tail) pathname
 						 verify-existence follow-links
 						 nodes function))))))))
 	  ((member :up)
 	     (with-directory-node-removed (head)
-	     (let ((head (concatenate 'string head "..")))
+	     (let ((head (concatenate 'base-string head "..")))
 	       (with-directory-node-noted (head)
-		 (%enumerate-directories (concatenate 'string head "/")
+		 (%enumerate-directories (concatenate 'base-string head "/")
 					 (rest tail) pathname
 					 verify-existence follow-links
 					 nodes function)))))))
@@ -608,19 +608,19 @@
 			  (components-match file-type type)
 			  (components-match file-version version))
 		 (funcall function
-			  (concatenate 'string
+			  (concatenate 'base-string
 				       directory
 				       complete-filename))))))
 	  (t
 	   (/noshow0 "default case")
-	   (let ((file (concatenate 'string directory name)))
+	   (let ((file (concatenate 'base-string directory name)))
 	     (/noshow "computed basic FILE")
 	     (unless (or (null type) (eq type :unspecific))
 	       (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
-	       (setf file (concatenate 'string file "." type)))
-	     (unless (member version '(nil :newest :wild))
+	       (setf file (concatenate 'base-string file "." type)))
+	     (unless (member version '(nil :newest :wild :unspecific))
 	       (/noshow0 "tweaking FILE for more-or-less-:WILD case")
-	       (setf file (concatenate 'string file "."
+	       (setf file (concatenate 'base-string file "."
 				       (quick-integer-to-string version))))
 	     (/noshow0 "finished possibly tweaking FILE")
 	     (when (or (not verify-existence)
@@ -638,11 +638,11 @@
 	((zerop n) "0")
 	((eql n 1) "1")
 	((minusp n)
-	 (concatenate 'simple-string "-"
-		      (the simple-string (quick-integer-to-string (- n)))))
+	 (concatenate 'simple-base-string "-"
+		      (the simple-base-string (quick-integer-to-string (- n)))))
 	(t
 	 (do* ((len (1+ (truncate (integer-length n) 3)))
-	       (res (make-string len))
+	       (res (make-string len :element-type 'base-char))
 	       (i (1- len) (1- i))
 	       (q n)
 	       (r 0))
@@ -682,14 +682,16 @@
 (defun unix-namestring (pathname-spec &optional (for-input t))
   (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
 	 (matches nil)) ; an accumulator for actual matches
+    (when (wild-pathname-p namestring)
+      (error 'simple-file-error
+	     :pathname namestring
+	     :format-control "bad place for a wild pathname"))
     (!enumerate-matches (match namestring nil :verify-existence for-input)
 			(push match matches))
     (case (length matches)
       (0 nil)
       (1 (first matches))
-      (t (error 'simple-file-error
-		:format-control "~S is ambiguous:~{~%  ~A~}"
-		:format-arguments (list pathname-spec matches))))))
+      (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))
 
 ;;;; TRUENAME and PROBE-FILE
 
@@ -703,27 +705,19 @@
 
   Under Unix, the TRUENAME of a broken symlink is considered to be
   the name of the broken symlink itself."
-  (if (wild-pathname-p pathname)
+  (let ((result (probe-file pathname)))
+    (unless result
       (error 'simple-file-error
-	     :format-control "can't use a wild pathname here"
-	     :pathname pathname)
-      (let ((result (probe-file pathname)))
-	(unless result
-	  (error 'simple-file-error
-		 :pathname pathname
-		 :format-control "The file ~S does not exist."
-		 :format-arguments (list (namestring pathname))))
-	result)))
+	     :pathname pathname
+	     :format-control "The file ~S does not exist."
+	     :format-arguments (list (namestring pathname))))
+    result))
 
 ;;; If PATHNAME exists, return its truename, otherwise NIL.
 (defun probe-file (pathname)
   #!+sb-doc
   "Return a pathname which is the truename of the file if it exists, or NIL
   otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
-  (when (wild-pathname-p pathname)
-    (error 'simple-file-error
-	   :pathname pathname
-	   :format-control "can't use a wild pathname here"))
   (let* ((defaulted-pathname (merge-pathnames
 			      pathname
 			      (sane-default-pathname-defaults)))
@@ -731,8 +725,11 @@
     (when (and namestring (sb!unix:unix-file-kind namestring t))
       (let ((trueishname (sb!unix:unix-resolve-links namestring)))
 	(when trueishname
-	  (let ((*ignore-wildcards* t))
-	    (pathname (sb!unix:unix-simplify-pathname trueishname))))))))
+	  (let* ((*ignore-wildcards* t)
+		 (name (sb!unix:unix-simplify-pathname trueishname))) 
+	    (if (eq (sb!unix:unix-file-kind name) :directory)
+		(pathname (concatenate 'string name "/"))
+		(pathname name))))))))
 
 ;;;; miscellaneous other operations
 
@@ -789,43 +786,30 @@
   #!+sb-doc
   "Return file's creation date, or NIL if it doesn't exist.
  An error of type file-error is signaled if file is a wild pathname"
-  (if (wild-pathname-p file)
-      ;; FIXME: This idiom appears many times in this file. Perhaps it
-      ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P
-      ;; should be a macro, not a function, so that the error message
-      ;; is reported as coming from e.g. FILE-WRITE-DATE instead of
-      ;; from CANNOT-BE-WILD-PATHNAME itself.)
-      (error 'simple-file-error
-	     :pathname file
-	     :format-control "bad place for a wild pathname")
-      (let ((name (unix-namestring file t)))
-	(when name
-	  (multiple-value-bind
-	      (res dev ino mode nlink uid gid rdev size atime mtime)
-	      (sb!unix:unix-stat name)
-	    (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)
+	  (sb!unix:unix-stat name)
+	(declare (ignore dev ino mode nlink uid gid rdev size atime))
+	(when res
+	  (+ unix-to-universal-time mtime))))))
 
 (defun file-author (file)
   #!+sb-doc
   "Return the file author as a string, or NIL if the author cannot be
  determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
  or FILE is a wild pathname."
-  (if (wild-pathname-p file)
+  (let ((name (unix-namestring (pathname file) t)))
+    (unless name
       (error 'simple-file-error
 	     :pathname file
-	     "bad place for a wild pathname")
-      (let ((name (unix-namestring (pathname file) t)))
-	(unless name
-	  (error 'simple-file-error
-		 :pathname file
-		 :format-control "~S doesn't exist."
-		 :format-arguments (list file)))
-	(multiple-value-bind (winp dev ino mode nlink uid)
-	    (sb!unix:unix-stat name)
-	  (declare (ignore dev ino mode nlink))
-	  (and winp (sb!unix:uid-username uid))))))
+	     :format-control "~S doesn't exist."
+	     :format-arguments (list file)))
+    (multiple-value-bind (winp dev ino mode nlink uid)
+	(sb!unix:unix-stat name)
+      (declare (ignore dev ino mode nlink))
+      (and winp (sb!unix:uid-username uid)))))
 
 ;;;; DIRECTORY
 
@@ -843,14 +827,10 @@
 	;; (which can arise when e.g. multiple symlinks map to the
 	;; same truename).
 	(truenames (make-hash-table :test #'equal))
-        (merged-pathname (merge-pathnames pathname
-					  *default-pathname-defaults*)))
+        (merged-pathname (merge-pathnames pathname)))
     (!enumerate-matches (match merged-pathname)
-      (let ((*ignore-wildcards* t)
-            (truename (truename (if (eq (sb!unix:unix-file-kind match)
-					:directory)
-                                    (concatenate 'string match "/")
-                                    match))))
+      (let* ((*ignore-wildcards* t)
+	     (truename (truename match)))
         (setf (gethash (namestring truename) truenames)
 	      truename)))
     (mapcar #'cdr