0.8.16.25:

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

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index fd67375..aa8b501 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -16,14 +16,11 @@
 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]
 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]

-;;; directory := [ "/" | search-list ] { file "/" }*
-;;; search-list := [^:/]*:
+;;; directory := [ "/" ] { file "/" }*

 ;;; file := [^/]*
 ;;; type := "." [^/.]*
 ;;; version := "." ([0-9]+ | "*")
 ;;;
 ;;; file := [^/]*
 ;;; type := "." [^/.]*
 ;;; version := "." ([0-9]+ | "*")
 ;;;

-;;; FIXME: Search lists are no longer supported.
-;;;

 ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
 ;;; parsed as either just the file specified or as specifying the
 ;;; file, type, and version. Therefore, we use the following rules
 ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
 ;;; parsed as either just the file specified or as specifying the
 ;;; file, type, and version. Therefore, we use the following rules

@@ -57,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)))

@@ -161,40 +158,16 @@
   (declare (type simple-base-string namestr)
           (type index start end))
   (let* ((last-dot (position #\. namestr :start (1+ start) :end end
   (declare (type simple-base-string namestr)
           (type index start end))
   (let* ((last-dot (position #\. namestr :start (1+ start) :end end

-                            :from-end t))
-        (second-to-last-dot (and last-dot
-                                 (position #\. namestr :start (1+ start)
-                                           :end last-dot :from-end t)))
-        (version :newest))
-    ;; If there is a second-to-last dot, check to see whether there is
-    ;; a valid version after the last dot.
-    (when second-to-last-dot
-      (cond ((and (= (+ last-dot 2) end)
-                 (char= (schar namestr (1+ last-dot)) #\*))
-            (setf version :wild))
-           ((and (< (1+ last-dot) end)
-                 (do ((index (1+ last-dot) (1+ index)))
-                     ((= index end) t)
-                   (unless (char<= #\0 (schar namestr index) #\9)
-                     (return nil))))
-            (setf version
-                  (parse-integer namestr :start (1+ last-dot) :end end)))
-           (t
-            (setf second-to-last-dot nil))))
-    (cond (second-to-last-dot
-          (values (maybe-make-pattern namestr start second-to-last-dot)
-                  (maybe-make-pattern namestr
-                                      (1+ second-to-last-dot)
-                                      last-dot)
-                  version))
-         (last-dot
-          (values (maybe-make-pattern namestr start last-dot)
-                  (maybe-make-pattern namestr (1+ last-dot) end)
-                  version))
-         (t
-          (values (maybe-make-pattern namestr start end)
-                  nil
-                  version)))))
+                            :from-end t)))
+    (cond 
+      (last-dot
+       (values (maybe-make-pattern namestr start last-dot)
+              (maybe-make-pattern namestr (1+ last-dot) end)
+              :newest))
+      (t
+       (values (maybe-make-pattern namestr start end)
+              nil
+              :newest)))))

 
 (/show0 "filesys.lisp 200")
 
 
 (/show0 "filesys.lisp 200")
 

@@ -218,89 +191,69 @@
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 

-(defun maybe-extract-search-list (namestr start end)
-  (declare (type simple-base-string namestr)
-          (type index start end))
-  (let ((quoted nil))
-    (do ((index start (1+ index)))
-       ((= index end)
-        (values nil start))
-      (if quoted
-         (setf quoted nil)
-         (case (schar namestr index)
-           (#\\
-            (setf quoted t))
-           (#\:
-            (return (values (remove-backslashes namestr start index)
-                            (1+ index)))))))))
-

 (defun parse-unix-namestring (namestr start end)
 (defun parse-unix-namestring (namestr start end)

-  (declare (type simple-base-string namestr)
-          (type index start end))
+  (declare (type simple-string namestr)
+           (type index start end))
+  (setf namestr (coerce namestr 'simple-base-string))

   (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
   (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)

-    (let ((search-list (if absolute
-                          nil
-                          (let ((first (car pieces)))
-                            (multiple-value-bind (search-list new-start)
-                                (maybe-extract-search-list namestr
-                                                           (car first)
-                                                           (cdr first))
-                              (when search-list
-                                (setf absolute t)
-                                (setf (car first) new-start))
-                              search-list)))))
-      (multiple-value-bind (name type version)
-         (let* ((tail (car (last pieces)))
-                (tail-start (car tail))
-                (tail-end (cdr tail)))
-           (unless (= tail-start tail-end)
-             (setf pieces (butlast pieces))
-             (extract-name-type-and-version namestr tail-start tail-end)))
-       ;; PVE: make sure there are no illegal characters in
-       ;; the name, illegal being (code-char 0) and #\/
-       #!+high-security
-       (when (and (stringp name)
-                  (find-if #'(lambda (x) (or (char= x (code-char 0))
-                                             (char= x #\/)))
-                           name))
-         (error 'parse-error))
-       
-       ;; Now we have everything we want. So return it.
-       (values nil ; no host for unix namestrings.
-               nil ; no devices for unix namestrings.
-               (collect ((dirs))
-                 (when search-list
-                   (dirs (intern-search-list search-list)))
-                 (dolist (piece pieces)
-                   (let ((piece-start (car piece))
-                         (piece-end (cdr piece)))
-                     (unless (= piece-start piece-end)
-                       (cond ((string= namestr ".." :start1 piece-start
-                                       :end1 piece-end)
-                              (dirs :up))
-                             ((string= namestr "**" :start1 piece-start
-                                       :end1 piece-end)
-                              (dirs :wild-inferiors))
-                             (t
-                              (dirs (maybe-make-pattern namestr
-                                                        piece-start
-                                                        piece-end)))))))
-                 (cond (absolute
-                        (cons :absolute (dirs)))
-                       ((dirs)
-                        (cons :relative (dirs)))
-                       (t
-                        nil)))
-               name
-               type
-               version)))))
+    (multiple-value-bind (name type version)
+       (let* ((tail (car (last pieces)))
+              (tail-start (car tail))
+              (tail-end (cdr tail)))
+         (unless (= tail-start tail-end)
+           (setf pieces (butlast pieces))
+           (extract-name-type-and-version namestr tail-start tail-end)))
+
+      (when (stringp name)
+       (let ((position (position-if (lambda (char)
+                                      (or (char= char (code-char 0))
+                                          (char= char #\/)))
+                                    name)))
+         (when position
+           (error 'namestring-parse-error
+                  :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
+                  :namestring namestr
+                  :offset position))))
+      ;; Now we have everything we want. So return it.
+      (values nil ; no host for Unix namestrings
+             nil ; no device for Unix namestrings
+             (collect ((dirs))
+               (dolist (piece pieces)
+                 (let ((piece-start (car piece))
+                       (piece-end (cdr piece)))
+                   (unless (= piece-start piece-end)
+                     (cond ((string= namestr ".."
+                                     :start1 piece-start
+                                     :end1 piece-end)
+                            (dirs :up))
+                           ((string= namestr "**"
+                                     :start1 piece-start
+                                     :end1 piece-end)
+                            (dirs :wild-inferiors))
+                           (t
+                            (dirs (maybe-make-pattern namestr
+                                                      piece-start
+                                                      piece-end)))))))
+               (cond (absolute
+                      (cons :absolute (dirs)))
+                     ((dirs)
+                      (cons :relative (dirs)))
+                     (t
+                      nil)))
+             name
+             type
+             version))))

 
 (/show0 "filesys.lisp 300")
 
 (defun unparse-unix-host (pathname)
   (declare (type pathname pathname)
           (ignore pathname))
 
 (/show0 "filesys.lisp 300")
 
 (defun unparse-unix-host (pathname)
   (declare (type pathname pathname)
           (ignore pathname))

-  "Unix")
+  ;; this host designator needs to be recognized as a physical host in
+  ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
+  ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
+  ;; 2002-05-09
+  "")

 
 (defun unparse-unix-piece (thing)
   (etypecase thing
 
 (defun unparse-unix-piece (thing)
   (etypecase thing

@@ -344,7 +297,7 @@
              (t
               (error "invalid pattern piece: ~S" piece))))))
        (apply #'concatenate
              (t
               (error "invalid pattern piece: ~S" piece))))))
        (apply #'concatenate

-             'simple-string
+             'simple-base-string

              (strings))))))
 
 (defun unparse-unix-directory-list (directory)
              (strings))))))
 
 (defun unparse-unix-directory-list (directory)

@@ -353,11 +306,7 @@
     (when directory
       (ecase (pop directory)
        (:absolute
     (when directory
       (ecase (pop directory)
        (:absolute

-        (cond ((search-list-p (car directory))
-               (pieces (search-list-name (pop directory)))
-               (pieces ":"))
-              (t
-               (pieces "/"))))
+        (pieces "/"))

        (:relative
         ;; nothing special
         ))
        (:relative
         ;; nothing special
         ))

@@ -374,7 +323,7 @@
           (pieces "/"))
          (t
           (error "invalid directory component: ~S" dir)))))
           (pieces "/"))
          (t
           (error "invalid directory component: ~S" dir)))))

-    (apply #'concatenate 'simple-string (pieces))))
+    (apply #'concatenate 'simple-base-string (pieces))))

 
 (defun unparse-unix-directory (pathname)
   (declare (type pathname pathname))
 
 (defun unparse-unix-directory (pathname)
   (declare (type pathname pathname))

@@ -385,29 +334,35 @@
   (collect ((strings))
     (let* ((name (%pathname-name pathname))
           (type (%pathname-type pathname))
   (collect ((strings))
     (let* ((name (%pathname-name pathname))
           (type (%pathname-type pathname))

-          (type-supplied (not (or (null type) (eq type :unspecific))))
-          (version (%pathname-version pathname))
-          (version-supplied (not (or (null version) (eq version :newest)))))
+          (type-supplied (not (or (null type) (eq type :unspecific)))))
+      ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
+      ;; translating logical pathnames to a filesystem without
+      ;; versions (like Unix).

       (when name
       (when name

+       (when (and (null type)
+                  (typep name 'string)
+                  (> (length name) 0)
+                  (position #\. name :start 1))
+         (error "too many dots in the name: ~S" pathname))
+       (when (and (typep name 'string)
+                  (string= name ""))
+         (error "name is of length 0: ~S" pathname))

        (strings (unparse-unix-piece name)))
       (when type-supplied
        (unless name
          (error "cannot specify the type without a file: ~S" pathname))
        (strings (unparse-unix-piece name)))
       (when type-supplied
        (unless name
          (error "cannot specify the type without a file: ~S" pathname))

+       (when (typep type 'simple-string)
+         (when (position #\. type)
+           (error "type component can't have a #\. inside: ~S" pathname)))

        (strings ".")
        (strings ".")

-       (strings (unparse-unix-piece type)))
-      (when version-supplied
-       (unless type-supplied
-         (error "cannot specify the version without a type: ~S" pathname))
-       (strings (if (eq version :wild)
-                    ".*"
-                    (format nil ".~D" version)))))
-    (apply #'concatenate 'simple-string (strings))))
+       (strings (unparse-unix-piece type))))
+    (apply #'concatenate 'simple-base-string (strings))))

 
 (/show0 "filesys.lisp 406")
 
 (defun unparse-unix-namestring (pathname)
   (declare (type pathname pathname))
 
 (/show0 "filesys.lisp 406")
 
 (defun unparse-unix-namestring (pathname)
   (declare (type pathname pathname))

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

               (unparse-unix-directory pathname)
               (unparse-unix-file pathname)))
 
               (unparse-unix-directory pathname)
               (unparse-unix-file pathname)))
 

@@ -420,8 +375,11 @@
       (let* ((pathname-directory (%pathname-directory pathname))
             (defaults-directory (%pathname-directory defaults))
             (prefix-len (length defaults-directory))
       (let* ((pathname-directory (%pathname-directory pathname))
             (defaults-directory (%pathname-directory defaults))
             (prefix-len (length defaults-directory))

-            (result-dir
-             (cond ((and (> prefix-len 1)
+            (result-directory
+             (cond ((null pathname-directory) '(:relative))
+                   ((eq (car pathname-directory) :relative)
+                    pathname-directory)
+                   ((and (> prefix-len 1)

                          (>= (length pathname-directory) prefix-len)
                          (compare-component (subseq pathname-directory
                                                     0 prefix-len)
                          (>= (length pathname-directory) prefix-len)
                          (compare-component (subseq pathname-directory
                                                     0 prefix-len)

@@ -433,16 +391,11 @@
                     ;; We are an absolute pathname, so we can just use it.
                     pathname-directory)
                    (t
                     ;; We are an absolute pathname, so we can just use it.
                     pathname-directory)
                    (t

-                    ;; We are a relative directory. So we lose.
-                    (lose)))))
-       (strings (unparse-unix-directory-list result-dir)))
-      (let* ((pathname-version (%pathname-version pathname))
-            (version-needed (and pathname-version
-                                 (not (eq pathname-version :newest))))
-            (pathname-type (%pathname-type pathname))
-            (type-needed (or version-needed
-                             (and pathname-type
-                                  (not (eq pathname-type :unspecific)))))
+                    (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
+       (strings (unparse-unix-directory-list result-directory)))
+      (let* ((pathname-type (%pathname-type pathname))
+            (type-needed (and pathname-type
+                              (not (eq pathname-type :unspecific))))

             (pathname-name (%pathname-name pathname))
             (name-needed (or type-needed
                              (and pathname-name
             (pathname-name (%pathname-name pathname))
             (name-needed (or type-needed
                              (and pathname-name

@@ -451,69 +404,59 @@
                                                            defaults)))))))
        (when name-needed
          (unless pathname-name (lose))
                                                            defaults)))))))
        (when name-needed
          (unless pathname-name (lose))

+         (when (and (null pathname-type)
+                    (position #\. pathname-name :start 1))
+           (error "too many dots in the name: ~S" pathname))

          (strings (unparse-unix-piece pathname-name)))
        (when type-needed
          (when (or (null pathname-type) (eq pathname-type :unspecific))
            (lose))
          (strings (unparse-unix-piece pathname-name)))
        (when type-needed
          (when (or (null pathname-type) (eq pathname-type :unspecific))
            (lose))

+         (when (typep pathname-type 'simple-base-string)
+           (when (position #\. pathname-type)
+             (error "type component can't have a #\. inside: ~S" pathname)))

          (strings ".")
          (strings ".")

-         (strings (unparse-unix-piece pathname-type)))
-       (when version-needed
-         (typecase pathname-version
-           ((member :wild)
-            (strings ".*"))
-           (integer
-            (strings (format nil ".~D" pathname-version)))
-           (t
-            (lose)))))
+         (strings (unparse-unix-piece pathname-type))))

       (apply #'concatenate 'simple-string (strings)))))
       (apply #'concatenate 'simple-string (strings)))))

-
-(/show0 "filesys.lisp 471")
-
-(def!struct (unix-host
-            (:make-load-form-fun make-unix-host-load-form)
-            (:include host
-                      (parse #'parse-unix-namestring)
-                      (unparse #'unparse-unix-namestring)
-                      (unparse-host #'unparse-unix-host)
-                      (unparse-directory #'unparse-unix-directory)
-                      (unparse-file #'unparse-unix-file)
-                      (unparse-enough #'unparse-unix-enough)
-                      (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
-
-(defvar *unix-host* (make-unix-host))
-
-(/show0 "filesys.lisp 488")
-
-(defun make-unix-host-load-form (host)
-  (declare (ignore host))
-  '*unix-host*)

 \f
 ;;;; wildcard matching stuff
 
 \f
 ;;;; wildcard matching stuff
 

-(/show0 "filesys.lisp 498")
+;;; Return a list of all the Lispy filenames (not including e.g. the
+;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME.
+(defun directory-lispy-filenames (directory-name)
+  (with-alien ((adlf (* c-string)
+                    (alien-funcall (extern-alien
+                                    "alloc_directory_lispy_filenames"
+                                    (function (* c-string) c-string))
+                                   directory-name)))
+    (if (null-alien adlf)
+       (error 'simple-file-error
+              :pathname directory-name
+              :format-control "~@<couldn't read directory ~S: ~2I~_~A~:>"
+              :format-arguments (list directory-name (strerror)))
+       (unwind-protect
+           (c-strings->string-list adlf)
+         (alien-funcall (extern-alien "free_directory_lispy_filenames"
+                                      (function void (* c-string)))
+                        adlf)))))

 
 

-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
+(/show0 "filesys.lisp 498")

 
 

-(defmacro enumerate-matches ((var pathname &optional result
-                                 &key (verify-existence t)
-                                  (follow-links t))
-                            &body body)
-  (let ((body-name (gensym)))
-    `(block nil
-       (flet ((,body-name (,var)
-               ,@body))
-        (%enumerate-matches (pathname ,pathname)
-                            ,verify-existence
-                             ,follow-links
-                            #',body-name)
-        ,result))))
+(defmacro !enumerate-matches ((var pathname &optional result
+                                  &key (verify-existence t)
+                                  (follow-links t))
+                             &body body)
+  `(block nil
+     (%enumerate-matches (pathname ,pathname)
+                        ,verify-existence
+                        ,follow-links
+                        (lambda (,var) ,@body))
+     ,result))

 
 (/show0 "filesys.lisp 500")
 
 
 (/show0 "filesys.lisp 500")
 

+;;; Call FUNCTION on matches.

 (defun %enumerate-matches (pathname verify-existence follow-links function)
 (defun %enumerate-matches (pathname verify-existence follow-links function)

-  (/show0 "entering %ENUMERATE-MATCHES")
+  (/noshow0 "entering %ENUMERATE-MATCHES")

   (when (pathname-type pathname)
     (unless (pathname-name pathname)
       (error "cannot supply a type without a name:~%  ~S" pathname)))
   (when (pathname-type pathname)
     (unless (pathname-name pathname)
       (error "cannot supply a type without a name:~%  ~S" pathname)))

@@ -521,21 +464,22 @@
             (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))
   (let ((directory (pathname-directory pathname)))
             (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))
   (let ((directory (pathname-directory pathname)))

-    (/show0 "computed DIRECTORY")
+    (/noshow0 "computed DIRECTORY")

     (if directory
     (if directory

-       (ecase (car directory)
+       (ecase (first directory)

          (:absolute
          (:absolute

-          (/show0 "absolute directory")
-          (%enumerate-directories "/" (cdr directory) pathname
+          (/noshow0 "absolute directory")
+          (%enumerate-directories "/" (rest directory) pathname

                                   verify-existence follow-links
                                   nil function))
          (:relative
                                   verify-existence follow-links
                                   nil function))
          (:relative

-          (/show0 "relative directory")
-          (%enumerate-directories "" (cdr directory) pathname
+          (/noshow0 "relative directory")
+          (%enumerate-directories "" (rest directory) pathname

                                   verify-existence follow-links
                                   nil function)))
        (%enumerate-files "" pathname verify-existence function))))
 
                                   verify-existence follow-links
                                   nil function)))
        (%enumerate-files "" pathname verify-existence function))))
 

+;;; Call FUNCTION on directories.

 (defun %enumerate-directories (head tail pathname verify-existence
                               follow-links nodes function)
   (declare (simple-string head))
 (defun %enumerate-directories (head tail pathname verify-existence
                               follow-links nodes function)
   (declare (simple-string head))

@@ -550,35 +494,36 @@
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))
                      ,@body))))
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))
                      ,@body))))

-            (do-directory-entries ((name directory) &body body)
-              `(let ((dir (sb!unix:open-dir ,directory)))
-            (when dir
-              (unwind-protect
-                  (loop
-                         (let ((,name (sb!unix:read-dir dir)))
-                           (cond ((null ,name)
-                             (return))
-                                 ((string= ,name "."))
-                                 ((string= ,name ".."))
-                                 (t
-                                  ,@body))))
-                     (sb!unix:close-dir dir))))))
+            (with-directory-node-removed ((head) &body body)
+              `(multiple-value-bind (res dev ino mode)
+                   (unix-xstat ,head)
+                 (when (and res (eql (logand mode sb!unix:s-ifmt)
+                                     sb!unix:s-ifdir))
+                   (let ((nodes (remove (cons dev ino) nodes :test #'equal)))
+                     ,@body)))))

     (if tail
        (let ((piece (car tail)))
          (etypecase piece
            (simple-string
     (if tail
        (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))))
            ((member :wild-inferiors)
                                         (cdr tail) pathname
                                         verify-existence follow-links
                                         nodes function))))
            ((member :wild-inferiors)

+            ;; now with extra error case handling from CLHS
+            ;; 19.2.2.4.3 -- CSR, 2004-01-24
+            (when (member (cadr tail) '(:up :back))
+              (error 'simple-file-error
+                     :pathname pathname
+                     :format-control "~@<invalid use of ~S after :WILD-INFERIORS~@:>."
+                     :format-arguments (list (cadr tail))))

             (%enumerate-directories head (rest tail) pathname
                                     verify-existence follow-links
                                     nodes function)
             (%enumerate-directories head (rest tail) pathname
                                     verify-existence follow-links
                                     nodes function)

-            (do-directory-entries (name head)
-              (let ((subdir (concatenate 'string head name)))
+            (dolist (name (ignore-errors (directory-lispy-filenames head)))
+              (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))

@@ -589,14 +534,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))
                         (%enumerate-directories subdir tail pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
            ((or pattern (member :wild))

-            (do-directory-entries (name head)
+            (dolist (name (directory-lispy-filenames head))

               (when (or (eq piece :wild) (pattern-matches piece name))
               (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))

@@ -604,80 +549,89 @@
                                (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)
                         (%enumerate-directories subdir (rest tail) pathname
                                                 verify-existence follow-links
                                                 nodes function))))))))
          ((member :up)

-            (let ((head (concatenate 'string head "..")))
+          (when (string= head "/")
+            (error 'simple-file-error
+                   :pathname pathname
+                   :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
+          (with-directory-node-removed (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
                                         (rest tail) pathname
                                         verify-existence follow-links

-                                        nodes function))))))
+                                        nodes function)))))
+         ((member :back)
+          ;; :WILD-INFERIORS is handled above, so the only case here
+          ;; should be (:ABSOLUTE :BACK)
+          (aver (string= head "/"))
+          (error 'simple-file-error
+                 :pathname pathname
+                 :format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))

        (%enumerate-files head pathname verify-existence function))))
 
        (%enumerate-files head pathname verify-existence function))))
 

+;;; Call FUNCTION on files.

 (defun %enumerate-files (directory pathname verify-existence function)
   (declare (simple-string directory))
 (defun %enumerate-files (directory pathname verify-existence function)
   (declare (simple-string directory))

-  (/show0 "entering %ENUMERATE-FILES")
+  (/noshow0 "entering %ENUMERATE-FILES")

   (let ((name (%pathname-name pathname))
        (type (%pathname-type pathname))
        (version (%pathname-version pathname)))
   (let ((name (%pathname-name pathname))
        (type (%pathname-type pathname))
        (version (%pathname-version pathname)))

-    (/show0 "computed NAME, TYPE, and VERSION")
+    (/noshow0 "computed NAME, TYPE, and VERSION")

     (cond ((member name '(nil :unspecific))
     (cond ((member name '(nil :unspecific))

-          (/show0 "UNSPECIFIC, more or less")
-          (when (or (not verify-existence)
-                    (sb!unix:unix-file-kind directory))
-            (funcall function directory)))
+          (/noshow0 "UNSPECIFIC, more or less")
+           (let ((directory (coerce directory 'base-string)))
+             (when (or (not verify-existence)
+                       (sb!unix:unix-file-kind directory))
+               (funcall function directory))))

          ((or (pattern-p name)
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))
          ((or (pattern-p name)
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))

-          (/show0 "WILD, more or less")
-          (let ((dir (sb!unix:open-dir directory)))
-            (when dir
-              (unwind-protect
-                  (loop
-                    (/show0 "at head of LOOP")
-                    (let ((file (sb!unix:read-dir dir)))
-                      (if file
-                          (unless (or (string= file ".")
-                                      (string= file ".."))
-                            (multiple-value-bind
-                                (file-name file-type file-version)
-                                (let ((*ignore-wildcards* t))
-                                  (extract-name-type-and-version
-                                   file 0 (length file)))
-                              (when (and (components-match file-name name)
-                                         (components-match file-type type)
-                                         (components-match file-version
-                                                           version))
-                                (funcall function
-                                         (concatenate 'string
-                                                      directory
-                                                      file)))))
-                          (return))))
-                (sb!unix:close-dir dir)))))
+          (/noshow0 "WILD, more or less")
+          ;; I IGNORE-ERRORS here just because the original CMU CL
+          ;; code did. I think the intent is that it's not an error
+          ;; to request matches to a wild pattern when no matches
+          ;; exist, but I haven't tried to figure out whether
+          ;; everything is kosher. (E.g. what if we try to match a
+          ;; wildcard but we don't have permission to read one of the
+          ;; relevant directories?) -- WHN 2001-04-17
+          (dolist (complete-filename (ignore-errors
+                                       (directory-lispy-filenames directory)))
+            (multiple-value-bind
+                (file-name file-type file-version)
+                (let ((*ignore-wildcards* t))
+                  (extract-name-type-and-version
+                   complete-filename 0 (length complete-filename)))
+              (when (and (components-match file-name name)
+                         (components-match file-type type)
+                         (components-match file-version version))
+                (funcall function
+                         (concatenate 'base-string
+                                      directory
+                                      complete-filename))))))

          (t
          (t

-          (/show0 "default case")
-          (let ((file (concatenate 'string directory name)))
-            (/show0 "computed basic FILE=..")
-            #!+sb-show (%primitive print file)
+          (/noshow0 "default case")
+          (let ((file (concatenate 'base-string directory name)))
+            (/noshow "computed basic FILE")

             (unless (or (null type) (eq type :unspecific))
             (unless (or (null type) (eq type :unspecific))

-              (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
-              (setf file (concatenate 'string file "." type)))
-            (unless (member version '(nil :newest :wild))
-              (/show0 "tweaking FILE for more-or-less-:WILD case")
-              (setf file (concatenate 'string file "."
+              (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
+              (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 'base-string file "."

                                       (quick-integer-to-string version))))
                                       (quick-integer-to-string version))))

-            (/show0 "finished possibly tweaking FILE=..")
-            #!+sb-show (%primitive print file)
+            (/noshow0 "finished possibly tweaking FILE")

             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))
             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))

-              (/show0 "calling FUNCTION on FILE")
+              (/noshow0 "calling FUNCTION on FILE")

               (funcall function file)))))))
 
               (funcall function file)))))))
 

-(/show0 "filesys.lisp 603")
+(/noshow0 "filesys.lisp 603")

 
 ;;; FIXME: Why do we need this?
 (defun quick-integer-to-string (n)
 
 ;;; FIXME: Why do we need this?
 (defun quick-integer-to-string (n)

@@ -687,11 +641,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))

@@ -706,72 +660,76 @@
 \f
 ;;;; UNIX-NAMESTRING
 
 \f
 ;;;; UNIX-NAMESTRING
 

-(defun unix-namestring (pathname &optional (for-input t) executable-only)
-  #!+sb-doc
-  "Convert PATHNAME into a string that can be used with UNIX system calls.
-   Search-lists and wild-cards are expanded."
-  ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
-  ;; pathnames too.
-  ;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
-  (let ((path (let ((lpn (pathname pathname)))
-               (if (typep lpn 'logical-pathname)
-                   (namestring (translate-logical-pathname lpn))
-                   pathname))))
-    (enumerate-search-list
-      (pathname path)
-      (collect ((names))
-       (enumerate-matches (name pathname nil :verify-existence for-input)
-                          (when (or (not executable-only)
-                                    (and (eq (sb!unix:unix-file-kind name)
-                                             :file)
-                                         (sb!unix:unix-access name
-                                                              sb!unix:x_ok)))
-                            (names name)))
-       (let ((names (names)))
-         (when names
-           (when (cdr names)
-             (error 'simple-file-error
-                    :format-control "~S is ambiguous:~{~%  ~A~}"
-                    :format-arguments (list pathname names)))
-           (return (car names))))))))
+(defun empty-relative-pathname-spec-p (x)
+  (or (equal x "")
+      (and (pathnamep x)
+          (or (equal (pathname-directory x) '(:relative))
+              ;; KLUDGE: I'm not sure this second check should really
+              ;; have to be here. But on sbcl-0.6.12.7,
+              ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and
+              ;; (PATHNAME "") seems to act like an empty relative
+              ;; pathname, so in order to work with that, I test
+              ;; for NIL here. -- WHN 2001-05-18
+              (null (pathname-directory x)))
+          (null (pathname-name x))
+          (null (pathname-type x)))
+      ;; (The ANSI definition of "pathname specifier" has 
+      ;; other cases, but none of them seem to admit the possibility
+      ;; of being empty and relative.)
+      ))
+
+;;; Convert PATHNAME into a string that can be used with UNIX system
+;;; calls, or return NIL if no match is found. Wild-cards are expanded.
+(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 (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))

 \f
 ;;;; TRUENAME and PROBE-FILE
 
 \f
 ;;;; TRUENAME and PROBE-FILE
 

-;;; Another silly file function trivially different from another function.
+;;; This is only trivially different from PROBE-FILE, which is silly
+;;; but ANSI.

 (defun truename (pathname)
   #!+sb-doc
 (defun truename (pathname)
   #!+sb-doc

-  "Return the pathname for the actual file described by the pathname
-  An error of type file-error is signalled if no such file exists,
-  or the pathname is wild."
-  (if (wild-pathname-p pathname)
+  "Return the pathname for the actual file described by PATHNAME.
+  An error of type FILE-ERROR is signalled if no such file exists,
+  or the pathname is wild.
+
+  Under Unix, the TRUENAME of a broken symlink is considered to be
+  the name of the broken symlink itself."
+  (let ((result (probe-file pathname)))
+    (unless result

       (error 'simple-file-error
       (error 'simple-file-error

-            :format-control "bad place for a wild pathname"
-            :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
 (defun probe-file (pathname)
   #!+sb-doc

-  "Return a pathname which is the truename of the file if it exists, NIL
+  "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."
   otherwise. An error of type FILE-ERROR is signaled if pathname is wild."

-  (if (wild-pathname-p pathname)
-      (error 'simple-file-error
-            :pathname pathname
-            :format-control "bad place for a wild pathname")
-      (let ((namestring (unix-namestring pathname t)))
-       (when (and namestring (sb!unix:unix-file-kind namestring))
-         (let ((truename (sb!unix:unix-resolve-links
-                          (sb!unix:unix-maybe-prepend-current-directory
-                           namestring))))
-           (when truename
-             (let ((*ignore-wildcards* t))
-               (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+  (let* ((defaulted-pathname (merge-pathnames
+                             pathname
+                             (sane-default-pathname-defaults)))
+        (namestring (unix-namestring defaulted-pathname t)))
+    (when (and namestring (sb!unix:unix-file-kind namestring t))
+      (let ((trueishname (sb!unix:unix-resolve-links namestring)))
+       (when 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
 

@@ -779,7 +737,7 @@
 
 (defun rename-file (file new-name)
   #!+sb-doc
 
 (defun rename-file (file new-name)
   #!+sb-doc

-  "Rename File to have the specified New-Name. If file is a stream open to a
+  "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a

   file, then the associated file is renamed."
   (let* ((original (truename file))
         (original-namestring (unix-namestring original t))
   file, then the associated file is renamed."
   (let* ((original (truename file))
         (original-namestring (unix-namestring original t))

@@ -795,16 +753,16 @@
       (unless res
        (error 'simple-file-error
               :pathname new-name
       (unless res
        (error 'simple-file-error
               :pathname new-name

-              :format-control "failed to rename ~A to ~A: ~A"
-              :format-arguments (list original new-name
-                                      (sb!unix:get-unix-error-msg error))))
+              :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
+                                ~I~_~A~:>"
+              :format-arguments (list original new-name (strerror error))))

       (when (streamp file)
       (when (streamp file)

-       (file-name file new-namestring))
+       (file-name file new-name))

       (values new-name original (truename new-name)))))
 
 (defun delete-file (file)
   #!+sb-doc
       (values new-name original (truename new-name)))))
 
 (defun delete-file (file)
   #!+sb-doc

-  "Delete the specified file."
+  "Delete the specified FILE."

   (let ((namestring (unix-namestring file t)))
     (when (streamp file)
       (close file :abort t))
   (let ((namestring (unix-namestring file t)))
     (when (streamp file)
       (close file :abort t))

@@ -813,179 +771,247 @@
             :pathname file
             :format-control "~S doesn't exist."
             :format-arguments (list file)))
             :pathname file
             :format-control "~S doesn't exist."
             :format-arguments (list file)))

-

     (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
       (unless res
     (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
       (unless res

-       (error 'simple-file-error
-              :pathname namestring
-              :format-control "could not delete ~A: ~A"
-              :format-arguments (list namestring
-                                      (sb!unix:get-unix-error-msg err))))))
+       (simple-file-perror "couldn't delete ~A" namestring err))))

   t)
 \f
   t)
 \f

-;;; Return Home:, which is set up for us at initialization time.
+;;; (This is an ANSI Common Lisp function.) 

 (defun user-homedir-pathname (&optional host)
 (defun user-homedir-pathname (&optional host)

-  #!+sb-doc
-  "Returns the home directory of the logged in user as a pathname.
-  This is obtained from the logical name \"home:\"."
+  "Return the home directory of the user as a pathname."

   (declare (ignore host))
   (declare (ignore host))

-  ;; Note: CMU CL did #P"home:" here instead of using a call to
-  ;; PATHNAME. Delaying construction of the pathname until we're
-  ;; running in a target Lisp lets us avoid figuring out how to dump
-  ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
-  ;; object file. It also might have a small positive effect on
-  ;; efficiency, in that we don't allocate a PATHNAME we don't need,
-  ;; but it it could also have a larger negative effect. Hopefully
-  ;; it'll be OK. -- WHN 19990714
-  (pathname "home:"))
+  (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))

 
 (defun file-write-date (file)
   #!+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"
 
 (defun file-write-date (file)
   #!+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
 
 (defun file-author (file)
   #!+sb-doc

-  "Returns the file author as a string, or nil if the author cannot be
- determined. Signals an error of type file-error if file doesn't exist,
- or file is a wild pathname."
-  (if (wild-pathname-p file)
+  "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."
+  (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))
-         (if winp (lookup-login-name 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
 
 (/show0 "filesys.lisp 800")
 
 \f
 ;;;; DIRECTORY
 
 (/show0 "filesys.lisp 800")
 

-(defun directory (pathname &key (all t) (check-for-subdirs t)
-                          (follow-links t))
-  #!+sb-doc
-  "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. If :FOLLOW-LINKS is NIL,
-   then symbolic links in the result are not expanded. This is not the
-   default because TRUENAME does follow links, and the result pathnames are
-   defined to be the TRUENAME of the pathname (the truename of a link may well
-   be in another directory.)"
-  (let ((results nil))
-    (enumerate-search-list
-       (pathname (merge-pathnames pathname
-                                  (make-pathname :name :wild
-                                                 :type :wild
-                                                 :version :wild)))
-      (enumerate-matches (name pathname)
-       (when (or all
-                 (let ((slash (position #\/ name :from-end t)))
-                   (or (null slash)
-                       (= (1+ slash) (length name))
-                       (char/= (schar name (1+ slash)) #\.))))
-         (push name results))))
-    (let ((*ignore-wildcards* t))
-      (mapcar (lambda (name)
-               (let ((name (if (and check-for-subdirs
-                                    (eq (sb!unix:unix-file-kind name)
-                                        :directory))
-                               (concatenate 'string name "/")
-                               name)))
-                 (if follow-links (truename name) (pathname name))))
-             (sort (delete-duplicates results :test #'string=) #'string<)))))
-\f
-;;;; translating Unix uid's
-;;;;
-;;;; FIXME: should probably move into unix.lisp
-
-(defvar *uid-hash-table* (make-hash-table)
-  #!+sb-doc
-  "hash table for keeping track of uid's and login names")
-
-(/show0 "filesys.lisp 844")
+;;; NOTE: There is a fair amount of hair below that is probably not
+;;; strictly necessary.
+;;;
+;;; The issue is the following: what does (DIRECTORY "SYS:*;") mean?
+;;; Until 2004-01, SBCL's behaviour was unquestionably wrong, as it
+;;; did not translate the logical pathname at all, but instead treated
+;;; it as a physical one.  Other Lisps seem to to treat this call as
+;;; equivalent to (DIRECTORY (TRANSLATE-LOGICAL-PATHNAME "SYS:*;")),
+;;; which is fine as far as it goes, but not very interesting, and
+;;; arguably counterintuitive.  (PATHNAME-MATCH-P "SYS:SRC;" "SYS:*;")
+;;; is true, so why should "SYS:SRC;" not show up in the call to
+;;; DIRECTORY?  (assuming the physical pathname corresponding to it
+;;; exists, of course).
+;;;
+;;; So, the interpretation that I am pushing is for all pathnames
+;;; matching the input pathname to be queried.  This means that we
+;;; need to compute the intersection of the input pathname and the
+;;; logical host FROM translations, and then translate the resulting
+;;; pathname using the host to the TO translation; this treatment is
+;;; recursively invoked until we get a physical pathname, whereupon
+;;; our physical DIRECTORY implementation takes over.

 
 

-;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
-;;; lookups are cached in a hash table since groveling the passwd(s)
-;;; files is somewhat expensive. The table may hold NIL for id's that
-;;; cannot be looked up since this keeps the files from having to be
-;;; searched in their entirety each time this id is translated.
-(defun lookup-login-name (uid)
-  (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
-    (if foundp
-       login-name
-       (setf (gethash uid *uid-hash-table*)
-             (get-group-or-user-name :user uid)))))
+;;; FIXME: this is an incomplete implementation.  It only works when
+;;; both are logical pathnames (which is OK, because that's the only
+;;; case when we call it), but there are other pitfalls as well: see
+;;; the DIRECTORY-HELPER below for some, but others include a lack of
+;;; pattern handling.
+(defun pathname-intersections (one two)
+  (aver (logical-pathname-p one))
+  (aver (logical-pathname-p two))
+  (labels
+      ((intersect-version (one two)
+        (aver (typep one '(or null (member :newest :wild :unspecific)
+                           integer)))
+        (aver (typep two '(or null (member :newest :wild :unspecific)
+                           integer)))
+        (cond
+          ((eq one :wild) two)
+          ((eq two :wild) one)
+          ((or (null one) (eq one :unspecific)) two)
+          ((or (null two) (eq two :unspecific)) one)
+          ((eql one two) one)
+          (t nil)))
+       (intersect-name/type (one two)
+        (aver (typep one '(or null (member :wild :unspecific) string)))
+        (aver (typep two '(or null (member :wild :unspecific) string)))
+        (cond
+          ((eq one :wild) two)
+          ((eq two :wild) one)
+          ((or (null one) (eq one :unspecific)) two)
+          ((or (null two) (eq two :unspecific)) one)
+          ((string= one two) one)
+          (t nil)))
+       (intersect-directory (one two)
+        (aver (typep one '(or null (member :wild :unspecific) list)))
+        (aver (typep two '(or null (member :wild :unspecific) list)))
+        (cond
+          ((eq one :wild) two)
+          ((eq two :wild) one)
+          ((or (null one) (eq one :unspecific)) two)
+          ((or (null two) (eq two :unspecific)) one)
+          (t (aver (eq (car one) (car two)))
+             (mapcar
+              (lambda (x) (cons (car one) x))
+              (intersect-directory-helper (cdr one) (cdr two)))))))
+    (let ((version (intersect-version
+                   (pathname-version one) (pathname-version two)))
+         (name (intersect-name/type
+                (pathname-name one) (pathname-name two)))
+         (type (intersect-name/type
+                (pathname-type one) (pathname-type two)))
+         (host (pathname-host one)))
+      (mapcar (lambda (d)
+               (make-pathname :host host :name name :type type
+                              :version version :directory d))
+             (intersect-directory
+              (pathname-directory one) (pathname-directory two))))))

 
 

-;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group")
-;;; since it is a much smaller file, contains all the local id's, and
-;;; most uses probably involve id's on machines one would login into.
-;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
-;;; is really long and has to be fetched over the net.
+;;; FIXME: written as its own function because I (CSR) don't
+;;; understand it, so helping both debuggability and modularity.  In
+;;; case anyone is motivated to rewrite it, it returns a list of
+;;; sublists representing the intersection of the two input directory
+;;; paths (excluding the initial :ABSOLUTE or :RELATIVE).

 ;;;
 ;;;

-;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
-;;; the GROUP-OR-USER argument.
-(defun get-group-or-user-name (group-or-user id)
-  #!+sb-doc
-  "Returns the simple-string user or group name of the user whose uid or gid
-   is id, or NIL if no such user or group exists. Group-or-user is either
-   :group or :user."
-  (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
-    (declare (simple-string id-string))
-    (multiple-value-bind (file1 file2)
-       (ecase group-or-user
-         (:group (values "/etc/group" "/etc/groups"))
-         (:user (values "/etc/passwd" "/etc/passwd")))
-      (or (get-group-or-user-name-aux id-string file1)
-         (get-group-or-user-name-aux id-string file2)))))
+;;; FIXME: Does not work with :UP or :BACK
+;;; FIXME: Does not work with patterns
+;;;
+;;; FIXME: PFD suggests replacing this implementation with a DFA
+;;; conversion of a NDFA.  Find out (a) what this means and (b) if it
+;;; turns out to be worth it.
+(defun intersect-directory-helper (one two)
+  (flet ((simple-intersection (cone ctwo)
+          (cond
+            ((eq cone :wild) ctwo)
+            ((eq ctwo :wild) cone)
+            (t (aver (typep cone 'string))
+               (aver (typep ctwo 'string))
+               (if (string= cone ctwo) cone nil)))))
+    (macrolet
+       ((loop-possible-wild-inferiors-matches
+            (lower-bound bounding-sequence order)
+          (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym)))
+            `(let ((,l (length ,bounding-sequence)))
+              (loop for ,index from ,lower-bound to ,l
+               append (mapcar (lambda (,g2)
+                                (append
+                                 (butlast ,bounding-sequence (- ,l ,index))
+                                 ,g2))
+                       (mapcar
+                        (lambda (,g3)
+                          (append
+                           (if (eq (car (nthcdr ,index ,bounding-sequence))
+                                   :wild-inferiors)
+                               '(:wild-inferiors)
+                               nil) ,g3))
+                        (intersect-directory-helper
+                         ,@(if order
+                               `((nthcdr ,index one) (cdr two))
+                               `((cdr one) (nthcdr ,index two)))))))))))
+      (cond
+       ((and (eq (car one) :wild-inferiors)
+             (eq (car two) :wild-inferiors))
+        (delete-duplicates
+         (append (mapcar (lambda (x) (cons :wild-inferiors x))
+                         (intersect-directory-helper (cdr one) (cdr two)))
+                 (loop-possible-wild-inferiors-matches 2 one t)
+                 (loop-possible-wild-inferiors-matches 2 two nil))
+         :test 'equal))
+       ((eq (car one) :wild-inferiors)
+        (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil)
+                           :test 'equal))
+       ((eq (car two) :wild-inferiors)
+        (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t)
+                           :test 'equal))
+       ((and (null one) (null two)) (list nil))
+       ((null one) nil)
+       ((null two) nil)
+       (t (and (simple-intersection (car one) (car two))
+               (mapcar (lambda (x) (cons (simple-intersection
+                                          (car one) (car two)) x))
+                       (intersect-directory-helper (cdr one) (cdr two)))))))))

 
 

-;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
-;;; getpwent? getpwuid?
-(defun get-group-or-user-name-aux (id-string passwd-file)
-  (with-open-file (stream passwd-file)
-    (loop
-      (let ((entry (read-line stream nil)))
-       (unless entry (return nil))
-       (let ((name-end (position #\: (the simple-string entry)
-                                 :test #'char=)))
-         (when name-end
-           (let ((id-start (position #\: (the simple-string entry)
-                                     :start (1+ name-end) :test #'char=)))
-             (when id-start
-               (incf id-start)
-               (let ((id-end (position #\: (the simple-string entry)
-                                       :start id-start :test #'char=)))
-                 (when (and id-end
-                            (string= id-string entry
-                                     :start2 id-start :end2 id-end))
-                   (return (subseq entry 0 name-end))))))))))))
+(defun directory (pathname &key)
+  #!+sb-doc
+  "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
+   given pathname. Note that the interaction between this ANSI-specified
+   TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
+   means this function can sometimes return files which don't have the same
+   directory as PATHNAME."
+  (let (;; We create one entry in this hash table for each truename,
+       ;; as an asymptotically efficient way of removing duplicates
+       ;; (which can arise when e.g. multiple symlinks map to the
+       ;; same truename).
+       (truenames (make-hash-table :test #'equal))
+       ;; FIXME: Possibly this MERGE-PATHNAMES call should only
+       ;; happen once we get a physical pathname.
+        (merged-pathname (merge-pathnames pathname)))
+    (labels ((do-physical-directory (pathname)
+              (aver (not (logical-pathname-p pathname)))
+              (!enumerate-matches (match pathname)
+                (let* ((*ignore-wildcards* t)
+                       ;; FIXME: Why not TRUENAME?  As reported by
+                       ;; Milan Zamazal sbcl-devel 2003-10-05, using
+                       ;; TRUENAME causes a race condition whereby
+                       ;; removal of a file during the directory
+                       ;; operation causes an error.  It's not clear
+                       ;; what the right thing to do is, though.  --
+                       ;; CSR, 2003-10-13
+                       (truename (probe-file match)))
+                  (when truename
+                    (setf (gethash (namestring truename) truenames)
+                          truename)))))
+            (do-directory (pathname)
+              (if (logical-pathname-p pathname)
+                  (let ((host (intern-logical-host (pathname-host pathname))))
+                    (dolist (x (logical-host-canon-transls host))
+                      (destructuring-bind (from to) x
+                        (let ((intersections
+                               (pathname-intersections pathname from)))
+                          (dolist (p intersections)
+                            (do-directory (translate-pathname p from to)))))))
+                  (do-physical-directory pathname))))
+      (do-directory merged-pathname))
+    (mapcar #'cdr
+           ;; Sorting isn't required by the ANSI spec, but sorting
+           ;; into some canonical order seems good just on the
+           ;; grounds that the implementation should have repeatable
+           ;; behavior when possible.
+            (sort (loop for name being each hash-key in truenames
+                       using (hash-value truename)
+                        collect (cons name truename))
+                  #'string<
+                 :key #'car))))

 \f
 (/show0 "filesys.lisp 899")
 
 \f
 (/show0 "filesys.lisp 899")
 

-;;; Predicate to order pathnames by. Goes by name.
+;;; predicate to order pathnames by; goes by name

 (defun pathname-order (x y)
   (let ((xn (%pathname-name x))
        (yn (%pathname-name y)))
 (defun pathname-order (x y)
   (let ((xn (%pathname-name x))
        (yn (%pathname-name y)))

@@ -997,70 +1023,37 @@
                (t t)))
        xn)))
 \f
                (t t)))
        xn)))
 \f

-(defun default-directory ()
-  #!+sb-doc
-  "Returns the pathname for the default directory. This is the place where
-  a file will be written if no directory is specified. This may be changed
-  with setf."
-  (multiple-value-bind (gr dir-or-error) (sb!unix:unix-current-directory)
-    (if gr
-       (let ((*ignore-wildcards* t))
-         (pathname (concatenate 'simple-string dir-or-error "/")))
-       (error dir-or-error))))
-
-(defun %set-default-directory (new-val)
-  (let ((namestring (unix-namestring new-val t)))
-    (unless namestring
-      (error "~S doesn't exist." new-val))
-    (multiple-value-bind (gr error) (sb!unix:unix-chdir namestring)
-      (if gr
-         (setf (search-list "default:") (default-directory))
-         (error (sb!unix:get-unix-error-msg error))))
-    new-val))
-
-(/show0 "filesys.lisp 934")
-
-(/show0 "entering what used to be !FILESYS-COLD-INIT")
-(defvar *default-pathname-defaults*
-  (%make-pathname *unix-host* nil nil nil nil :newest))
-(setf (search-list "default:") (default-directory))
-(/show0 "leaving what used to be !FILESYS-COLD-INIT")
-\f

 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
   #!+sb-doc
 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
   #!+sb-doc

-  "Tests whether the directories containing the specified file
-  actually exist, and attempts to create them if they do not.
-  Portable programs should avoid using the :MODE keyword argument."
-  (let* ((pathname (pathname pathspec))
-        (pathname (if (typep pathname 'logical-pathname)
-                      (translate-logical-pathname pathname)
-                      pathname))
-        (created-p nil))
+  "Test whether the directories containing the specified file
+  actually exist, and attempt to create them if they do not.
+  The MODE argument is a CMUCL/SBCL-specific extension to control
+  the Unix permission bits."
+  (let ((pathname (physicalize-pathname (pathname pathspec)))
+       (created-p nil))

     (when (wild-pathname-p pathname)
       (error 'simple-file-error
             :format-control "bad place for a wild pathname"
             :pathname pathspec))
     (when (wild-pathname-p pathname)
       (error 'simple-file-error
             :format-control "bad place for a wild pathname"
             :pathname pathspec))

-    (enumerate-search-list (pathname pathname)
-       (let ((dir (pathname-directory pathname)))
-        (loop for i from 1 upto (length dir)
-              do (let ((newpath (make-pathname
-                                 :host (pathname-host pathname)
-                                 :device (pathname-device pathname)
-                                 :directory (subseq dir 0 i))))
-                   (unless (probe-file newpath)
-                     (let ((namestring (namestring newpath)))
-                       (when verbose
-                         (format *standard-output*
-                                 "~&creating directory: ~A~%"
-                                 namestring))
-                       (sb!unix:unix-mkdir namestring mode)
-                       (unless (probe-file namestring)
-                         (error 'simple-file-error
-                                :pathname pathspec
-                                :format-control "can't create directory ~A"
-                                :format-arguments (list namestring)))
-                       (setf created-p t)))))
-        ;; Only the first path in a search-list is considered.
-        (return (values pathname created-p))))))
+    (let ((dir (pathname-directory pathname)))
+      (loop for i from 1 upto (length dir)
+           do (let ((newpath (make-pathname
+                              :host (pathname-host pathname)
+                              :device (pathname-device pathname)
+                              :directory (subseq dir 0 i))))
+                (unless (probe-file newpath)
+                  (let ((namestring (coerce (namestring newpath) 'base-string)))
+                    (when verbose
+                      (format *standard-output*
+                              "~&creating directory: ~A~%"
+                              namestring))
+                    (sb!unix:unix-mkdir namestring mode)
+                    (unless (probe-file namestring)
+                      (error 'simple-file-error
+                             :pathname pathspec
+                             :format-control "can't create directory ~A"
+                             :format-arguments (list namestring)))
+                    (setf created-p t)))))
+      (values pathname created-p))))

 
 (/show0 "filesys.lisp 1000")
 
 (/show0 "filesys.lisp 1000")