X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=e7de62510fb291b91200682d85cf8d5d98a3a308;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=eaa6cb63b568e527fc3fb3256ad4eaae13943993;hpb=26148f0c8d7d35e1c5e1d363ade79552cbeb0386;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index eaa6cb6..e7de625 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -318,9 +318,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) @@ -625,7 +625,7 @@ a host-structure or string." (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 + ;; "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. @@ -649,66 +649,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)))) - (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,~@ + (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 host (pathname-host defaults)))) - (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. @@ -1471,15 +1476,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 @@ -1496,13 +1495,6 @@ a host-structure or string." (pathname pathname) (t (translate-logical-pathname (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)) - (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific