X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=ff023ee7cc604f7862979d41d70af838483964df;hb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;hp=226e4c42fc8df24144ca4b712a4dbe9a85a882bf;hpb=fec3614baf361523a4fb154ed80d9b73e1452b2d;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 226e4c4..ff023ee 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,7 +13,7 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;;; UNIX-HOST stuff +;;;; PHYSICAL-HOST stuff (def!struct (unix-host (:make-load-form-fun make-unix-host-load-form) @@ -23,18 +23,39 @@ (unparse #'unparse-unix-namestring) (unparse-native #'unparse-native-unix-namestring) (unparse-host #'unparse-unix-host) - (unparse-directory #'unparse-unix-directory) + (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*) -(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-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*) + +(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 @@ -90,7 +111,7 @@ ;;; 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 @@ -265,8 +286,8 @@ ;;; ;;; 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 @@ -275,7 +296,7 @@ (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 @@ -286,7 +307,7 @@ (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 @@ -342,6 +363,7 @@ ,hd0)) (host ,hd0)))) ,@body))) +) ; EVAL-WHEN (defun find-host (host-designator &optional (errorp t)) (with-host (host host-designator) @@ -440,7 +462,7 @@ the operating system native pathname conventions." (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)) @@ -493,25 +515,33 @@ 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))) + `(: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) @@ -824,7 +854,8 @@ a host-structure or string." 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) @@ -839,12 +870,14 @@ a host-structure or string." (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 @@ -868,13 +901,17 @@ a host-structure or string." &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) @@ -894,10 +931,11 @@ PARSE-NAMESTRING." (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)) @@ -926,9 +964,14 @@ PARSE-NAMESTRING." 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 @@ -936,7 +979,7 @@ PARSE-NAMESTRING." (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 @@ -1031,7 +1074,7 @@ PARSE-NAMESTRING." (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 @@ -1223,7 +1266,7 @@ PARSE-NAMESTRING." (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) @@ -1250,8 +1293,9 @@ PARSE-NAMESTRING." (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))))))))) @@ -1263,6 +1307,12 @@ PARSE-NAMESTRING." ;;;; 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) @@ -1283,7 +1333,7 @@ PARSE-NAMESTRING." 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. @@ -1311,11 +1361,12 @@ PARSE-NAMESTRING." ;;; 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 @@ -1469,6 +1520,14 @@ PARSE-NAMESTRING." ;;; 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." @@ -1476,12 +1535,19 @@ PARSE-NAMESTRING." (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 @@ -1532,13 +1598,15 @@ PARSE-NAMESTRING." (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 ".") @@ -1650,14 +1718,52 @@ PARSE-NAMESTRING." (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;.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)))))