0.9.8.17:

	Fix a bug in ENSURE-DIRECTORIES-EXIST: merge in
	*DEFAULT-PATHNAME-DEFAULTS*.
	... this fix may also include a mostly-working set of pathname
		functions for Win32.  Or it may not.  You have been
		warned.

build-order.lisp-expr

@@ -640,7 +640,10 @@
  ("src/code/reader"            :not-host) ; needs "code/readtable"
  ("src/code/target-stream"     :not-host) ; needs WHITESPACEP from "code/reader"
  ("src/code/target-pathname"   :not-host) ; needs "code/pathname"
+ ("src/code/unix-pathname"      :not-host)
+ ("src/code/win32-pathname"     :not-host)
  ("src/code/filesys"           :not-host) ; needs HOST from "code/pathname"
+
  ("src/code/save"              :not-host) ; uses the definition of PATHNAME
                                           ;   from "code/pathname"
  ("src/code/sharpm"            :not-host) ; uses stuff from "code/reader"

src/code/pathname.lisp

@@ -25,6 +25,7 @@
   (unparse-directory (missing-arg) :type function)
   (unparse-file (missing-arg) :type function)
   (unparse-enough (missing-arg) :type function)
+  (unparse-directory-separator (missing-arg) :type simple-string)
   (customary-case (missing-arg) :type (member :upper :lower)))
 
 (def!method print-object ((host host) stream)
@@ -49,6 +50,7 @@
                        (unparse-directory #'unparse-logical-directory)
                        (unparse-file #'unparse-logical-file)
                        (unparse-enough #'unparse-enough-namestring)
+                       (unparse-directory-separator ";")
                        (customary-case :upper)))
   (name "" :type simple-base-string)
   (translations nil :type list)

src/code/target-pathname.lisp

@@ -13,7 +13,7 @@
 
 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
 
-;;;; UNIX-HOST stuff
+;;;; PHYSICAL-HOST stuff
 
 (def!struct (unix-host
              (:make-load-form-fun make-unix-host-load-form)
@@ -26,15 +26,34 @@
                        (unparse-directory #'unparse-unix-directory)
                        (unparse-file #'unparse-unix-file)
                        (unparse-enough #'unparse-unix-enough)
+                       (unparse-directory-separator "/")
                        (customary-case :lower))))
-
 (defvar *unix-host* (make-unix-host))
-
 (defun make-unix-host-load-form (host)
   (declare (ignore host))
   '*unix-host*)
 
-(defvar *physical-host* *unix-host*)
+(def!struct (win32-host
+             (:make-load-form-fun make-win32-host-load-form)
+             (:include host
+                       (parse #'parse-win32-namestring)
+                       (parse-native #'parse-native-win32-namestring)
+                       (unparse #'unparse-win32-namestring)
+                       (unparse-native #'unparse-native-win32-namestring)
+                       (unparse-host #'unparse-win32-host)
+                       (unparse-directory #'unparse-win32-directory)
+                       (unparse-file #'unparse-win32-file)
+                       (unparse-enough #'unparse-win32-enough)
+                       (unparse-directory-separator "\\")
+                       (customary-case :upper))))
+(defvar *win32-host* (make-win32-host))
+(defun make-win32-host-load-form (host)
+  (declare (ignore host))
+  '*win32-host*)
+
+(defvar *physical-host*
+  #!-win32 *unix-host*
+  #!+win32 *win32-host*)
 
 ;;; Return a value suitable, e.g., for preinitializing
 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is

src/code/unix-pathname.lisp

@@ -0,0 +1,318 @@
+;;;; pathname parsing for Unix filesystems
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; 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 (namestring start end)
+  (declare (type simple-string namestring)
+           (type index start end))
+  (setf namestring (coerce namestring 'simple-base-string))
+  (multiple-value-bind (absolute pieces)
+      (split-at-slashes namestring 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 namestring 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 namestring
+                   :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= namestring ".."
+                                      :start1 piece-start
+                                      :end1 piece-end)
+                             (dirs :up))
+                            ((string= namestring "**"
+                                      :start1 piece-start
+                                      :end1 piece-end)
+                             (dirs :wild-inferiors))
+                            (t
+                             (dirs (maybe-make-pattern namestring
+                                                       piece-start
+                                                       piece-end)))))))
+                (cond (absolute
+                       (cons :absolute (dirs)))
+                      ((dirs)
+                       (cons :relative (dirs)))
+                      (t
+                       nil)))
+              name
+              type
+              version))))
+
+(defun parse-native-unix-namestring (namestring start end)
+  (declare (type simple-string namestring)
+           (type index start end))
+  (setf namestring (coerce namestring 'simple-base-string))
+  (multiple-value-bind (absolute ranges)
+      (split-at-slashes namestring start end)
+    (let* ((components (loop for ((start . end) . rest) on ranges
+                             for piece = (subseq namestring start end)
+                             collect (if (and (string= piece "..") rest)
+                                         :up
+                                         piece)))
+           (name-and-type
+            (let* ((end (first (last components)))
+                   (dot (position #\. end :from-end t)))
+              ;; FIXME: can we get this dot-interpretation knowledge
+              ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
+              ;; does slightly more work than that.
+              (cond
+                ((string= end "")
+                 (list nil nil))
+                ((and dot (> dot 0))
+                 (list (subseq end 0 dot) (subseq end (1+ dot))))
+                (t
+                 (list end nil))))))
+      (values nil
+              nil
+              (cons (if absolute :absolute :relative) (butlast components))
+              (first name-and-type)
+              (second name-and-type)
+              nil))))
+
+(/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-native-unix-namestring (pathname)
+  (declare (type pathname pathname))
+  (let ((directory (pathname-directory pathname))
+        (name (pathname-name pathname))
+        (type (pathname-type pathname)))
+    (coerce
+     (with-output-to-string (s)
+       (ecase (car directory)
+         (:absolute (write-char #\/ s))
+         (:relative))
+       (dolist (piece (cdr directory))
+         (typecase piece
+           ((member :up) (write-string ".." s))
+           (string (write-string piece s))
+           (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+         (write-char #\/ s))
+       (when name
+         (unless (stringp name)
+           (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
+         (write-string name s)
+         (when type
+           (unless (stringp type)
+             (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
+           (write-char #\. s)
+           (write-string type s))))
+     'simple-base-string)))
+
+(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)))))