Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv4116/src/code
184.108.40.206: real LOAD-LOGICAL-PATHNAME-TRANSLATIONS
* Read translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST.
Patch by Michael Weber on sbcl-devel.
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- target-pathname.lisp 18 Sep 2009 11:31:24 -0000 1.63
+++ target-pathname.lisp 17 Mar 2010 14:28:00 -0000 1.64
@@ -1256,7 +1256,7 @@
(defun translate-pathname (source from-wildname to-wildname &key)
"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 @@
(defun load-logical-pathname-translations (host)
+ "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
+The file should contain a single form, suitable for use with
+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.
;; 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*)