X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=81da10fb97a65298da31c5fe258a49fe53f31d51;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=bff90db738ecd89ca829e4333ab9b0ed88787145;hpb=5a7debb7fa6c532ffc4ff41f61352336d9a93697;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index bff90db..81da10f 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -27,6 +27,7 @@ (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) @@ -45,8 +46,9 @@ (unparse-file #'unparse-win32-file) (unparse-enough #'unparse-win32-enough) (unparse-directory-separator "\\") + (simplify-namestring #'simplify-win32-namestring) (customary-case :upper)))) -(defvar *win32-host* (make-win32-host)) +(defparameter *win32-host* (make-win32-host)) (defun make-win32-host-load-form (host) (declare (ignore host)) '*win32-host*) @@ -109,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 @@ -525,12 +527,10 @@ the operating system native pathname conventions." (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) @@ -843,7 +843,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) @@ -858,12 +859,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 @@ -887,13 +890,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) @@ -913,10 +920,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)) @@ -945,9 +953,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 @@ -955,7 +968,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 @@ -1269,8 +1282,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))))))))) @@ -1282,6 +1296,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) @@ -1302,7 +1322,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. @@ -1330,11 +1350,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-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)))) ;;;; logical pathname parsing @@ -1682,3 +1703,25 @@ PARSE-NAMESTRING." ;; 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))) + +(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)))))