X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=f0123a92efd4ffcdcb832a0b6551c61cad8a503b;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=8c0f0fa12bbdb89bbdeef16b806cf6fa671b2b95;hpb=0e5c7ae9b0e73edb5efcb9d334760ff2171d17ab;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 8c0f0fa..f0123a9 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,30 +13,18 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;;; UNIX-HOST stuff - -(def!struct (unix-host - (:make-load-form-fun make-unix-host-load-form) - (:include host - (parse #'parse-unix-namestring) - (unparse #'unparse-unix-namestring) - (unparse-host #'unparse-unix-host) - (unparse-directory #'unparse-unix-directory) - (unparse-file #'unparse-unix-file) - (unparse-enough #'unparse-unix-enough) - (customary-case :lower)))) - -(defvar *unix-host* (make-unix-host)) - -(defun make-unix-host-load-form (host) +;;; To be initialized in unix/win32-pathname.lisp +(defvar *physical-host*) + +(defun make-host-load-form (host) (declare (ignore host)) - '*unix-host*) + '*physical-host*) ;;; Return a value suitable, e.g., for preinitializing ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is ;;; initialized (at which time we can't safely call e.g. #'PATHNAME). (defun make-trivial-default-pathname () - (%make-pathname *unix-host* nil nil nil nil :newest)) + (%make-pathname *physical-host* nil nil nil nil :newest)) ;;; pathname methods @@ -81,12 +69,12 @@ (upcase-maybe type) version) (progn - (aver (eq host *unix-host*)) + (aver (eq host *physical-host*)) (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. -(defvar *logical-hosts* (make-hash-table :test 'equal)) +(defvar *logical-hosts* (make-hash-table :test 'equal :synchronized t)) ;;;; patterns @@ -242,27 +230,28 @@ (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. ;;; ;;; FIXME: was rewritten, should be tested (or rewritten again, this ;;; time using ONCE-ONLY, *then* tested) -;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)? -(defmacro with-pathname ((pathname pathname-designator) &body body) +(eval-when (:compile-toplevel :execute) +(sb!xc:defmacro with-pathname ((pathname pathname-designator) &body body) (let ((pd0 (gensym))) `(let* ((,pd0 ,pathname-designator) (,pathname (etypecase ,pd0 @@ -271,26 +260,93 @@ (file-stream (file-name ,pd0))))) ,@body))) -;;; Convert the var, a host or string name for a host, into a -;;; LOGICAL-HOST structure or nil if not defined. -;;; -;;; pw notes 1/12/97 this potentially useful macro is not used anywhere -;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed. -#| -(defmacro with-host ((var expr) &body body) - `(let ((,var (let ((,var ,expr)) - (typecase ,var - (logical-host ,var) - (string (find-logical-host ,var nil)) - (t nil))))) - ,@body)) -|# - -(defun pathname (thing) +(sb!xc:defmacro with-native-pathname ((pathname pathname-designator) &body body) + (let ((pd0 (gensym))) + `(let* ((,pd0 ,pathname-designator) + (,pathname (etypecase ,pd0 + (pathname ,pd0) + (string (parse-native-namestring ,pd0)) + ;; FIXME + #+nil + (file-stream (file-name ,pd0))))) + ,@body))) + +(sb!xc:defmacro with-host ((host host-designator) &body body) + ;; Generally, redundant specification of information in software, + ;; whether in code or in comments, is bad. However, the ANSI spec + ;; for this is messy enough that it's hard to hold in short-term + ;; memory, so I've recorded these redundant notes on the + ;; implications of the ANSI spec. + ;; + ;; According to the ANSI spec, HOST can be a valid pathname host, or + ;; a logical host, or NIL. + ;; + ;; A valid pathname host can be a valid physical pathname host or a + ;; valid logical pathname host. + ;; + ;; A valid physical pathname host is "any of a string, a list of + ;; strings, or the symbol :UNSPECIFIC, that is recognized by the + ;; implementation as the name of a host". In SBCL as of 0.6.9.8, + ;; that means :UNSPECIFIC: though someday we might want to + ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like + ;; '("RTFM" "MIT" "EDU"), that's not supported now. + ;; + ;; A valid logical pathname host is a string which has been defined as + ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. + ;; + ;; A logical host is an object of implementation-dependent nature. In + ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). + (let ((hd0 (gensym))) + `(let* ((,hd0 ,host-designator) + (,host (etypecase ,hd0 + ((string 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical host object. So we do + ;; that. + *physical-host*) + (string + ;; In general ANSI-compliant Common Lisps, a + ;; string might also be a physical pathname + ;; host, but ANSI leaves this up to the + ;; implementor, and in SBCL we don't do it, so + ;; it must be a logical host. + (find-logical-host ,hd0)) + ((or null (member :unspecific)) + ;; CLHS says that HOST=:UNSPECIFIC has + ;; implementation-defined behavior. We + ;; just turn it into NIL. + nil) + (list + ;; ANSI also allows LISTs to designate hosts, + ;; but leaves its interpretation + ;; implementation-defined. Our interpretation + ;; is that it's unsupported.:-| + (error "A LIST representing a pathname host is not ~ + supported in this implementation:~% ~S" + ,hd0)) + (host ,hd0)))) + ,@body))) +) ; EVAL-WHEN + +(defun find-host (host-designator &optional (errorp t)) + (with-host (host host-designator) + (when (and errorp (not host)) + (error "Couldn't find host: ~S" host-designator)) + host)) + +(defun pathname (pathspec) + #!+sb-doc + "Convert PATHSPEC (a pathname designator) into a pathname." + (declare (type pathname-designator pathspec)) + (with-pathname (pathname pathspec) + pathname)) + +(defun native-pathname (pathspec) #!+sb-doc - "Convert thing (a pathname, string or stream) into a pathname." - (declare (type pathname-designator thing)) - (with-pathname (pathname thing) + "Convert PATHSPEC (a pathname designator) into a pathname, assuming +the operating system native pathname conventions." + (with-native-pathname (pathname pathspec) pathname)) ;;; Change the case of thing if DIDDLE-P. @@ -370,7 +426,7 @@ (if (and (eq dir :back) results (not (member (car results) - '(:back :wild-inferiors)))) + '(:back :wild-inferiors :relative :absolute)))) (pop results) (push dir results)))) (dolist (dir (maybe-diddle-case dir2 diddle-case)) @@ -397,15 +453,21 @@ (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)) @@ -423,25 +485,33 @@ ((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))) + `(:absolute ,(maybe-diddle-case directory diddle-case))) (string `(:absolute - ,(maybe-diddle-case (coerce directory 'simple-string) - diddle-case))))) + ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case))))) (defun make-pathname (&key host (device nil devp) @@ -485,11 +555,7 @@ a host-structure or string." ;; as the name of a logical host. ..." ;; HS is silent on what happens if the :HOST arg is NOT one of these. ;; It seems an error message is appropriate. - (host (typecase host - (host host) ; A valid host, use it. - ((string 0) *unix-host*) ; "" cannot be a logical host - (string (find-logical-host host t)) ; logical-host or lose. - (t default-host))) ; unix-host + (host (or (find-host host nil) default-host)) (diddle-args (and (eq (host-customary-case host) :lower) (eq case :common))) (diddle-defaults @@ -670,7 +736,7 @@ a host-structure or string." ;; implementation-defined." ;; ;; Both clauses are handled here, as the default - ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST ;; for a host. ((pathname-host defaults) (funcall (host-parse (pathname-host defaults)) @@ -726,90 +792,135 @@ a host-structure or string." (type (or index null) end) (type (or t null) junk-allowed) (values (or null pathname) (or null index))) - ;; Generally, redundant specification of information in software, - ;; whether in code or in comments, is bad. However, the ANSI spec - ;; for this is messy enough that it's hard to hold in short-term - ;; memory, so I've recorded these redundant notes on the - ;; implications of the ANSI spec. - ;; - ;; According to the ANSI spec, HOST can be a valid pathname host, or - ;; a logical host, or NIL. - ;; - ;; A valid pathname host can be a valid physical pathname host or a - ;; valid logical pathname host. - ;; - ;; A valid physical pathname host is "any of a string, a list of - ;; strings, or the symbol :UNSPECIFIC, that is recognized by the - ;; implementation as the name of a host". In SBCL as of 0.6.9.8, - ;; that means :UNSPECIFIC: though someday we might want to - ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like - ;; '("RTFM" "MIT" "EDU"), that's not supported now. - ;; - ;; A valid logical pathname host is a string which has been defined as - ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. - ;; - ;; A logical host is an object of implementation-dependent nature. In - ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). - (let ((found-host (etypecase host - ((string 0) - ;; This is a special host. It's not valid as a - ;; logical host, so it is a sensible thing to - ;; designate the physical Unix host object. So - ;; we do that. - *unix-host*) + (with-host (found-host host) + (let (;; According to ANSI defaults may be any valid pathname designator + (defaults (etypecase defaults + (pathname + defaults) (string - ;; In general ANSI-compliant Common Lisps, a - ;; string might also be a physical pathname host, - ;; but ANSI leaves this up to the implementor, - ;; and in SBCL we don't do it, so it must be a - ;; logical host. - (find-logical-host host)) - ((or null (member :unspecific)) - ;; CLHS says that HOST=:UNSPECIFIC has - ;; implementation-defined behavior. We - ;; just turn it into NIL. - nil) - (list - ;; ANSI also allows LISTs to designate hosts, - ;; but leaves its interpretation - ;; implementation-defined. Our interpretation - ;; is that it's unsupported.:-| - (error "A LIST representing a pathname host is not ~ - supported in this implementation:~% ~S" - host)) - (host - host))) - ;; According to ANSI defaults may be any valid pathname designator - (defaults (etypecase defaults - (pathname - defaults) - (string - (aver (pathnamep *default-pathname-defaults*)) - (parse-namestring defaults)) - (stream - (truename defaults))))) - (declare (type (or null host) found-host) - (type pathname defaults)) - (etypecase thing - (simple-string - (%parse-namestring thing found-host defaults start end junk-allowed)) - (string - (%parse-namestring (coerce thing 'simple-string) - found-host defaults start end junk-allowed)) - (pathname - (let ((defaulted-host (or found-host (%pathname-host defaults)))) - (declare (type host defaulted-host)) - (unless (eq defaulted-host (%pathname-host thing)) - (error "The HOST argument doesn't match the pathname host:~% ~ - ~S and ~S." - defaulted-host (%pathname-host thing)))) - (values thing start)) - (stream - (let ((name (file-name thing))) - (unless name - (error "can't figure out the file associated with stream:~% ~S" - thing)) - (values name nil)))))) + (aver (pathnamep *default-pathname-defaults*)) + (parse-namestring defaults)) + (stream + (truename defaults))))) + (declare (type pathname defaults)) + (etypecase thing + (simple-string + (%parse-namestring thing found-host defaults start end junk-allowed)) + (string + (%parse-namestring (coerce thing 'simple-string) + found-host defaults start end junk-allowed)) + (pathname + (let ((defaulted-host (or found-host (%pathname-host defaults)))) + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ + ~S and ~S." + defaulted-host (%pathname-host thing)))) + (values thing start)) + (stream + (let ((name (file-name thing))) + (unless name + (error "can't figure out the file associated with stream:~% ~S" + thing)) + (values name nil))))))) + +(defun %parse-native-namestring (namestr host defaults start end junk-allowed + as-directory) + (declare (type (or host null) host) + (type string namestr) + (type index start) + (type (or index null) end)) + (cond + (junk-allowed + (handler-case + (%parse-native-namestring namestr host defaults start end nil as-directory) + (namestring-parse-error (condition) + (values nil (namestring-parse-error-offset condition))))) + (t + (let* ((end (%check-vector-sequence-bounds namestr start end))) + (multiple-value-bind (new-host device directory file type version) + (cond + (host + (funcall (host-parse-native host) namestr start end as-directory)) + ((pathname-host defaults) + (funcall (host-parse-native (pathname-host defaults)) + namestr + start + end + as-directory)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) + (when (and host new-host (not (eq new-host host))) + (error 'simple-type-error + :datum new-host + :expected-type `(or null (eql ,host)) + :format-control + "The host in the namestring, ~S,~@ + does not match the explicit HOST argument, ~S." + :format-arguments (list new-host host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) + (values (%make-pathname + pn-host device directory file type version) + end))))))) + +(defun parse-native-namestring (thing + &optional + host + (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed + as-directory) + #!+sb-doc + "Convert THING into a pathname, using the native conventions +appropriate for the pathname host HOST, or if not specified the +host of DEFAULTS. If THING is a string, the parse is bounded by +START and END, and error behaviour is controlled by JUNK-ALLOWED, +as with PARSE-NAMESTRING. For file systems whose native +conventions allow directories to be indicated as files, if +AS-DIRECTORY is true, return a pathname denoting THING as a +directory." + (declare (type pathname-designator thing defaults) + (type (or list host string (member :unspecific)) host) + (type index start) + (type (or index null) end) + (type (or t null) junk-allowed) + (values (or null pathname) (or null index))) + (with-host (found-host host) + (let ((defaults (etypecase defaults + (pathname + defaults) + (string + (aver (pathnamep *default-pathname-defaults*)) + (parse-native-namestring defaults)) + (stream + (truename defaults))))) + (declare (type pathname defaults)) + (etypecase thing + (simple-string + (%parse-native-namestring + thing found-host defaults start end junk-allowed as-directory)) + (string + (%parse-native-namestring (coerce thing 'simple-string) + found-host defaults start end junk-allowed + as-directory)) + (pathname + (let ((defaulted-host (or found-host (%pathname-host defaults)))) + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ + ~S and ~S." + defaulted-host (%pathname-host thing)))) + (values thing start)) + (stream + ;; FIXME + (let ((name (file-name thing))) + (unless name + (error "can't figure out the file associated with stream:~% ~S" + thing)) + (values name nil))))))) (defun namestring (pathname) #!+sb-doc @@ -823,6 +934,23 @@ a host-structure or string." host:~% ~S" pathname)) (funcall (host-unparse host) pathname))))) +(defun native-namestring (pathname &key as-file) + #!+sb-doc + "Construct the full native (name)string form of PATHNAME. For +file systems whose native conventions allow directories to be +indicated as files, if AS-FILE is true and the name, type, and +version components of PATHNAME are all NIL or :UNSPECIFIC, +construct a string that names the directory according to the file +system's syntax for files." + (declare (type pathname-designator pathname)) + (with-native-pathname (pathname pathname) + (when pathname + (let ((host (%pathname-host pathname))) + (unless host + (error "can't determine the native namestring for pathnames with no ~ + host:~% ~S" pathname)) + (funcall (host-unparse-native host) pathname as-file))))) + (defun host-namestring (pathname) #!+sb-doc "Return a string representation of the name of the host in the pathname." @@ -863,7 +991,7 @@ a host-structure or string." &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) @@ -916,7 +1044,7 @@ a host-structure or string." (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (or (eq (%pathname-host wildname) *unix-host*) + (or (eq (%pathname-host wildname) *physical-host*) (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern @@ -1108,7 +1236,7 @@ a host-structure or string." (defun translate-pathname (source from-wildname to-wildname &key) #!+sb-doc "Use the source pathname to translate the from-wildname's wild and - unspecified elements into a completed to-pathname based on the to-wildname." +unspecified elements into a completed to-pathname based on the to-wildname." (declare (type pathname-designator source from-wildname to-wildname)) (with-pathname (source source) (with-pathname (from from-wildname) @@ -1134,9 +1262,10 @@ a host-structure or string." (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) - (if (eq from-host *unix-host*) - (if (eq (%pathname-version to) :wild) - (%pathname-version from) + (if (eq from-host *physical-host*) + (if (or (eq (%pathname-version to) :wild) + (eq (%pathname-version to) nil)) + (%pathname-version source) (%pathname-version to)) (frob %pathname-version))))))))) @@ -1148,6 +1277,12 @@ a host-structure or string." ;;;; utilities +(defun simplify-namestring (namestring &optional host) + (funcall (host-simplify-namestring + (or host + (pathname-host (sane-default-pathname-defaults)))) + namestring)) + ;;; Canonicalize a logical pathname word by uppercasing it checking that it ;;; contains only legal characters. (defun logical-word-or-lose (word) @@ -1168,7 +1303,7 @@ a host-structure or string." is not alphanumeric or hyphen:~% ~S" :args (list ch) :namestring word :offset i)))) - (coerce word 'base-string))) + (coerce word 'string))) ; why not simple-string? ;;; Given a logical host or string, return a logical host. If ERROR-P ;;; is NIL, then return NIL when no such host exists. @@ -1196,11 +1331,12 @@ a host-structure or string." ;;; a new one if necessary. (defun intern-logical-host (thing) (declare (values logical-host)) - (or (find-logical-host thing nil) - (let* ((name (logical-word-or-lose thing)) - (new (make-logical-host :name name))) - (setf (gethash name *logical-hosts*) new) - new))) + (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))) + (setf (gethash name *logical-hosts*) new) + new)))) ;;;; logical pathname parsing @@ -1354,6 +1490,14 @@ a host-structure or string." ;;; loaded yet. (defvar *logical-pathname-defaults*) +(defun logical-namestring-p (x) + (and (stringp x) + (ignore-errors + (typep (pathname x) 'logical-pathname)))) + +(deftype logical-namestring () + `(satisfies logical-namestring-p)) + (defun logical-pathname (pathspec) #!+sb-doc "Converts the pathspec argument to a logical-pathname and returns it." @@ -1361,12 +1505,19 @@ a host-structure or string." (values logical-pathname)) (if (typep pathspec 'logical-pathname) pathspec - (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*))) - (when (eq (%pathname-host res) - (%pathname-host *logical-pathname-defaults*)) - (error "This logical namestring does not specify a host:~% ~S" - pathspec)) - res))) + (flet ((oops (problem) + (error 'simple-type-error + :datum pathspec + :expected-type 'logical-namestring + :format-control "~S is not a valid logical namestring:~% ~A" + :format-arguments (list pathspec problem)))) + (let ((res (handler-case + (parse-namestring pathspec nil *logical-pathname-defaults*) + (error (e) (oops e))))) + (when (eq (%pathname-host res) + (%pathname-host *logical-pathname-defaults*)) + (oops "no host specified")) + res)))) ;;;; logical pathname unparsing @@ -1417,13 +1568,15 @@ a host-structure or string." (version-supplied (not (or (null version) (eq version :unspecific))))) (when name - (when (and (null type) (position #\. name :start 1)) + (when (and (null type) + (typep name 'string) + (position #\. name :start 1)) (error "too many dots in the name: ~S" pathname)) (strings (unparse-logical-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) - (when (typep type 'simple-string) + (when (typep type 'string) (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") @@ -1535,14 +1688,78 @@ a host-structure or string." (defun load-logical-pathname-translations (host) #!+sb-doc + "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST, +with HOST replaced by the supplied parameter. Returns T on success. + +If HOST is already defined as logical pathname host, no file is loaded and NIL +is returned. + +The file should contain a single form, suitable for use with +\(SETF LOGICAL-PATHNAME-TRANSLATIONS). + +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))) (if (find-logical-host host nil) ;; This host is already defined, all is well and good. nil ;; ANSI: "The specific nature of the search is - ;; implementation-defined." SBCL: doesn't search at all - ;; - ;; FIXME: now that we have a SYS host that the system uses, it - ;; might be cute to search in "SYS:TRANSLATIONS;.LISP" - (error "logical host ~S not found" host))) + ;; implementation-defined." + (prog1 t + (setf (logical-pathname-translations host) + (with-open-file (lpt (make-pathname :host "SYS" + :directory '(:absolute "SITE") + :name host + :type "TRANSLATIONS" + :version :newest)) + (read lpt)))))) + +(defun !pathname-cold-init () + (let* ((sys *default-pathname-defaults*) + (src + (merge-pathnames + (make-pathname :directory '(:relative "src" :wild-inferiors) + :name :wild :type :wild) + sys)) + (contrib + (merge-pathnames + (make-pathname :directory '(:relative "contrib" :wild-inferiors) + :name :wild :type :wild) + sys)) + (output + (merge-pathnames + (make-pathname :directory '(:relative "output" :wild-inferiors) + :name :wild :type :wild) + sys))) + (setf (logical-pathname-translations "SYS") + `(("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)))))