X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=b791566bd8ce2aa153b9ae3ce52516229a6f275b;hb=d269194b61cad24590c75fe2df7d9237a668668c;hp=52e81dcdd27424f5ff48a4d94abefbb357ce722c;hpb=9df2abae0a60d757448f06f0cc90213ec9fa775b;p=sbcl.git

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 52e81dc..b791566 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -1361,7 +1361,7 @@ unspecified elements into a completed to-pathname based on the to-wildname."
 ;;; a new one if necessary.
 (defun intern-logical-host (thing)
   (declare (values logical-host))
-  (with-locked-hash-table (*logical-hosts*)
+  (with-locked-system-table (*logical-hosts*)
     (or (find-logical-host thing nil)
         (let* ((name (logical-word-or-lose thing))
                (new (make-logical-host :name name)))
@@ -1767,3 +1767,29 @@ experimental and subject to change."
           `(("SYS:SRC;**;*.*.*" ,src)
             ("SYS:CONTRIB;**;*.*.*" ,contrib)
             ("SYS:OUTPUT;**;*.*.*" ,output)))))
+
+(defun set-sbcl-source-location (pathname)
+  "Initialize the SYS logical host based on PATHNAME, which should be
+the top-level directory of the SBCL sources. This will replace any
+existing translations for \"SYS:SRC;\", \"SYS:CONTRIB;\", and
+\"SYS:OUTPUT;\". Other \"SYS:\" translations are preserved."
+  (let ((truename (truename pathname))
+        (current-translations
+         (remove-if (lambda (translation)
+                      (or (pathname-match-p "SYS:SRC;" translation)
+                          (pathname-match-p "SYS:CONTRIB;" translation)
+                          (pathname-match-p "SYS:OUTPUT;" translation)))
+                    (logical-pathname-translations "SYS")
+                    :key #'first)))
+    (flet ((physical-target (component)
+             (merge-pathnames
+              (make-pathname :directory (list :relative component
+                                              :wild-inferiors)
+                             :name :wild
+                             :type :wild)
+              truename)))
+      (setf (logical-pathname-translations "SYS")
+            `(("SYS:SRC;**;*.*.*" ,(physical-target "src"))
+              ("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib"))
+              ("SYS:OUTPUT;**;*.*.*" ,(physical-target "output"))
+              ,@current-translations)))))