0.pre7.122:

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

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 3c5debb..ca9a19f 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

@@ -218,7 +215,17 @@
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 
          (setf start (1+ slash))))
       (values absolute (pieces)))))
 

-(defun maybe-extract-search-list (namestr start end)
+;;; the thing before a colon in a logical path
+(def!struct (logical-hostname (:make-load-form-fun
+                              (lambda (x)
+                                (values `(make-logical-hostname
+                                          ,(logical-hostname-name x))
+                                        nil)))
+                             (:copier nil)
+                             (:constructor make-logical-hostname (name)))
+  (name (missing-arg) :type simple-string))
+
+(defun maybe-extract-logical-hostname (namestr start end)

   (declare (type simple-base-string namestr)
           (type index start end))
   (let ((quoted nil))
   (declare (type simple-base-string namestr)
           (type index start end))
   (let ((quoted nil))

@@ -231,69 +238,77 @@
            (#\\
             (setf quoted t))
            (#\:
            (#\\
             (setf quoted t))
            (#\:

-            (return (values (remove-backslashes namestr start index)
+            (return (values (make-logical-hostname
+                             (remove-backslashes namestr start index))

                             (1+ index)))))))))
 
 (defun parse-unix-namestring (namestr start end)
   (declare (type simple-base-string namestr)
                             (1+ index)))))))))
 
 (defun parse-unix-namestring (namestr start end)
   (declare (type simple-base-string namestr)

-          (type index start end))
+           (type index start end))

   (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)))))
+    (let ((logical-hostname
+          (if absolute
+              nil
+              (let ((first (car pieces)))
+                (multiple-value-bind (logical-hostname new-start)
+                    (maybe-extract-logical-hostname namestr
+                                                    (car first)
+                                                    (cdr first))
+                  (when logical-hostname
+                    (setf absolute t)
+                    (setf (car first) new-start))
+                  logical-hostname)))))
+      (declare (type (or null logical-hostname) logical-hostname))

       (multiple-value-bind (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)))
-       ;; 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)))))
+          (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))
+                  (when logical-hostname
+                    (dirs logical-hostname))
+                  (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")
 
 
 (/show0 "filesys.lisp 300")
 

@@ -353,8 +368,14 @@
     (when directory
       (ecase (pop directory)
        (:absolute
     (when directory
       (ecase (pop directory)
        (:absolute

-        (cond ((search-list-p (car directory))
-               (pieces (search-list-name (pop directory)))
+        (cond ((logical-hostname-p (car directory))
+               ;; FIXME: The old CMU CL "search list" extension is
+               ;; gone, but the old machinery is still being used
+               ;; clumsily here and elsewhere, to represent anything
+               ;; which belongs before a colon prefix in the ANSI
+               ;; pathname machinery. This should be cleaned up,
+               ;; using simpler machinery with more mnemonic names.
+               (pieces (logical-hostname-name (pop directory)))

                (pieces ":"))
               (t
                (pieces "/"))))
                (pieces ":"))
               (t
                (pieces "/"))))

@@ -461,29 +482,6 @@
            (t
             (lose)))))
       (apply #'concatenate 'simple-string (strings)))))
            (t
             (lose)))))
       (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
 

@@ -508,28 +506,22 @@
 
 (/show0 "filesys.lisp 498")
 
 
 (/show0 "filesys.lisp 498")
 

-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
-
-(defmacro enumerate-matches ((var pathname &optional result
-                                 &key (verify-existence t)
-                                  (follow-links t))
-                            &body body)
-  (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-")))
-    `(block nil
-       (flet ((,body-name (,var)
-               ,@body))
-         (declare (dynamic-extent ,body-name))
-        (%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")
 
 ;;; Call FUNCTION on matches.
 (defun %enumerate-matches (pathname verify-existence follow-links function)
 
 (/show0 "filesys.lisp 500")
 
 ;;; Call FUNCTION on matches.
 (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)))

@@ -537,17 +529,17 @@
             (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))))

@@ -566,6 +558,13 @@
                  (when (and res (eql (logand mode sb!unix:s-ifmt)
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))
                  (when (and res (eql (logand mode sb!unix:s-ifmt)
                                      sb!unix:s-ifdir))
                    (let ((nodes (cons (cons dev ino) nodes)))

+                     ,@body))))
+            (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)))
                      ,@body)))))
     (if tail
        (let ((piece (car tail)))

@@ -613,24 +612,25 @@
                                                 verify-existence follow-links
                                                 nodes function))))))))
          ((member :up)
                                                 verify-existence follow-links
                                                 nodes function))))))))
          ((member :up)

+            (with-directory-node-removed (head)

             (let ((head (concatenate 'string head "..")))
               (with-directory-node-noted (head)
                 (%enumerate-directories (concatenate 'string head "/")
                                         (rest tail) pathname
                                         verify-existence follow-links
             (let ((head (concatenate 'string head "..")))
               (with-directory-node-noted (head)
                 (%enumerate-directories (concatenate 'string head "/")
                                         (rest tail) pathname
                                         verify-existence follow-links

-                                        nodes function))))))
+                                        nodes function)))))))

        (%enumerate-files head pathname verify-existence function))))
 
 ;;; Call FUNCTION on files.
 (defun %enumerate-files (directory pathname verify-existence function)
   (declare (simple-string directory))
        (%enumerate-files head pathname verify-existence function))))
 
 ;;; Call FUNCTION on files.
 (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")
+          (/noshow0 "UNSPECIFIC, more or less")

           (when (or (not verify-existence)
                     (sb!unix:unix-file-kind directory))
             (funcall function directory)))
           (when (or (not verify-existence)
                     (sb!unix:unix-file-kind directory))
             (funcall function directory)))

@@ -638,7 +638,7 @@
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))
               (pattern-p type)
               (eq name :wild)
               (eq type :wild))

-          (/show0 "WILD, more or less")
+          (/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
           ;; 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

@@ -661,25 +661,23 @@
                                       directory
                                       complete-filename))))))
          (t
                                       directory
                                       complete-filename))))))
          (t

-          (/show0 "default case")
+          (/noshow0 "default case")

           (let ((file (concatenate 'string directory name)))
           (let ((file (concatenate 'string directory name)))

-            (/show0 "computed basic FILE=..")
-            (/primitive-print file)
+            (/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")
+              (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")

               (setf file (concatenate 'string file "." type)))
             (unless (member version '(nil :newest :wild))
               (setf file (concatenate 'string file "." type)))
             (unless (member version '(nil :newest :wild))

-              (/show0 "tweaking FILE for more-or-less-:WILD case")
+              (/noshow0 "tweaking FILE for more-or-less-:WILD case")

               (setf file (concatenate 'string file "."
                                       (quick-integer-to-string version))))
               (setf file (concatenate 'string file "."
                                       (quick-integer-to-string version))))

-            (/show0 "finished possibly tweaking FILE=..")
-            (/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)

@@ -727,8 +725,7 @@
       ))
 
 ;;; Convert PATHNAME into a string that can be used with UNIX system
       ))
 
 ;;; Convert PATHNAME into a string that can be used with UNIX system

-;;; calls, or return NIL if no match is found. Search-lists and
-;;; wild-cards are expanded.
+;;; calls, or return NIL if no match is found. Wild-cards are expanded.

 (defun unix-namestring (pathname-spec &optional (for-input t))
   ;; The ordinary rules of converting Lispy paths to Unix paths break
   ;; down for the current working directory, which Lisp thinks of as
 (defun unix-namestring (pathname-spec &optional (for-input t))
   ;; The ordinary rules of converting Lispy paths to Unix paths break
   ;; down for the current working directory, which Lisp thinks of as

@@ -748,7 +745,7 @@
       ;; Otherwise, the ordinary rules apply.
       (let* ((namestring (physicalize-pathname (pathname pathname-spec)))
             (matches nil)) ; an accumulator for actual matches
       ;; Otherwise, the ordinary rules apply.
       (let* ((namestring (physicalize-pathname (pathname pathname-spec)))
             (matches nil)) ; an accumulator for actual matches

-       (enumerate-matches (match namestring nil :verify-existence for-input)
+       (!enumerate-matches (match namestring nil :verify-existence for-input)

           (push match matches))
        (case (length matches)
          (0 nil)
           (push match matches))
        (case (length matches)
          (0 nil)

@@ -886,7 +883,7 @@
 
 (defun file-author (file)
   #!+sb-doc
 
 (defun file-author (file)
   #!+sb-doc

-  "Return the file author as a string, or nil if the author cannot be
+  "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)
  determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
  or FILE is a wild pathname."
   (if (wild-pathname-p file)

@@ -902,7 +899,7 @@
        (multiple-value-bind (winp dev ino mode nlink uid)
            (sb!unix:unix-stat name)
          (declare (ignore dev ino mode nlink))
        (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))))))
+         (and winp (sb!unix:uid-username uid))))))

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

@@ -915,92 +912,31 @@
    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."
    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 ((truenames nil))
-    (enumerate-search-list
-       (pathname (merge-pathnames pathname
-                                  (make-pathname :name :wild
-                                                 :type :wild
-                                                 :version :wild)))
-      (enumerate-matches (match pathname)
-       (let ((*ignore-wildcards* t))
-         (push (truename (if (eq (sb!unix:unix-file-kind match) :directory)
-                             (concatenate 'string match "/")
-                             match))
-               truenames))))
-    ;; FIXME: The DELETE-DUPLICATES here requires quadratic time,
-    ;; which is unnecessarily slow. That might not be an issue,
-    ;; though, since the time constant for doing TRUENAME on every
-    ;; directory entry is likely to be (much) larger, and the cost of
-    ;; all those TRUENAMEs on a huge directory might even be quadratic
-    ;; in the directory size. Someone who cares about enormous
-    ;; directories might want to check this. -- WHN 2001-06-19
-    (sort (delete-duplicates truenames :test #'string= :key #'pathname-name)
-         #'string< :key #'pathname-name)))
-\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")
-
-;;; 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)))))
-
-;;; 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: 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: 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))))))))))))
+  (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))
+        (merged-pathname (merge-pathnames pathname
+                                         *default-pathname-defaults*)))
+    (!enumerate-matches (match merged-pathname)
+      (let ((*ignore-wildcards* t)
+            (truename (truename (if (eq (sb!unix:unix-file-kind match)
+                                       :directory)
+                                    (concatenate 'string match "/")
+                                    match))))
+        (setf (gethash (namestring truename) truenames)
+             truename)))
+    (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")
 

@@ -1028,27 +964,25 @@
       (error 'simple-file-error
             :format-control "bad place for a wild pathname"
             :pathname pathspec))
       (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 (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)))))
+      (values pathname created-p))))

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