From 5601246d7ef4875fe5d90244f58b6951f6199104 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Thu, 22 Feb 2001 20:49:43 +0000 Subject: [PATCH] From Mike McDonald I've appended the necessary mods inorder to make the autoloading of logical pathname translations to work. This includes fixing load-logical-pathname-translations to work the way the manual says it does. --- code/pathname.lisp | 46 +++++++++++++++++++++++++++------------------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/code/pathname.lisp b/code/pathname.lisp index 2e97c0179..261e23516 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.41 2000/07/10 06:31:02 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.42 2001/02/22 20:49:43 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -830,9 +830,13 @@ a host-structure or string." (values (or logical-host null))) (let ((colon-pos (position #\: namestr :start start :end end))) (if colon-pos - (values (gethash (nstring-upcase (subseq namestr start colon-pos)) - *logical-hosts*)) - nil))) + (values (let ((thing (nstring-upcase (subseq namestr start colon-pos)))) + (or (gethash (logical-word-or-lose thing) + *logical-hosts*) + (and (load-logical-pathname-translations thing) + (gethash (logical-word-or-lose thing) + *logical-hosts*))))) + nil))) ;;; PARSE-NAMESTRING -- Interface @@ -1486,8 +1490,12 @@ a host-structure or string." (defun find-logical-host (thing &optional (errorp t)) (etypecase thing (string - (let ((found (gethash (logical-word-or-lose thing) - *logical-hosts*))) + (let ((found (or (gethash (logical-word-or-lose thing) + *logical-hosts*) + (and errorp + (load-logical-pathname-translations thing) + (gethash (logical-word-or-lose thing) + *logical-hosts*))))) (if (or found (not errorp)) found (error 'simple-file-error @@ -1496,7 +1504,6 @@ a host-structure or string." :format-arguments (list thing))))) (logical-host thing))) - ;;; INTERN-LOGICAL-HOST -- Internal ;;; ;;; Given a logical host name or host, return a logical host, creating a new @@ -1809,7 +1816,6 @@ a host-structure or string." (values list)) (logical-host-translations (find-logical-host host))) - ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public ;;; (defun (setf logical-pathname-translations) (translations host) @@ -1839,17 +1845,19 @@ a host-structure or string." successfully, T is returned, else error." (declare (type string host) (values (member t nil))) - (unless (find-logical-host host nil) - (with-open-file (in-str (make-pathname :defaults "library:" - :name host - :type "translations")) - (if *load-verbose* - (format *error-output* - ";; Loading pathname translations from ~A~%" - (namestring (truename in-str)))) - (setf (logical-pathname-translations host) (read in-str))) - t)) - + (when (and (find-logical-host "library" nil) + (not (find-logical-host host nil))) + (let ((filename (make-pathname :defaults "library:" + :name (logical-word-or-lose host) + :type (logical-word-or-lose "translations")))) + (when (probe-file filename) + (with-open-file (in-str filename) + (if *load-verbose* + (format *error-output* + ";; Loading pathname translations from ~A~%" + (namestring (translate-logical-pathname filename)))) + (setf (logical-pathname-translations host) (read in-str))) + t)))) ;;; TRANSLATE-LOGICAL-PATHNAME -- Public ;;; -- GitLab