0.9.16.17:

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

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 2887bac..f323df9 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -1,4 +1,5 @@
-;;;; file system interface functions -- fairly Unix-specific
+;;;; file system interface functions -- fairly Unix-centric, but with
+;;;; differences between Unix and Win32 papered over.

 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.

@@ -13,6 +14,11 @@
 \f
 ;;;; Unix pathname host support
 
 \f
 ;;;; Unix pathname host support
 

+;;; FIXME: the below shouldn't really be here, but in documentation
+;;; (chapter 19 makes a lot of requirements for documenting
+;;; implementation-dependent decisions), but anyway it's probably not
+;;; what we currently do.
+;;;

 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]
 ;;; Unix namestrings have the following format:
 ;;;
 ;;; namestring := [ directory ] [ file [ type [ version ]]]

@@ -29,11 +35,7 @@
 ;;; - If the first character is a dot, it's part of the file. It is not
 ;;; considered a dot in the following rules.
 ;;;
 ;;; - If the first character is a dot, it's part of the file. It is not
 ;;; considered a dot in the following rules.
 ;;;

-;;; - If there is only one dot, it separates the file and the type.
-;;;
-;;; - If there are multiple dots and the stuff following the last dot
-;;; is a valid version, then that is the version and the stuff between
-;;; the second to last dot and the last dot is the type.
+;;; - Otherwise, the last dot separates the file and the type.

 ;;;
 ;;; Wildcard characters:
 ;;;
 ;;;
 ;;; Wildcard characters:
 ;;;

@@ -41,10 +43,11 @@
 ;;; following characters, it is considered part of a wildcard pattern
 ;;; and has the following meaning.
 ;;;
 ;;; following characters, it is considered part of a wildcard pattern
 ;;; and has the following meaning.
 ;;;

-;;; ? - matches any character
+;;; ? - matches any one character

 ;;; * - matches any zero or more characters.
 ;;; [abc] - matches any of a, b, or c.
 ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
 ;;; * - matches any zero or more characters.
 ;;; [abc] - matches any of a, b, or c.
 ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.

+;;;   (FIXME: no it doesn't)

 ;;;
 ;;; Any of these special characters can be preceded by a backslash to
 ;;; cause it to be treated as a regular character.
 ;;;
 ;;; Any of these special characters can be preceded by a backslash to
 ;;; cause it to be treated as a regular character.

@@ -52,9 +55,9 @@
   #!+sb-doc
   "Remove any occurrences of #\\ from the string because we've already
    checked for whatever they may have protected."
   #!+sb-doc
   "Remove any occurrences of #\\ from the string because we've already
    checked for whatever they may have protected."

-  (declare (type simple-base-string namestr)
+  (declare (type simple-string namestr)

            (type index start end))
            (type index start end))

-  (let* ((result (make-string (- end start) :element-type 'base-char))
+  (let* ((result (make-string (- end start) :element-type 'character))

          (dst 0)
          (quoted nil))
     (do ((src start (1+ src)))
          (dst 0)
          (quoted nil))
     (do ((src start (1+ src)))

@@ -82,7 +85,7 @@
 (/show0 "filesys.lisp 86")
 
 (defun maybe-make-pattern (namestr start end)
 (/show0 "filesys.lisp 86")
 
 (defun maybe-make-pattern (namestr start end)

-  (declare (type simple-base-string namestr)
+  (declare (type simple-string namestr)

            (type index start end))
   (if *ignore-wildcards*
       (subseq namestr start end)
            (type index start end))
   (if *ignore-wildcards*
       (subseq namestr start end)

@@ -155,7 +158,7 @@
 (/show0 "filesys.lisp 160")
 
 (defun extract-name-type-and-version (namestr start end)
 (/show0 "filesys.lisp 160")
 
 (defun extract-name-type-and-version (namestr start end)

-  (declare (type simple-base-string namestr)
+  (declare (type simple-string namestr)

            (type index start end))
   (let* ((last-dot (position #\. namestr :start (1+ start) :end end
                              :from-end t)))
            (type index start end))
   (let* ((last-dot (position #\. namestr :start (1+ start) :end end
                              :from-end t)))

@@ -171,252 +174,6 @@
 
 (/show0 "filesys.lisp 200")
 
 
 (/show0 "filesys.lisp 200")
 

-;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value is true if absolute directories
-;;; location.
-(defun split-at-slashes (namestr start end)
-  (declare (type simple-base-string namestr)
-           (type index start end))
-  (let ((absolute (and (/= start end)
-                       (char= (schar namestr start) #\/))))
-    (when absolute
-      (incf start))
-    ;; Next, split the remainder into slash-separated chunks.
-    (collect ((pieces))
-      (loop
-        (let ((slash (position #\/ namestr :start start :end end)))
-          (pieces (cons start (or slash end)))
-          (unless slash
-            (return))
-          (setf start (1+ slash))))
-      (values absolute (pieces)))))
-
-(defun parse-unix-namestring (namestr 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 (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))
-  ;; 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
-    ((member :wild) "*")
-    (simple-string
-     (let* ((srclen (length thing))
-            (dstlen srclen))
-       (dotimes (i srclen)
-         (case (schar thing i)
-           ((#\* #\? #\[)
-            (incf dstlen))))
-       (let ((result (make-string dstlen))
-             (dst 0))
-         (dotimes (src srclen)
-           (let ((char (schar thing src)))
-             (case char
-               ((#\* #\? #\[)
-                (setf (schar result dst) #\\)
-                (incf dst)))
-             (setf (schar result dst) char)
-             (incf dst)))
-         result)))
-    (pattern
-     (collect ((strings))
-       (dolist (piece (pattern-pieces thing))
-         (etypecase piece
-           (simple-string
-            (strings piece))
-           (symbol
-            (ecase piece
-              (:multi-char-wild
-               (strings "*"))
-              (:single-char-wild
-               (strings "?"))))
-           (cons
-            (case (car piece)
-              (:character-set
-               (strings "[")
-               (strings (cdr piece))
-               (strings "]"))
-              (t
-               (error "invalid pattern piece: ~S" piece))))))
-       (apply #'concatenate
-              'simple-base-string
-              (strings))))))
-
-(defun unparse-unix-directory-list (directory)
-  (declare (type list directory))
-  (collect ((pieces))
-    (when directory
-      (ecase (pop directory)
-        (:absolute
-         (pieces "/"))
-        (:relative
-         ;; nothing special
-         ))
-      (dolist (dir directory)
-        (typecase dir
-          ((member :up)
-           (pieces "../"))
-          ((member :back)
-           (error ":BACK cannot be represented in namestrings."))
-          ((member :wild-inferiors)
-           (pieces "**/"))
-          ((or simple-string pattern (member :wild))
-           (pieces (unparse-unix-piece dir))
-           (pieces "/"))
-          (t
-           (error "invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-base-string (pieces))))
-
-(defun unparse-unix-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-unix-directory-list (%pathname-directory pathname)))
-
-(defun unparse-unix-file (pathname)
-  (declare (type pathname pathname))
-  (collect ((strings))
-    (let* ((name (%pathname-name pathname))
-           (type (%pathname-type pathname))
-           (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 (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))
-        (when (typep type 'simple-string)
-          (when (position #\. type)
-            (error "type component can't have a #\. inside: ~S" pathname)))
-        (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))
-  (concatenate 'simple-base-string
-               (unparse-unix-directory pathname)
-               (unparse-unix-file pathname)))
-
-(defun unparse-unix-enough (pathname defaults)
-  (declare (type pathname pathname defaults))
-  (flet ((lose ()
-           (error "~S cannot be represented relative to ~S."
-                  pathname defaults)))
-    (collect ((strings))
-      (let* ((pathname-directory (%pathname-directory pathname))
-             (defaults-directory (%pathname-directory defaults))
-             (prefix-len (length defaults-directory))
-             (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)
-                                             defaults-directory))
-                     ;; Pathname starts with a prefix of default. So
-                     ;; just use a relative directory from then on out.
-                     (cons :relative (nthcdr prefix-len pathname-directory)))
-                    ((eq (car pathname-directory) :absolute)
-                     ;; We are an absolute pathname, so we can just use it.
-                     pathname-directory)
-                    (t
-                     (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
-                                   (not (compare-component pathname-name
-                                                           (%pathname-name
-                                                            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))
-          (when (typep pathname-type 'simple-base-string)
-            (when (position #\. pathname-type)
-              (error "type component can't have a #\. inside: ~S" pathname)))
-          (strings ".")
-          (strings (unparse-unix-piece pathname-type))))
-      (apply #'concatenate 'simple-string (strings)))))

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

@@ -455,6 +212,15 @@
 (/show0 "filesys.lisp 500")
 
 ;;; Call FUNCTION on matches.
 (/show0 "filesys.lisp 500")
 
 ;;; Call FUNCTION on matches.

+;;;
+;;; KLUDGE: this assumes that an absolute pathname is indicated to the
+;;; operating system by having a directory separator as the first
+;;; character in the directory part.  This is true for Win32 pathnames
+;;; and for Unix pathnames, but it isn't true for LispM pathnames (and
+;;; their bastard offspring, logical pathnames.  Also it assumes that
+;;; Unix pathnames have an empty or :unspecific device, and that
+;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC
+;;; devices.

 (defun %enumerate-matches (pathname verify-existence follow-links function)
   (/noshow0 "entering %ENUMERATE-MATCHES")
   (when (pathname-type pathname)
 (defun %enumerate-matches (pathname verify-existence follow-links function)
   (/noshow0 "entering %ENUMERATE-MATCHES")
   (when (pathname-type pathname)

@@ -463,25 +229,28 @@
   (when (and (integerp (pathname-version pathname))
              (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))
   (when (and (integerp (pathname-version pathname))
              (member (pathname-type pathname) '(nil :unspecific)))
     (error "cannot supply a version without a type:~%  ~S" pathname))

-  (let ((directory (pathname-directory pathname)))
-    (/noshow0 "computed DIRECTORY")
-    (if directory
-        (ecase (first directory)
-          (:absolute
-           (/noshow0 "absolute directory")
-           (%enumerate-directories "/" (rest directory) pathname
-                                   verify-existence follow-links
-                                   nil function))
-          (:relative
-           (/noshow0 "relative directory")
-           (%enumerate-directories "" (rest directory) pathname
-                                   verify-existence follow-links
-                                   nil function)))
-        (%enumerate-files "" pathname verify-existence function))))
+  (let ((host (pathname-host pathname))
+        (device (pathname-device pathname))
+        (directory (pathname-directory pathname)))
+    (/noshow0 "computed HOST and DIRECTORY")
+    (let* ((dirstring (if directory
+                          (ecase (first directory)
+                            (:absolute (host-unparse-directory-separator host))
+                            (:relative ""))
+                          ""))
+           (devstring (if (and device (not (eq device :unspecific)))
+                          (concatenate 'simple-string (string device) (string #\:))
+                          ""))
+           (headstring (concatenate 'simple-string devstring dirstring)))
+      (if directory
+          (%enumerate-directories headstring (rest directory) pathname
+                                  verify-existence follow-links nil function)
+          (%enumerate-files headstring pathname verify-existence function)))))

 
 ;;; Call FUNCTION on directories.
 (defun %enumerate-directories (head tail pathname verify-existence
 
 ;;; Call FUNCTION on directories.
 (defun %enumerate-directories (head tail pathname verify-existence

-                               follow-links nodes function)
+                               follow-links nodes function
+                               &aux (host (pathname-host pathname)))

   (declare (simple-string head))
   (macrolet ((unix-xstat (name)
                `(if follow-links
   (declare (simple-string head))
   (macrolet ((unix-xstat (name)
                `(if follow-links

@@ -505,12 +274,14 @@
         (let ((piece (car tail)))
           (etypecase piece
             (simple-string
         (let ((piece (car tail)))
           (etypecase piece
             (simple-string

-             (let ((head (concatenate 'base-string head piece)))
+             (let ((head (concatenate 'string head piece)))

                (with-directory-node-noted (head)
                (with-directory-node-noted (head)

-                 (%enumerate-directories (concatenate 'base-string head "/")
-                                         (cdr tail) pathname
-                                         verify-existence follow-links
-                                         nodes function))))
+                 (%enumerate-directories
+                  (concatenate 'string head
+                               (host-unparse-directory-separator host))
+                  (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
             ((member :wild-inferiors)
              ;; now with extra error case handling from CLHS
              ;; 19.2.2.4.3 -- CSR, 2004-01-24

@@ -522,8 +293,8 @@
              (%enumerate-directories head (rest tail) pathname
                                      verify-existence follow-links
                                      nodes function)
              (%enumerate-directories head (rest tail) pathname
                                      verify-existence follow-links
                                      nodes function)

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

@@ -534,14 +305,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 'base-string subdir "/")))
+                             (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))

                          (%enumerate-directories subdir tail pathname
                                                  verify-existence follow-links
                                                  nodes function))))))))
             ((or pattern (member :wild))
              (dolist (name (directory-lispy-filenames head))
                (when (or (eq piece :wild) (pattern-matches piece name))
                          (%enumerate-directories subdir tail pathname
                                                  verify-existence follow-links
                                                  nodes function))))))))
             ((or pattern (member :wild))
              (dolist (name (directory-lispy-filenames head))
                (when (or (eq piece :wild) (pattern-matches piece name))

-                 (let ((subdir (concatenate 'base-string head name)))
+                 (let ((subdir (concatenate '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))

@@ -549,26 +320,26 @@
                                 (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 'base-string subdir "/")))
+                             (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))

                          (%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)

-           (when (string= head "/")
+           (when (string= head (host-unparse-directory-separator host))

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

                (with-directory-node-noted (head)
                (with-directory-node-noted (head)

-                 (%enumerate-directories (concatenate 'base-string head "/")
+                 (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host))

                                          (rest tail) pathname
                                          verify-existence follow-links
                                          nodes function)))))
           ((member :back)
            ;; :WILD-INFERIORS is handled above, so the only case here
            ;; should be (:ABSOLUTE :BACK)
                                          (rest tail) pathname
                                          verify-existence follow-links
                                          nodes function)))))
           ((member :back)
            ;; :WILD-INFERIORS is handled above, so the only case here
            ;; should be (:ABSOLUTE :BACK)

-           (aver (string= head "/"))
+           (aver (string= head (host-unparse-directory-separator host)))

            (error 'simple-file-error
                   :pathname pathname
                   :format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
            (error 'simple-file-error
                   :pathname pathname
                   :format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))

@@ -584,7 +355,7 @@
     (/noshow0 "computed NAME, TYPE, and VERSION")
     (cond ((member name '(nil :unspecific))
            (/noshow0 "UNSPECIFIC, more or less")
     (/noshow0 "computed NAME, TYPE, and VERSION")
     (cond ((member name '(nil :unspecific))
            (/noshow0 "UNSPECIFIC, more or less")

-           (let ((directory (coerce directory 'base-string)))
+           (let ((directory (coerce directory 'string)))

              (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))))

@@ -611,19 +382,19 @@
                           (components-match file-type type)
                           (components-match file-version version))
                  (funcall function
                           (components-match file-type type)
                           (components-match file-version version))
                  (funcall function

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

                                        directory
                                        complete-filename))))))
           (t
            (/noshow0 "default case")
                                        directory
                                        complete-filename))))))
           (t
            (/noshow0 "default case")

-           (let ((file (concatenate 'base-string directory name)))
+           (let ((file (concatenate 'string directory name)))

              (/noshow "computed basic FILE")
              (unless (or (null type) (eq type :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
              (/noshow "computed basic FILE")
              (unless (or (null type) (eq type :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")

-               (setf file (concatenate 'base-string file "." type)))
+               (setf file (concatenate 'string file "." type)))

              (unless (member version '(nil :newest :wild :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:WILD case")
              (unless (member version '(nil :newest :wild :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:WILD case")

-               (setf file (concatenate 'base-string file "."
+               (setf file (concatenate 'string file "."

                                        (quick-integer-to-string version))))
              (/noshow0 "finished possibly tweaking FILE")
              (when (or (not verify-existence)
                                        (quick-integer-to-string version))))
              (/noshow0 "finished possibly tweaking FILE")
              (when (or (not verify-existence)

@@ -680,6 +451,13 @@
 
 ;;; 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.
 
 ;;; 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.

+;;;
+;;; FIXME: apart from the error checking (for wildness and for
+;;; existence) and conversion to physical pathanme, this is redundant
+;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be
+;;; written in terms of the other.
+;;;
+;;; FIXME: actually this (I think) works not just for Unix.

 (defun unix-namestring (pathname-spec &optional (for-input t))
   (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
          (matches nil)) ; an accumulator for actual matches
 (defun unix-namestring (pathname-spec &optional (for-input t))
   (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
          (matches nil)) ; an accumulator for actual matches

@@ -728,6 +506,7 @@
           (let* ((*ignore-wildcards* t)
                  (name (sb!unix:unix-simplify-pathname trueishname)))
             (if (eq (sb!unix:unix-file-kind name) :directory)
           (let* ((*ignore-wildcards* t)
                  (name (sb!unix:unix-simplify-pathname trueishname)))
             (if (eq (sb!unix:unix-file-kind name) :directory)

+                ;; FIXME: this might work, but it's ugly.

                 (pathname (concatenate 'string name "/"))
                 (pathname name))))))))
 \f
                 (pathname (concatenate 'string name "/"))
                 (pathname name))))))))
 \f

@@ -776,11 +555,39 @@
         (simple-file-perror "couldn't delete ~A" namestring err))))
   t)
 \f
         (simple-file-perror "couldn't delete ~A" namestring err))))
   t)
 \f

+(defun ensure-trailing-slash (string)
+  (let ((last-char (char string (1- (length string)))))
+         (if (or (eql last-char #\/)
+                 #!+win32
+                 (eql last-char #\\))
+             string
+             (concatenate 'string string "/"))))
+
+(defun sbcl-homedir-pathname ()
+  (let ((sbcl-home (posix-getenv "SBCL_HOME")))
+    ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores
+    (when sbcl-home
+      (parse-native-namestring
+       (ensure-trailing-slash sbcl-home)))))
+

 ;;; (This is an ANSI Common Lisp function.)
 (defun user-homedir-pathname (&optional host)
 ;;; (This is an ANSI Common Lisp function.)
 (defun user-homedir-pathname (&optional host)

-  "Return the home directory of the user as a pathname."
+  #!+sb-doc
+  "Return the home directory of the user as a pathname. If the HOME
+environment variable has been specified, the directory it designates
+is returned; otherwise obtains the home directory from the operating
+system."

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

-  (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))
+  (parse-native-namestring
+   (ensure-trailing-slash
+    (if (posix-getenv "HOME")
+        (posix-getenv "HOME")
+        #!-win32
+        (sb!unix:uid-homedir (sb!unix:unix-getuid))
+        #!+win32
+        ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH
+        (return-from user-homedir-pathname
+          (sb!win32::get-folder-pathname sb!win32::csidl_profile))))))

 
 (defun file-write-date (file)
   #!+sb-doc
 
 (defun file-write-date (file)
   #!+sb-doc

@@ -1029,7 +836,7 @@
   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."
   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)))
+  (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec))))

         (created-p nil))
     (when (wild-pathname-p pathname)
       (error 'simple-file-error
         (created-p nil))
     (when (wild-pathname-p pathname)
       (error 'simple-file-error

@@ -1042,7 +849,7 @@
                                :device (pathname-device pathname)
                                :directory (subseq dir 0 i))))
                  (unless (probe-file newpath)
                                :device (pathname-device pathname)
                                :directory (subseq dir 0 i))))
                  (unless (probe-file newpath)

-                   (let ((namestring (coerce (namestring newpath) 'base-string)))
+                   (let ((namestring (coerce (namestring newpath) 'string)))

                      (when verbose
                        (format *standard-output*
                                "~&creating directory: ~A~%"
                      (when verbose
                        (format *standard-output*
                                "~&creating directory: ~A~%"

@@ -1060,6 +867,6 @@
                            :report "Continue as if directory creation was successful."
                            nil)))
                      (setf created-p t)))))
                            :report "Continue as if directory creation was successful."
                            nil)))
                      (setf created-p t)))))

-      (values pathname created-p))))
+      (values pathspec created-p))))

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