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

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 81da10f..762f472 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -286,8 +286,8 @@
 ;;;
 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
 ;;; time using ONCE-ONLY, *then* tested)
-;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
-(defmacro with-pathname ((pathname pathname-designator) &body body)
+(eval-when (:compile-toplevel :execute)
+(sb!xc:defmacro with-pathname ((pathname pathname-designator) &body body)
   (let ((pd0 (gensym)))
     `(let* ((,pd0 ,pathname-designator)
             (,pathname (etypecase ,pd0
@@ -296,7 +296,7 @@
                          (file-stream (file-name ,pd0)))))
        ,@body)))
 
-(defmacro with-native-pathname ((pathname pathname-designator) &body body)
+(sb!xc:defmacro with-native-pathname ((pathname pathname-designator) &body body)
   (let ((pd0 (gensym)))
     `(let* ((,pd0 ,pathname-designator)
             (,pathname (etypecase ,pd0
@@ -307,7 +307,7 @@
                          (file-stream (file-name ,pd0)))))
        ,@body)))
 
-(defmacro with-host ((host host-designator) &body body)
+(sb!xc:defmacro with-host ((host host-designator) &body body)
   ;; Generally, redundant specification of information in software,
   ;; whether in code or in comments, is bad. However, the ANSI spec
   ;; for this is messy enough that it's hard to hold in short-term
@@ -363,6 +363,7 @@
                              ,hd0))
                      (host ,hd0))))
       ,@body)))
+) ; EVAL-WHEN
 
 (defun find-host (host-designator &optional (errorp t))
   (with-host (host host-designator)
@@ -1063,7 +1064,7 @@ system's syntax for files."
              (frob %pathname-directory directory-components-match)
              (frob %pathname-name)
              (frob %pathname-type)
-             (or (eq (%pathname-host wildname) *unix-host*)
+             (or (eq (%pathname-host wildname) *physical-host*)
                  (frob %pathname-version)))))))
 
 ;;; Place the substitutions into the pattern and return the string or pattern
@@ -1255,7 +1256,7 @@ system's syntax for files."
 (defun translate-pathname (source from-wildname to-wildname &key)
   #!+sb-doc
   "Use the source pathname to translate the from-wildname's wild and
-   unspecified elements into a completed to-pathname based on the to-wildname."
+unspecified elements into a completed to-pathname based on the to-wildname."
   (declare (type pathname-designator source from-wildname to-wildname))
   (with-pathname (source source)
     (with-pathname (from from-wildname)
@@ -1509,6 +1510,14 @@ system's syntax for files."
 ;;; loaded yet.
 (defvar *logical-pathname-defaults*)
 
+(defun logical-namestring-p (x)
+  (and (stringp x)
+       (ignore-errors
+         (typep (pathname x) 'logical-pathname))))
+
+(deftype logical-namestring ()
+  `(satisfies logical-namestring-p))
+
 (defun logical-pathname (pathspec)
   #!+sb-doc
   "Converts the pathspec argument to a logical-pathname and returns it."
@@ -1516,12 +1525,19 @@ system's syntax for files."
            (values logical-pathname))
   (if (typep pathspec 'logical-pathname)
       pathspec
-      (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
-        (when (eq (%pathname-host res)
-                  (%pathname-host *logical-pathname-defaults*))
-          (error "This logical namestring does not specify a host:~%  ~S"
-                 pathspec))
-        res)))
+      (flet ((oops (problem)
+               (error 'simple-type-error
+                      :datum pathspec
+                      :expected-type 'logical-namestring
+                      :format-control "~S is not a valid logical namestring:~%  ~A"
+                      :format-arguments (list pathspec problem))))
+        (let ((res (handler-case
+                       (parse-namestring pathspec nil *logical-pathname-defaults*)
+                     (error (e) (oops e)))))
+          (when (eq (%pathname-host res)
+                    (%pathname-host *logical-pathname-defaults*))
+            (oops "no host specified"))
+          res))))
 
 ;;;; logical pathname unparsing
 
@@ -1692,17 +1708,33 @@ system's syntax for files."
 
 (defun load-logical-pathname-translations (host)
   #!+sb-doc
+  "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST,
+with HOST replaced by the supplied parameter. Returns T on success.
+
+If HOST is already defined as logical pathname host, no file is loaded and NIL
+is returned.
+
+The file should contain a single form, suitable for use with
+\(SETF LOGICAL-PATHNAME-TRANSLATIONS).
+
+Note: behaviour of this function is higly implementation dependent, and
+historically it used to be a no-op in SBcL -- the current approach is somewhat
+experimental and subject to change."
   (declare (type string host)
            (values (member t nil)))
   (if (find-logical-host host nil)
       ;; This host is already defined, all is well and good.
       nil
       ;; ANSI: "The specific nature of the search is
-      ;; implementation-defined." SBCL: doesn't search at all
-      ;;
-      ;; FIXME: now that we have a SYS host that the system uses, it
-      ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
-      (error "logical host ~S not found" host)))
+      ;; implementation-defined."
+      (prog1 t
+        (setf (logical-pathname-translations host)
+              (with-open-file (lpt (make-pathname :host "SYS"
+                                                  :directory '(:absolute "SITE")
+                                                  :name host
+                                                  :type "TRANSLATIONS"
+                                                  :version :newest))
+                (read lpt))))))
 
 (defun !pathname-cold-init ()
   (let* ((sys *default-pathname-defaults*)