new SET-SBCL-SOURCE-LOCATION convenience function

From Zach Beane sbcl-devel 2011-11-15.

Signed-off-by: Christophe Rhodes <csr21@cantab.net>

diff --git a/NEWS b/NEWS
index c37e890..7f67885 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -35,6 +35,9 @@ changes relative to sbcl-1.0.53:
     overflows. (lp#888410)
   * enhancement: RUN-PROGRAM now distinguishes exec() failing from child
     process exiting with code 1. (lp#676987)
+  * enhancement: convenience function SET-SBCL-SOURCE-LOCATION for informing
+    the system where on the filesystem the SBCL sources themselves are
+    located.  (Thanks to Zach Beane)
   * bug fix: on 64-bit targets, atomic-incf/aref does index computation
     correctly, even on wide-fixnum builds. (lp#887220)
   * bug fix: (directory "foo/*/*.*") did not follow symlinks in foo/ that

diff --git a/doc/manual/pathnames.texinfo b/doc/manual/pathnames.texinfo
index 50c3260..4eb43de 100644 (file)
--- a/doc/manual/pathnames.texinfo
+++ b/doc/manual/pathnames.texinfo
@@ -105,6 +105,8 @@ particular, the core system's source files match the logical pathname
 @code{"SYS:SRC;**;*.*.*"}, and the contributed modules' source files
 match @code{"SYS:CONTRIB;**;*.*.*"}.
 
+@include fun-sb-ext-set-sbcl-source-location.texinfo
+
 @node Native Filenames
 @comment  node-name,  next,  previous,  up
 @section Native Filenames

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 58915b0..54430d7 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -799,6 +799,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "TYPEXPAND-1" "TYPEXPAND" "TYPEXPAND-ALL"
                "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P"
                "DELETE-DIRECTORY"
+               "SET-SBCL-SOURCE-LOCATION"
 
                ;; stepping interface
                "STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION"

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index ff023ee..b791566 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -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)))))