;;;
;;; 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)))
-(defmacro with-native-pathname ((pathname pathname-designator) &body body)
+(sb!xc:defmacro with-native-pathname ((pathname pathname-designator) &body body)
(let ((pd0 (gensym)))
`(let* ((,pd0 ,pathname-designator)
(,pathname (etypecase ,pd0
(file-stream (file-name ,pd0)))))
,@body)))
-(defmacro with-host ((host host-designator) &body 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
,hd0))
(host ,hd0))))
,@body)))
+) ; EVAL-WHEN
(defun find-host (host-designator &optional (errorp t))
(with-host (host host-designator)
(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)
;;; 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
(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)))))
projects / sbcl.git / blobdiff