From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 17 Mar 2010 14:28:00 +0000 (+0000)
Subject: 1.0.36.28: real LOAD-LOGICAL-PATHNAME-TRANSLATIONS
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3f01b91f6cbef8818b9200bc9c7cc81980cdd9c0;p=sbcl.git

1.0.36.28: real LOAD-LOGICAL-PATHNAME-TRANSLATIONS

 * Read translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST.

 Patch by Michael Weber on sbcl-devel.
---

diff --git a/NEWS b/NEWS
index c91a356..2d32718 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@ changes relative to sbcl-1.0.36:
     stack frame thrown from.
   * enhancement: WITH-COMPILATION-UNIT :POLICY allows restricting changes to
     compiler optimization qualities inside dynamic extent of its body.
+  * enhancement: LOAD-LOGICAL-PATHNAME-TRANSLATIONS can be used to load
+    translations from SYS:SITE;<HOST>.TRANSLATIONS.NEWEST (thanks to Michael
+    Weber)
   * optimization: SLOT-VALUE and (SETF SLOT-VALUE) take advantage of
     constraint propgation, allowing better compilation eg. when used to
     access structures with WITH-SLOTS. (lp#520366)
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 54a3116..762f472 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -1256,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)
@@ -1708,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*)
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 7ed7250..e2c200e 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -486,4 +486,36 @@
   (assert (equal (make-pathname :directory '(:absolute))
                  (read-from-string "#p\"\\\\\\\\\""))))
 
+(with-test (:name :load-logical-pathname-translations)
+  (let* ((cwd (truename "."))
+         (foo (merge-pathnames "llpnt-foo.translations" cwd))
+         (bar (merge-pathnames "llpnt-bar.translations" cwd))
+         (translations (logical-pathname-translations "SYS")))
+    (unwind-protect
+         (progn
+           (with-open-file (f foo :direction :output)
+             (prin1 (list (list "*.TEXT" (make-pathname
+                                          :directory '(:absolute "my" "foo")
+                                          :name :wild :type "txt")))
+                    f))
+           (with-open-file (f bar :direction :output)
+             (prin1 (list (list "*.CL" (make-pathname
+                                        :directory '(:absolute "my" "bar")
+                                        :name :wild :type "lisp"))) f))
+           (setf (logical-pathname-translations "SYS")
+                 (list* (list "SITE;LLPNT-FOO.TRANSLATIONS.NEWEST" foo)
+                        (list "SITE;LLPNT-BAR.TRANSLATIONS.NEWEST" bar)
+                        translations))
+           (assert (load-logical-pathname-translations "LLPNT-FOO"))
+           (assert (load-logical-pathname-translations "LLPNT-BAR"))
+           (assert
+            (and
+             (equal "/my/bar/quux.lisp"
+                    (namestring (translate-logical-pathname "LLPNT-BAR:QUUX.CL")))
+             (equal "/my/foo/quux.txt"
+                    (namestring (translate-logical-pathname "LLPNT-FOO:QUUX.TEXT"))))))
+      (ignore-errors (delete-file foo))
+      (ignore-errors (delete-file bar))
+      (setf (logical-pathname-translations "SYS") translations))))
+
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 314304d..89a04bf 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.36.27"
+"1.0.36.28"