X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=81da10fb97a65298da31c5fe258a49fe53f31d51;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=f32e656cce224b6f2cb8c0d8f75732bf93465e21;hpb=81880593109f9f359cd06dc5c4323750ccc2bf21;p=sbcl.git

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index f32e656..81da10f 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -843,7 +843,8 @@ a host-structure or string."
                     thing))
            (values name nil)))))))
 
-(defun %parse-native-namestring (namestr host defaults start end junk-allowed)
+(defun %parse-native-namestring (namestr host defaults start end junk-allowed
+                                 as-directory)
   (declare (type (or host null) host)
            (type string namestr)
            (type index start)
@@ -859,12 +860,13 @@ a host-structure or string."
        (multiple-value-bind (new-host device directory file type version)
            (cond
              (host
-              (funcall (host-parse-native host) namestr start end))
+              (funcall (host-parse-native host) namestr start end as-directory))
              ((pathname-host defaults)
               (funcall (host-parse-native (pathname-host defaults))
                        namestr
                        start
-                       end))
+                       end
+                       as-directory))
              ;; I don't think we should ever get here, as the default
              ;; host will always have a non-null HOST, given that we
              ;; can't create a new pathname without going through
@@ -888,13 +890,17 @@ a host-structure or string."
                                 &optional
                                 host
                                 (defaults *default-pathname-defaults*)
-                                &key (start 0) end junk-allowed)
+                                &key (start 0) end junk-allowed
+                                as-directory)
   #!+sb-doc
   "Convert THING into a pathname, using the native conventions
-appropriate for the pathname host HOST, or if not specified the host
-of DEFAULTS.  If THING is a string, the parse is bounded by START and
-END, and error behaviour is controlled by JUNK-ALLOWED, as with
-PARSE-NAMESTRING."
+appropriate for the pathname host HOST, or if not specified the
+host of DEFAULTS.  If THING is a string, the parse is bounded by
+START and END, and error behaviour is controlled by JUNK-ALLOWED,
+as with PARSE-NAMESTRING.  For file systems whose native
+conventions allow directories to be indicated as files, if
+AS-DIRECTORY is true, return a pathname denoting THING as a
+directory."
   (declare (type pathname-designator thing defaults)
            (type (or list host string (member :unspecific)) host)
            (type index start)
@@ -914,10 +920,11 @@ PARSE-NAMESTRING."
       (etypecase thing
         (simple-string
          (%parse-native-namestring
-          thing found-host defaults start end junk-allowed))
+          thing found-host defaults start end junk-allowed as-directory))
         (string
          (%parse-native-namestring (coerce thing 'simple-string)
-                                   found-host defaults start end junk-allowed))
+                                   found-host defaults start end junk-allowed
+                                   as-directory))
         (pathname
          (let ((defaulted-host (or found-host (%pathname-host defaults))))
            (declare (type host defaulted-host))
@@ -946,9 +953,14 @@ PARSE-NAMESTRING."
                   host:~%  ~S" pathname))
         (funcall (host-unparse host) pathname)))))
 
-(defun native-namestring (pathname)
+(defun native-namestring (pathname &key as-file)
   #!+sb-doc
-  "Construct the full native (name)string form of PATHNAME."
+  "Construct the full native (name)string form of PATHNAME.  For
+file systems whose native conventions allow directories to be
+indicated as files, if AS-FILE is true and the name, type, and
+version components of PATHNAME are all NIL or :UNSPECIFIC,
+construct a string that names the directory according to the file
+system's syntax for files."
   (declare (type pathname-designator pathname))
   (with-native-pathname (pathname pathname)
     (when pathname
@@ -956,7 +968,7 @@ PARSE-NAMESTRING."
         (unless host
           (error "can't determine the native namestring for pathnames with no ~
                   host:~%  ~S" pathname))
-        (funcall (host-unparse-native host) pathname)))))
+        (funcall (host-unparse-native host) pathname as-file)))))
 
 (defun host-namestring (pathname)
   #!+sb-doc
@@ -1692,3 +1704,24 @@ PARSE-NAMESTRING."
       ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
       (error "logical host ~S not found" host)))
 
+(defun !pathname-cold-init ()
+  (let* ((sys *default-pathname-defaults*)
+         (src
+          (merge-pathnames
+           (make-pathname :directory '(:relative "src" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys))
+         (contrib
+          (merge-pathnames
+           (make-pathname :directory '(:relative "contrib" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys))
+         (output
+          (merge-pathnames
+           (make-pathname :directory '(:relative "output" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys)))
+    (setf (logical-pathname-translations "SYS")
+          `(("SYS:SRC;**;*.*.*" ,src)
+            ("SYS:CONTRIB;**;*.*.*" ,contrib)
+            ("SYS:OUTPUT;**;*.*.*" ,output)))))