0.8.2.7:

[sbcl.git] / src / code / filesys.lisp

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index b4d48c6..849d66e 100644 (file)
--- 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))
    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)))
         (dst 0)
         (quoted nil))
     (do ((src start (1+ src)))

@@ -521,9 +521,9 @@
        (let ((piece (car tail)))
          (etypecase piece
            (simple-string
        (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)
               (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))))
                                         (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)))
                                     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))
                 (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))
                                          (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))
                         (%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))
                   (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))
                                (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)
                         (%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)
               (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)))))))
                                         (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
                          (components-match file-type type)
                          (components-match file-version version))
                 (funcall function

-                         (concatenate 'string
+                         (concatenate 'base-string

                                       directory
                                       complete-filename))))))
          (t
           (/noshow0 "default case")
                                       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")
             (/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")
               (/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)
                                       (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)
        ((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)))
        (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))
               (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
 (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))
     (!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")))))

 \f
 ;;;; TRUENAME and PROBE-FILE
 
 \f
 ;;;; 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."
 
   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
       (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."
 
 ;;; 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)))
   (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
     (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))))))))

 \f
 ;;;; miscellaneous other operations
 
 \f
 ;;;; 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"
   #!+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."
 
 (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
       (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)))))

 \f
 ;;;; DIRECTORY
 
 \f
 ;;;; DIRECTORY
 

@@ -843,14 +827,10 @@
        ;; (which can arise when e.g. multiple symlinks map to the
        ;; same truename).
        (truenames (make-hash-table :test #'equal))
        ;; (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)
     (!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
         (setf (gethash (namestring truename) truenames)
              truename)))
     (mapcar #'cdr