Disable win32 pathnames routines on -win32 and vice versa.

[sbcl.git] / src / code / target-pathname.lisp

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 52e81dc..2d20434 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -13,49 +13,12 @@
 
 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
 \f
-;;;; PHYSICAL-HOST stuff
-
-(def!struct (unix-host
-             (:make-load-form-fun make-unix-host-load-form)
-             (:include host
-                       (parse #'parse-unix-namestring)
-                       (parse-native #'parse-native-unix-namestring)
-                       (unparse #'unparse-unix-namestring)
-                       (unparse-native #'unparse-native-unix-namestring)
-                       (unparse-host #'unparse-unix-host)
-                       (unparse-directory #'unparse-physical-directory)
-                       (unparse-file #'unparse-unix-file)
-                       (unparse-enough #'unparse-unix-enough)
-                       (unparse-directory-separator "/")
-                       (simplify-namestring #'simplify-unix-namestring)
-                       (customary-case :lower))))
-(defvar *unix-host* (make-unix-host))
-(defun make-unix-host-load-form (host)
-  (declare (ignore host))
-  '*unix-host*)
-
-(def!struct (win32-host
-             (:make-load-form-fun make-win32-host-load-form)
-             (:include host
-                       (parse #'parse-win32-namestring)
-                       (parse-native #'parse-native-win32-namestring)
-                       (unparse #'unparse-win32-namestring)
-                       (unparse-native #'unparse-native-win32-namestring)
-                       (unparse-host #'unparse-win32-host)
-                       (unparse-directory #'unparse-physical-directory)
-                       (unparse-file #'unparse-win32-file)
-                       (unparse-enough #'unparse-win32-enough)
-                       (unparse-directory-separator "\\")
-                       (simplify-namestring #'simplify-win32-namestring)
-                       (customary-case :upper))))
-(defparameter *win32-host* (make-win32-host))
-(defun make-win32-host-load-form (host)
-  (declare (ignore host))
-  '*win32-host*)
+;;; To be initialized in unix/win32-pathname.lisp
+(defvar *physical-host*)
 
-(defvar *physical-host*
-  #!-win32 *unix-host*
-  #!+win32 *win32-host*)
+(defun make-host-load-form (host)
+  (declare (ignore host))
+  '*physical-host*)
 
 ;;; Return a value suitable, e.g., for preinitializing
 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
@@ -267,19 +230,20 @@
 (defun pathname= (pathname1 pathname2)
   (declare (type pathname pathname1)
            (type pathname pathname2))
-  (and (eq (%pathname-host pathname1)
-           (%pathname-host pathname2))
-       (compare-component (%pathname-device pathname1)
-                          (%pathname-device pathname2))
-       (compare-component (%pathname-directory pathname1)
-                          (%pathname-directory pathname2))
-       (compare-component (%pathname-name pathname1)
-                          (%pathname-name pathname2))
-       (compare-component (%pathname-type pathname1)
-                          (%pathname-type pathname2))
-       (or (eq (%pathname-host pathname1) *unix-host*)
-           (compare-component (%pathname-version pathname1)
-                              (%pathname-version pathname2)))))
+  (or (eq pathname1 pathname2)
+      (and (eq (%pathname-host pathname1)
+               (%pathname-host pathname2))
+           (compare-component (%pathname-device pathname1)
+                              (%pathname-device pathname2))
+           (compare-component (%pathname-directory pathname1)
+                              (%pathname-directory pathname2))
+           (compare-component (%pathname-name pathname1)
+                              (%pathname-name pathname2))
+           (compare-component (%pathname-type pathname1)
+                              (%pathname-type pathname2))
+           (or (eq (%pathname-host pathname1) *physical-host*)
+               (compare-component (%pathname-version pathname1)
+                                  (%pathname-version pathname2))))))
 
 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
 ;;; stream), into a pathname in pathname.
@@ -863,7 +827,7 @@ a host-structure or string."
   (cond
     (junk-allowed
      (handler-case
-         (%parse-namestring namestr host defaults start end nil)
+         (%parse-native-namestring namestr host defaults start end nil as-directory)
        (namestring-parse-error (condition)
          (values nil (namestring-parse-error-offset condition)))))
     (t
@@ -1292,7 +1256,7 @@ unspecified elements into a completed to-pathname based on the to-wildname."
                (frob %pathname-directory translate-directories)
                (frob %pathname-name)
                (frob %pathname-type)
-               (if (eq from-host *unix-host*)
+               (if (eq from-host *physical-host*)
                    (if (or (eq (%pathname-version to) :wild)
                            (eq (%pathname-version to) nil))
                        (%pathname-version source)
@@ -1361,7 +1325,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 +1731,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)))))