#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;;; 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))
\f
;;; pathname methods
(let ((namestring (handler-case (namestring pathname)
(error nil))))
(if namestring
- (format stream "#P~S" (coerce namestring '(simple-array character (*))))
+ (format stream
+ (if (or *print-readably* *print-escape*)
+ "#P~S"
+ "~A")
+ (coerce namestring '(simple-array character (*))))
(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
(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))
\f
;;;; patterns
(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
(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.
(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))
((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)
;; 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
;; 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))
(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
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."
(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
(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)
(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)))))))))
\f
;;;; 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)
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.
;;; 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))))
\f
;;;; logical pathname parsing
;;; 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."
(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))))
\f
;;;; logical pathname unparsing
(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 ".")
(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 higly 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;<name>.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)))))
projects / sbcl.git / blobdiff