X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=f0123a92efd4ffcdcb832a0b6551c61cad8a503b;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=196f50a39432d1e75196ed14cd41c9082e82555d;hpb=a647f35a48924c9bc1914e1286418309fc69704e;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 196f50a..f0123a9 100644 --- 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)) -;;;; 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. @@ -489,15 +453,21 @@ the operating system native pathname conventions." (diddle-case (and default-host pathname-host (not (eq (host-customary-case default-host) - (host-customary-case pathname-host)))))) + (host-customary-case pathname-host))))) + (directory (merge-directories (%pathname-directory pathname) + (%pathname-directory defaults) + diddle-case))) (%make-maybe-logical-pathname (or pathname-host default-host) - (or (%pathname-device pathname) - (maybe-diddle-case (%pathname-device defaults) - diddle-case)) - (merge-directories (%pathname-directory pathname) - (%pathname-directory defaults) - diddle-case) + (and ;; The device of ~/ shouldn't be merged, + ;; because the expansion may have a different device + (not (and (>= (length directory) 2) + (eql (car directory) :absolute) + (eql (cadr directory) :home))) + (or (%pathname-device pathname) + (maybe-diddle-case (%pathname-device defaults) + diddle-case))) + directory (or (%pathname-name pathname) (maybe-diddle-case (%pathname-name defaults) diddle-case)) @@ -515,17 +485,27 @@ the operating system native pathname conventions." ((member :unspecific) '(:relative)) (list (collect ((results)) - (results (pop directory)) - (dolist (piece directory) - (cond ((member piece '(:wild :wild-inferiors :up :back)) - (results piece)) - ((or (simple-string-p piece) (pattern-p piece)) - (results (maybe-diddle-case piece diddle-case))) - ((stringp piece) - (results (maybe-diddle-case (coerce piece 'simple-string) - diddle-case))) - (t - (error "~S is not allowed as a directory component." piece)))) + (let ((root (pop directory))) + (if (member root '(:relative :absolute)) + (results root) + (error "List of directory components must start with ~S or ~S." + :absolute :relative))) + (when directory + (let ((next (pop directory))) + (if (or (eq :home next) + (typep next '(cons (eql :home) (cons string null)))) + (results next) + (push next directory))) + (dolist (piece directory) + (cond ((member piece '(:wild :wild-inferiors :up :back)) + (results piece)) + ((or (simple-string-p piece) (pattern-p piece)) + (results (maybe-diddle-case piece diddle-case))) + ((stringp piece) + (results (maybe-diddle-case (coerce piece 'simple-string) + diddle-case))) + (t + (error "~S is not allowed as a directory component." piece))))) (results))) (simple-string `(:absolute ,(maybe-diddle-case directory diddle-case))) @@ -853,7 +833,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 @@ -1011,7 +991,7 @@ system's syntax for files." &optional (defaults *default-pathname-defaults*)) #!+sb-doc - "Return an abbreviated pathname sufficent to identify the pathname relative + "Return an abbreviated pathname sufficient to identify the pathname relative to the defaults." (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) @@ -1282,7 +1262,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) @@ -1351,7 +1331,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))) @@ -1717,8 +1697,8 @@ is returned. The file should contain a single form, suitable for use with \(SETF LOGICAL-PATHNAME-TRANSLATIONS). -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 +Note: behaviour of this function is highly 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))) @@ -1757,3 +1737,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)))))