X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-pathname.lisp;h=86d1f21525f6c9faf92e53c807f60cee2fdacfd1;hb=beccf6c476f5cf2ef0bd839866527a46ec88d626;hp=817082572aa15bcbce14cd2e51444631d26982da;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 8170825..86d1f21 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -58,27 +58,6 @@ (def!method make-load-form ((pathname pathname) &optional environment) (make-load-form-saving-slots pathname :environment environment)) - -;;; The potential conflict with search lists requires isolating the -;;; printed representation to use the i/o macro #.(logical-pathname -;;; ). -;;; -;;; FIXME: We don't use search lists any more, so that comment is -;;; stale, right? -(def!method print-object ((pathname logical-pathname) stream) - (let ((namestring (handler-case (namestring pathname) - (error nil)))) - (if namestring - (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring) - (print-unreadable-object (pathname stream :type t) - (format - stream - "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S" - (%pathname-host pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type @@ -97,7 +76,9 @@ (upcase-maybe name) (upcase-maybe type) version) - (%make-pathname host device directory name type version)))) + (progn + (aver (eq host *unix-host*)) + (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. @@ -267,8 +248,9 @@ (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) (%pathname-type pathname2)) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2)))) + (or (eq (%pathname-host pathname1) *unix-host*) + (compare-component (%pathname-version pathname1) + (%pathname-version pathname2))))) ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or ;;; stream), into a pathname in pathname. @@ -282,7 +264,7 @@ (,pathname (etypecase ,pd0 (pathname ,pd0) (string (parse-namestring ,pd0)) - (stream (file-name ,pd0))))) + (file-stream (file-name ,pd0))))) ,@body))) ;;; Convert the var, a host or string name for a host, into a @@ -318,9 +300,9 @@ (simple-string (check-for pred piece)) (cons - (case (car in) + (case (car piece) (:character-set - (check-for pred (cdr in)))))) + (check-for pred (cdr piece)))))) (return t)))) (list (dolist (x in) @@ -383,7 +365,8 @@ (flet ((add (dir) (if (and (eq dir :back) results - (not (eq (car results) :back))) + (not (member (car results) + '(:back :wild-inferiors)))) (pop results) (push dir results)))) (dolist (dir (maybe-diddle-case dir2 diddle-case)) @@ -426,6 +409,7 @@ (maybe-diddle-case (%pathname-type defaults) diddle-case)) (or (%pathname-version pathname) + (and (not (%pathname-name pathname)) (%pathname-version defaults)) default-version)))))) (defun import-directory (directory diddle-case) @@ -479,11 +463,11 @@ a host-structure or string." (default-host (if defaults (%pathname-host defaults) (pathname-host *default-pathname-defaults*))) - ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a + ;; Raymond Toy writes: CLHS says make-pathname can take a ;; string (as a logical-host) for the host part. We map that ;; string into the corresponding logical host structure. ;; - ;; pw@snoopy.mv.com: + ;; Paul Werkowski writes: ;; HyperSpec says for the arg to MAKE-PATHNAME; ;; "host---a valid physical pathname host. ..." ;; where it probably means -- a valid pathname host. @@ -499,6 +483,7 @@ a host-structure or string." ;; 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 (diddle-args (and (eq (host-customary-case host) :lower) @@ -605,6 +590,41 @@ a host-structure or string." ;;;; namestrings +;;; Handle the case for PARSE-NAMESTRING parsing a potentially +;;; syntactically valid logical namestring with an explicit host. +;;; +;;; This then isn't fully general -- we are relying on the fact that +;;; we will only pass to parse-namestring namestring with an explicit +;;; logical host, so that we can pass the host return from +;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth +;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18 +(defun parseable-logical-namestring-p (namestr start end) + (catch 'exit + (handler-bind + ((namestring-parse-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (let ((colon (position #\: namestr :start start :end end))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts", we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) + ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host matches. @@ -613,40 +633,71 @@ a host-structure or string." (type string namestr) (type index start) (type (or index null) end)) - (if junk-allowed - (handler-case - (%parse-namestring namestr host defaults start end nil) - (namestring-parse-error (condition) - (values nil (namestring-parse-error-offset condition)))) - (let* ((end (or end (length namestr))) - (parse-host (or host - (extract-logical-host-prefix namestr start end) - (pathname-host defaults)))) - (unless parse-host - (error "When no HOST argument is supplied, the DEFAULTS argument ~ - must have a non-null PATHNAME-HOST.")) - - (multiple-value-bind (new-host device directory file type version) - (funcall (host-parse parse-host) namestr start end) - (when (and host new-host (not (eq new-host host))) - (error 'simple-type-error - :datum new-host - ;; Note: ANSI requires that this be a TYPE-ERROR, - ;; but there seems to be no completely correct - ;; value to use for TYPE-ERROR-EXPECTED-TYPE. - ;; Instead, we return a sort of "type error allowed - ;; type", trying to say "it would be OK if you - ;; passed NIL as the host value" but not mentioning - ;; that a matching string would be OK too. - :expected-type 'null - :format-control - "The host in the namestring, ~S,~@ + (cond + (junk-allowed + (handler-case + (%parse-namestring namestr host defaults start end nil) + (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) + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) + namestr + start + end)) + ;; 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 + ;; Note: ANSI requires that this be a TYPE-ERROR, + ;; but there seems to be no completely correct + ;; value to use for TYPE-ERROR-EXPECTED-TYPE. + ;; Instead, we return a sort of "type error allowed + ;; type", trying to say "it would be OK if you + ;; passed NIL as the host value" but not mentioning + ;; that a matching string would be OK too. + :expected-type 'null + :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 parse-host))) - (values (%make-maybe-logical-pathname - pn-host device directory file type version) - end)))))) + :format-arguments (list new-host host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) + (values (%make-maybe-logical-pathname + pn-host device directory file type version) + end))))))) ;;; If NAMESTR begins with a colon-terminated, defined, logical host, ;;; then return that host, otherwise return NIL. @@ -665,9 +716,8 @@ a host-structure or string." host (defaults *default-pathname-defaults*) &key (start 0) end junk-allowed) - (declare (type pathname-designator thing) + (declare (type pathname-designator thing defaults) (type (or list host string (member :unspecific)) host) - (type pathname defaults) (type index start) (type (or index null) end) (type (or t null) junk-allowed) @@ -697,6 +747,12 @@ a host-structure or string." ;; 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*) (string ;; In general ANSI-compliant Common Lisps, a ;; string might also be a physical pathname host, @@ -718,8 +774,18 @@ a host-structure or string." supported in this implementation:~% ~S" host)) (host - host)))) - (declare (type (or null host) found-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)) @@ -744,8 +810,7 @@ a host-structure or string." (defun namestring (pathname) #!+sb-doc "Construct the full (name)string form of the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (when pathname (let ((host (%pathname-host pathname))) @@ -757,8 +822,7 @@ a host-structure or string." (defun host-namestring (pathname) #!+sb-doc "Return a string representation of the name of the host in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -770,8 +834,7 @@ a host-structure or string." (defun directory-namestring (pathname) #!+sb-doc "Return a string representation of the directories used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -783,8 +846,7 @@ a host-structure or string." (defun file-namestring (pathname) #!+sb-doc "Return a string representation of the name used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -841,7 +903,7 @@ a host-structure or string." (declare (type pathname-designator in-pathname)) (with-pathname (pathname in-pathname) (with-pathname (wildname in-wildname) - (macrolet ((frob (field &optional (op 'components-match )) + (macrolet ((frob (field &optional (op 'components-match)) `(or (null (,field wildname)) (,op (,field pathname) (,field wildname))))) (and (or (null (%pathname-host wildname)) @@ -850,7 +912,8 @@ a host-structure or string." (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))) + (or (eq (%pathname-host wildname) *unix-host*) + (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well, @@ -909,7 +972,8 @@ a host-structure or string." did not match:~% ~S ~S" source from)) -;;; Do TRANSLATE-COMPONENT for all components except host and directory. +;;; Do TRANSLATE-COMPONENT for all components except host, directory +;;; and version. (defun translate-component (source from to diddle-case) (typecase to (pattern @@ -1046,6 +1110,7 @@ a host-structure or string." (with-pathname (from from-wildname) (with-pathname (to to-wildname) (let* ((source-host (%pathname-host source)) + (from-host (%pathname-host from)) (to-host (%pathname-host to)) (diddle-case (and source-host to-host @@ -1065,7 +1130,11 @@ a host-structure or string." (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))))) + (if (eq from-host *unix-host*) + (if (eq (%pathname-version to) :wild) + (%pathname-version from) + (%pathname-version to)) + (frob %pathname-version))))))))) ;;;; logical pathname support. ANSI 92-102 specification. ;;;; @@ -1079,6 +1148,12 @@ a host-structure or string." ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) + (when (string= word "") + (error 'namestring-parse-error + :complaint "Attempted to treat invalid logical hostname ~ + as a logical host:~% ~S" + :args (list word) + :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) @@ -1086,7 +1161,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "logical namestring character which ~ is not alphanumeric or hyphen:~% ~S" - :arguments (list ch) + :args (list ch) :namestring word :offset i)))) word)) @@ -1139,7 +1214,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "double asterisk inside of logical ~ word: ~S" - :arguments (list chunk) + :args (list chunk) :namestring namestring :offset (+ (cdar chunks) pos))) (pattern (subseq chunk last-pos pos))) @@ -1173,7 +1248,7 @@ a host-structure or string." (unless (member ch '(#\; #\: #\.)) (error 'namestring-parse-error :complaint "illegal character for logical pathname:~% ~S" - :arguments (list ch) + :args (list ch) :namestring namestr :offset i)) (chunks (cons ch i))))) @@ -1193,7 +1268,7 @@ a host-structure or string." (unless (and chunks (simple-string-p (caar chunks))) (error 'namestring-parse-error :complaint "expecting ~A, got ~:[nothing~;~S~]." - :arguments (list what (caar chunks) (caar chunks)) + :args (list what (caar chunks) (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) (caar chunks)) @@ -1235,7 +1310,7 @@ a host-structure or string." (unless (eql (caar chunks) #\.) (error 'namestring-parse-error :complaint "expecting a dot, got ~S." - :arguments (list (caar chunks)) + :args (list (caar chunks)) :namestring namestr :offset (cdar chunks))) (if type @@ -1258,7 +1333,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "expected a positive integer, ~ got ~S" - :arguments (list str) + :args (list str) :namestring namestr :offset (+ pos (cdar chunks)))) (setq version res))))) @@ -1312,6 +1387,7 @@ a host-structure or string." (defun unparse-logical-piece (thing) (etypecase thing + ((member :wild) "*") (simple-string thing) (pattern (collect ((strings)) @@ -1326,6 +1402,36 @@ a host-structure or string." (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) +(defun unparse-logical-file (pathname) + (declare (type pathname pathname)) + (collect ((strings)) + (let* ((name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (type-supplied (not (or (null type) (eq type :unspecific)))) + (version-supplied (not (or (null version) + (eq version :unspecific))))) + (when name + (when (and (null type) (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-base-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-logical-piece type))) + (when version-supplied + (unless type-supplied + (error "cannot specify the version without a type: ~S" pathname)) + (etypecase version + ((member :newest) (strings ".NEWEST")) + ((member :wild) (strings ".*")) + (fixnum (strings ".") (strings (format nil "~D" version)))))) + (apply #'concatenate 'simple-string (strings)))) + ;;; Unparse a logical pathname string. (defun unparse-enough-namestring (pathname defaults) (let* ((path-directory (pathname-directory pathname)) @@ -1350,18 +1456,19 @@ a host-structure or string." ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return ;; the original directory. path-directory)))) - (make-pathname :host (pathname-host pathname) - :directory enough-directory - :name (pathname-name pathname) - :type (pathname-type pathname) - :version (pathname-version pathname)))) + (unparse-logical-namestring + (make-pathname :host (pathname-host pathname) + :directory enough-directory + :name (pathname-name pathname) + :type (pathname-type pathname) + :version (pathname-version pathname))))) (defun unparse-logical-namestring (pathname) (declare (type logical-pathname pathname)) (concatenate 'simple-string (logical-host-name (%pathname-host pathname)) ":" (unparse-logical-directory pathname) - (unparse-unix-file pathname))) + (unparse-logical-file pathname))) ;;;; logical pathname translations @@ -1397,15 +1504,9 @@ a host-structure or string." (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -;;; KLUDGE: Ordinarily known functions aren't defined recursively, and -;;; it's common for compiler problems (e.g. missing/broken -;;; optimization transforms) to cause them to recurse inadvertently, -;;; so the compiler should warn about it. But the natural definition -;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want -;;; the warning, so we hide the definition of T-L-P in this -;;; differently named function so that the compiler won't warn about -;;; it. -- WHN 2001-09-16 -(defun %translate-logical-pathname (pathname) +(defun translate-logical-pathname (pathname &key) + #!+sb-doc + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname @@ -1420,15 +1521,7 @@ a host-structure or string." (return (translate-logical-pathname (translate-pathname pathname from to))))))) (pathname pathname) - (stream (translate-logical-pathname (pathname pathname))) - (t (translate-logical-pathname (logical-pathname pathname))))) - -(defun translate-logical-pathname (pathname &key) - #!+sb-doc - "Translate PATHNAME to a physical pathname, which is returned." - (declare (type pathname-designator pathname) - (values (or null pathname))) - (%translate-logical-pathname pathname)) + (t (translate-logical-pathname (pathname pathname))))) (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") @@ -1444,7 +1537,10 @@ a host-structure or string." (values (member t nil))) (if (find-logical-host host nil) ;; This host is already defined, all is well and good. - t + 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)))