#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;;; UNIX-HOST stuff
+;;;; PHYSICAL-HOST stuff
(def!struct (unix-host
(:make-load-form-fun make-unix-host-load-form)
(unparse-directory #'unparse-unix-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*)
-(defvar *physical-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-win32-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*)
+
+(defvar *physical-host*
+ #!-win32 *unix-host*
+ #!+win32 *win32-host*)
;;; Return a value suitable, e.g., for preinitializing
;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
;;; 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
;;;
;;; 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)
(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))
(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)
thing))
(values name nil)))))))
-(defun %parse-native-namestring (namestr host defaults start end junk-allowed)
+(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)
(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))
+ (host
+ (funcall (host-parse-native host) namestr start end as-directory))
((pathname-host defaults)
(funcall (host-parse-native (pathname-host defaults))
namestr
start
- end))
+ 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
&optional
host
(defaults *default-pathname-defaults*)
- &key (start 0) end junk-allowed)
+ &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."
+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)
(etypecase thing
(simple-string
(%parse-native-namestring
- thing found-host defaults start end junk-allowed))
+ 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))
+ found-host defaults start end junk-allowed
+ as-directory))
(pathname
(let ((defaulted-host (or found-host (%pathname-host defaults))))
(declare (type host defaulted-host))
host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
-(defun native-namestring (pathname)
+(defun native-namestring (pathname &key as-file)
#!+sb-doc
- "Construct the full native (name)string form of PATHNAME."
+ "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
(unless host
(error "can't determine the native namestring for pathnames with no ~
host:~% ~S" pathname))
- (funcall (host-unparse-native host) pathname)))))
+ (funcall (host-unparse-native host) pathname as-file)))))
(defun host-namestring (pathname)
#!+sb-doc
(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
(frob %pathname-name)
(frob %pathname-type)
(if (eq from-host *unix-host*)
- (if (eq (%pathname-version to) :wild)
- (%pathname-version from)
+ (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-hash-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
(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 ".")
;; 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)))
+
+(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)))))