- (:make-load-form-fun make-unix-host-load-form)
- (:include host
- (parse #'parse-unix-namestring)
- (unparse #'unparse-unix-namestring)
- (unparse-host #'unparse-unix-host)
- (unparse-directory #'unparse-unix-directory)
- (unparse-file #'unparse-unix-file)
- (unparse-enough #'unparse-unix-enough)
- (customary-case :lower))))
+ (:make-load-form-fun make-unix-host-load-form)
+ (:include host
+ (parse #'parse-unix-namestring)
+ (unparse #'unparse-unix-namestring)
+ (unparse-host #'unparse-unix-host)
+ (unparse-directory #'unparse-unix-directory)
+ (unparse-file #'unparse-unix-file)
+ (unparse-enough #'unparse-unix-enough)
+ (customary-case :lower))))
- (if cur-sub
- (let* ((len (length chars))
- (new (make-string len))
- (index len))
- (dolist (char chars)
- (setf (schar new (decf index)) char))
- (cons new subs))
- subs))
- (matches (pieces start subs cur-sub chars)
- (if (null pieces)
- (if (= start len)
- (values t (maybe-prepend subs cur-sub chars))
- (values nil nil))
- (let ((piece (car pieces)))
- (etypecase piece
- (simple-string
- (let ((end (+ start (length piece))))
- (and (<= end len)
- (string= piece string
- :start2 start :end2 end)
- (matches (cdr pieces) end
- (maybe-prepend subs cur-sub chars)
- nil nil))))
- (list
- (ecase (car piece)
- (:character-set
- (and (< start len)
- (let ((char (schar string start)))
- (if (find char (cdr piece) :test #'char=)
- (matches (cdr pieces) (1+ start) subs t
- (cons char chars))))))))
- ((member :single-char-wild)
- (and (< start len)
- (matches (cdr pieces) (1+ start) subs t
- (cons (schar string start) chars))))
- ((member :multi-char-wild)
- (multiple-value-bind (won new-subs)
- (matches (cdr pieces) start subs t chars)
- (if won
- (values t new-subs)
- (and (< start len)
- (matches pieces (1+ start) subs t
- (cons (schar string start)
- chars)))))))))))
+ (if cur-sub
+ (let* ((len (length chars))
+ (new (make-string len))
+ (index len))
+ (dolist (char chars)
+ (setf (schar new (decf index)) char))
+ (cons new subs))
+ subs))
+ (matches (pieces start subs cur-sub chars)
+ (if (null pieces)
+ (if (= start len)
+ (values t (maybe-prepend subs cur-sub chars))
+ (values nil nil))
+ (let ((piece (car pieces)))
+ (etypecase piece
+ (simple-string
+ (let ((end (+ start (length piece))))
+ (and (<= end len)
+ (string= piece string
+ :start2 start :end2 end)
+ (matches (cdr pieces) end
+ (maybe-prepend subs cur-sub chars)
+ nil nil))))
+ (list
+ (ecase (car piece)
+ (:character-set
+ (and (< start len)
+ (let ((char (schar string start)))
+ (if (find char (cdr piece) :test #'char=)
+ (matches (cdr pieces) (1+ start) subs t
+ (cons char chars))))))))
+ ((member :single-char-wild)
+ (and (< start len)
+ (matches (cdr pieces) (1+ start) subs t
+ (cons (schar string start) chars))))
+ ((member :multi-char-wild)
+ (multiple-value-bind (won new-subs)
+ (matches (cdr pieces) start subs t chars)
+ (if won
+ (values t new-subs)
+ (and (< start len)
+ (matches pieces (1+ start) subs t
+ (cons (schar string start)
+ chars)))))))))))
- (let ((wild1 (first wild)))
- (if (eq wild1 :wild-inferiors)
- (let ((wild-subdirs (rest wild)))
- (or (null wild-subdirs)
- (loop
- (when (directory-components-match thing wild-subdirs)
- (return t))
- (pop thing)
- (unless thing (return nil)))))
- (and (consp thing)
- (components-match (first thing) wild1)
- (directory-components-match (rest thing)
- (rest wild))))))))
+ (let ((wild1 (first wild)))
+ (if (eq wild1 :wild-inferiors)
+ (let ((wild-subdirs (rest wild)))
+ (or (null wild-subdirs)
+ (loop
+ (when (directory-components-match thing wild-subdirs)
+ (return t))
+ (pop thing)
+ (unless thing (return nil)))))
+ (and (consp thing)
+ (components-match (first thing) wild1)
+ (directory-components-match (rest thing)
+ (rest wild))))))))
- (simple-string
- ;; String is matched by itself, a matching pattern or :WILD.
- (typecase wild
- (pattern
- (values (pattern-matches wild thing)))
- (simple-string
- (string= thing wild))))
- (pattern
- ;; A pattern is only matched by an identical pattern.
- (and (pattern-p wild) (pattern= thing wild)))
- (integer
- ;; An integer (version number) is matched by :WILD or the
- ;; same integer. This branch will actually always be NIL as
- ;; long as the version is a fixnum.
- (eql thing wild)))))
+ (simple-string
+ ;; String is matched by itself, a matching pattern or :WILD.
+ (typecase wild
+ (pattern
+ (values (pattern-matches wild thing)))
+ (simple-string
+ (string= thing wild))))
+ (pattern
+ ;; A pattern is only matched by an identical pattern.
+ (and (pattern-p wild) (pattern= thing wild)))
+ (integer
+ ;; An integer (version number) is matched by :WILD or the
+ ;; same integer. This branch will actually always be NIL as
+ ;; long as the version is a fixnum.
+ (eql thing wild)))))
- (typecase in
- (pattern
- (dolist (piece (pattern-pieces in))
- (when (typecase piece
- (simple-string
- (check-for pred piece))
- (cons
- (case (car piece)
- (:character-set
- (check-for pred (cdr piece))))))
- (return t))))
- (list
- (dolist (x in)
- (when (check-for pred x)
- (return t))))
- (simple-string
- (dotimes (i (length in))
- (when (funcall pred (schar in i))
- (return t))))
- (t nil)))
- (diddle-with (fun thing)
- (typecase thing
- (pattern
- (make-pattern
- (mapcar (lambda (piece)
- (typecase piece
- (simple-string
- (funcall fun piece))
- (cons
- (case (car piece)
- (:character-set
- (cons :character-set
- (funcall fun (cdr piece))))
- (t
- piece)))
- (t
- piece)))
- (pattern-pieces thing))))
- (list
- (mapcar fun thing))
- (simple-string
- (funcall fun thing))
- (t
- thing))))
- (let ((any-uppers (check-for #'upper-case-p thing))
- (any-lowers (check-for #'lower-case-p thing)))
- (cond ((and any-uppers any-lowers)
- ;; mixed case, stays the same
- thing)
- (any-uppers
- ;; all uppercase, becomes all lower case
- (diddle-with (lambda (x) (if (stringp x)
- (string-downcase x)
- x)) thing))
- (any-lowers
- ;; all lowercase, becomes all upper case
- (diddle-with (lambda (x) (if (stringp x)
- (string-upcase x)
- x)) thing))
- (t
- ;; no letters? I guess just leave it.
- thing))))
+ (typecase in
+ (pattern
+ (dolist (piece (pattern-pieces in))
+ (when (typecase piece
+ (simple-string
+ (check-for pred piece))
+ (cons
+ (case (car piece)
+ (:character-set
+ (check-for pred (cdr piece))))))
+ (return t))))
+ (list
+ (dolist (x in)
+ (when (check-for pred x)
+ (return t))))
+ (simple-string
+ (dotimes (i (length in))
+ (when (funcall pred (schar in i))
+ (return t))))
+ (t nil)))
+ (diddle-with (fun thing)
+ (typecase thing
+ (pattern
+ (make-pattern
+ (mapcar (lambda (piece)
+ (typecase piece
+ (simple-string
+ (funcall fun piece))
+ (cons
+ (case (car piece)
+ (:character-set
+ (cons :character-set
+ (funcall fun (cdr piece))))
+ (t
+ piece)))
+ (t
+ piece)))
+ (pattern-pieces thing))))
+ (list
+ (mapcar fun thing))
+ (simple-string
+ (funcall fun thing))
+ (t
+ thing))))
+ (let ((any-uppers (check-for #'upper-case-p thing))
+ (any-lowers (check-for #'lower-case-p thing)))
+ (cond ((and any-uppers any-lowers)
+ ;; mixed case, stays the same
+ thing)
+ (any-uppers
+ ;; all uppercase, becomes all lower case
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-downcase x)
+ x)) thing))
+ (any-lowers
+ ;; all lowercase, becomes all upper case
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-upcase x)
+ x)) thing))
+ (t
+ ;; no letters? I guess just leave it.
+ thing))))
- (pathname-host (%pathname-host pathname))
- (diddle-case
- (and default-host pathname-host
- (not (eq (host-customary-case default-host)
- (host-customary-case pathname-host))))))
- (%make-maybe-logical-pathname
- (or pathname-host default-host)
- (or (%pathname-device pathname)
- (maybe-diddle-case (%pathname-device defaults)
- diddle-case))
- (merge-directories (%pathname-directory pathname)
- (%pathname-directory defaults)
- diddle-case)
- (or (%pathname-name pathname)
- (maybe-diddle-case (%pathname-name defaults)
- diddle-case))
- (or (%pathname-type pathname)
- (maybe-diddle-case (%pathname-type defaults)
- diddle-case))
- (or (%pathname-version pathname)
- (and (not (%pathname-name pathname)) (%pathname-version defaults))
- default-version))))))
+ (pathname-host (%pathname-host pathname))
+ (diddle-case
+ (and default-host pathname-host
+ (not (eq (host-customary-case default-host)
+ (host-customary-case pathname-host))))))
+ (%make-maybe-logical-pathname
+ (or pathname-host default-host)
+ (or (%pathname-device pathname)
+ (maybe-diddle-case (%pathname-device defaults)
+ diddle-case))
+ (merge-directories (%pathname-directory pathname)
+ (%pathname-directory defaults)
+ diddle-case)
+ (or (%pathname-name pathname)
+ (maybe-diddle-case (%pathname-name defaults)
+ diddle-case))
+ (or (%pathname-type pathname)
+ (maybe-diddle-case (%pathname-type defaults)
+ diddle-case))
+ (or (%pathname-version pathname)
+ (and (not (%pathname-name pathname)) (%pathname-version defaults))
+ default-version))))))
- (with-pathname (defaults defaults) defaults)))
- (default-host (if defaults
- (%pathname-host defaults)
- (pathname-host *default-pathname-defaults*)))
- ;; 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.
- ;;
- ;; 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.
- ;; "valid pathname host n. a valid physical pathname host or
- ;; a valid logical pathname host."
- ;; and defines
- ;; "valid physical pathname host n. any of a string,
- ;; a list of strings, or the symbol :unspecific,
- ;; that is recognized by the implementation as the name of a host."
- ;; "valid logical pathname host n. a string that has been defined
- ;; as the name of a logical host. ..."
- ;; HS is silent on what happens if the :HOST arg is NOT one of these.
- ;; 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)
- (eq case :common)))
- (diddle-defaults
- (not (eq (host-customary-case host)
- (host-customary-case default-host))))
- (dev (if devp device (if defaults (%pathname-device defaults))))
- (dir (import-directory directory diddle-args))
- (ver (cond
- (versionp version)
- (defaults (%pathname-version defaults))
- (t nil))))
+ (with-pathname (defaults defaults) defaults)))
+ (default-host (if defaults
+ (%pathname-host defaults)
+ (pathname-host *default-pathname-defaults*)))
+ ;; 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.
+ ;;
+ ;; 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.
+ ;; "valid pathname host n. a valid physical pathname host or
+ ;; a valid logical pathname host."
+ ;; and defines
+ ;; "valid physical pathname host n. any of a string,
+ ;; a list of strings, or the symbol :unspecific,
+ ;; that is recognized by the implementation as the name of a host."
+ ;; "valid logical pathname host n. a string that has been defined
+ ;; as the name of a logical host. ..."
+ ;; HS is silent on what happens if the :HOST arg is NOT one of these.
+ ;; 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)
+ (eq case :common)))
+ (diddle-defaults
+ (not (eq (host-customary-case host)
+ (host-customary-case default-host))))
+ (dev (if devp device (if defaults (%pathname-device defaults))))
+ (dir (import-directory directory diddle-args))
+ (ver (cond
+ (versionp version)
+ (defaults (%pathname-version defaults))
+ (t nil))))
- (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)))))))
+ (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)))))))
- ;; 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,~@
+ ;; 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,~@
;; A valid physical pathname host is "any of a string, a list of
;; strings, or the symbol :UNSPECIFIC, that is recognized by the
;; implementation as the name of a host". In SBCL as of 0.6.9.8,
;; that means :UNSPECIFIC: though someday we might want to
;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
;; '("RTFM" "MIT" "EDU"), that's not supported now.
;; A valid physical pathname host is "any of a string, a list of
;; strings, or the symbol :UNSPECIFIC, that is recognized by the
;; implementation as the name of a host". In SBCL as of 0.6.9.8,
;; that means :UNSPECIFIC: though someday we might want to
;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
;; '("RTFM" "MIT" "EDU"), that's not supported now.
- ((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,
- ;; but ANSI leaves this up to the implementor,
- ;; and in SBCL we don't do it, so it must be a
- ;; logical host.
- (find-logical-host host))
- ((or null (member :unspecific))
- ;; CLHS says that HOST=:UNSPECIFIC has
- ;; implementation-defined behavior. We
- ;; just turn it into NIL.
- nil)
- (list
- ;; ANSI also allows LISTs to designate hosts,
- ;; but leaves its interpretation
- ;; implementation-defined. Our interpretation
- ;; is that it's unsupported.:-|
- (error "A LIST representing a pathname host is not ~
+ ((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,
+ ;; but ANSI leaves this up to the implementor,
+ ;; and in SBCL we don't do it, so it must be a
+ ;; logical host.
+ (find-logical-host host))
+ ((or null (member :unspecific))
+ ;; CLHS says that HOST=:UNSPECIFIC has
+ ;; implementation-defined behavior. We
+ ;; just turn it into NIL.
+ nil)
+ (list
+ ;; ANSI also allows LISTs to designate hosts,
+ ;; but leaves its interpretation
+ ;; implementation-defined. Our interpretation
+ ;; is that it's unsupported.:-|
+ (error "A LIST representing a pathname host is not ~
- ((nil)
- (or (wild-pathname-p pathname :host)
- (wild-pathname-p pathname :device)
- (wild-pathname-p pathname :directory)
- (wild-pathname-p pathname :name)
- (wild-pathname-p pathname :type)
- (wild-pathname-p pathname :version)))
- (:host (frob (%pathname-host pathname)))
- (:device (frob (%pathname-host pathname)))
- (:directory (some #'frob (%pathname-directory pathname)))
- (:name (frob (%pathname-name pathname)))
- (:type (frob (%pathname-type pathname)))
- (:version (frob (%pathname-version pathname)))))))
+ ((nil)
+ (or (wild-pathname-p pathname :host)
+ (wild-pathname-p pathname :device)
+ (wild-pathname-p pathname :directory)
+ (wild-pathname-p pathname :name)
+ (wild-pathname-p pathname :type)
+ (wild-pathname-p pathname :version)))
+ (:host (frob (%pathname-host pathname)))
+ (:device (frob (%pathname-host pathname)))
+ (:directory (some #'frob (%pathname-directory pathname)))
+ (:name (frob (%pathname-name pathname)))
+ (:type (frob (%pathname-type pathname)))
+ (:version (frob (%pathname-version pathname)))))))
- `(or (null (,field wildname))
- (,op (,field pathname) (,field wildname)))))
- (and (or (null (%pathname-host wildname))
- (eq (%pathname-host wildname) (%pathname-host pathname)))
- (frob %pathname-device)
- (frob %pathname-directory directory-components-match)
- (frob %pathname-name)
- (frob %pathname-type)
- (or (eq (%pathname-host wildname) *unix-host*)
- (frob %pathname-version)))))))
+ `(or (null (,field wildname))
+ (,op (,field pathname) (,field wildname)))))
+ (and (or (null (%pathname-host wildname))
+ (eq (%pathname-host wildname) (%pathname-host pathname)))
+ (frob %pathname-device)
+ (frob %pathname-directory directory-components-match)
+ (frob %pathname-name)
+ (frob %pathname-type)
+ (or (eq (%pathname-host wildname) *unix-host*)
+ (frob %pathname-version)))))))
- (unless source
- (unless (every (lambda (x) (eq x :wild-inferiors)) from)
- (didnt-match-error orig-source orig-from))
- (subs ())
- (return))
- (unless from (didnt-match-error orig-source orig-from))
- (let ((from-part (pop from))
- (source-part (pop source)))
- (typecase from-part
- (pattern
- (typecase source-part
- (pattern
- (if (pattern= from-part source-part)
- (subs source-part)
- (didnt-match-error orig-source orig-from)))
- (simple-string
- (multiple-value-bind (won new-subs)
- (pattern-matches from-part source-part)
- (if won
- (dolist (sub new-subs)
- (subs sub))
- (didnt-match-error orig-source orig-from))))
- (t
- (didnt-match-error orig-source orig-from))))
- ((member :wild)
- (subs source-part))
- ((member :wild-inferiors)
- (let ((remaining-source (cons source-part source)))
- (collect ((res))
- (loop
- (when (directory-components-match remaining-source from)
- (return))
- (unless remaining-source
- (didnt-match-error orig-source orig-from))
- (res (pop remaining-source)))
- (subs (res))
- (setq source remaining-source))))
- (simple-string
- (unless (and (simple-string-p source-part)
- (string= from-part source-part))
- (didnt-match-error orig-source orig-from)))
- (t
- (didnt-match-error orig-source orig-from)))))
+ (unless source
+ (unless (every (lambda (x) (eq x :wild-inferiors)) from)
+ (didnt-match-error orig-source orig-from))
+ (subs ())
+ (return))
+ (unless from (didnt-match-error orig-source orig-from))
+ (let ((from-part (pop from))
+ (source-part (pop source)))
+ (typecase from-part
+ (pattern
+ (typecase source-part
+ (pattern
+ (if (pattern= from-part source-part)
+ (subs source-part)
+ (didnt-match-error orig-source orig-from)))
+ (simple-string
+ (multiple-value-bind (won new-subs)
+ (pattern-matches from-part source-part)
+ (if won
+ (dolist (sub new-subs)
+ (subs sub))
+ (didnt-match-error orig-source orig-from))))
+ (t
+ (didnt-match-error orig-source orig-from))))
+ ((member :wild)
+ (subs source-part))
+ ((member :wild-inferiors)
+ (let ((remaining-source (cons source-part source)))
+ (collect ((res))
+ (loop
+ (when (directory-components-match remaining-source from)
+ (return))
+ (unless remaining-source
+ (didnt-match-error orig-source orig-from))
+ (res (pop remaining-source)))
+ (subs (res))
+ (setq source remaining-source))))
+ (simple-string
+ (unless (and (simple-string-p source-part)
+ (string= from-part source-part))
+ (didnt-match-error orig-source orig-from)))
+ (t
+ (didnt-match-error orig-source orig-from)))))
- (let* ((source-host (%pathname-host source))
- (from-host (%pathname-host from))
- (to-host (%pathname-host to))
- (diddle-case
- (and source-host to-host
- (not (eq (host-customary-case source-host)
- (host-customary-case to-host))))))
- (macrolet ((frob (field &optional (op 'translate-component))
- `(let ((result (,op (,field source)
- (,field from)
- (,field to)
- diddle-case)))
- (if (eq result :error)
- (error "~S doesn't match ~S." source from)
- result))))
- (%make-maybe-logical-pathname
- (or to-host source-host)
- (frob %pathname-device)
- (frob %pathname-directory translate-directories)
- (frob %pathname-name)
- (frob %pathname-type)
- (if (eq from-host *unix-host*)
- (if (eq (%pathname-version to) :wild)
- (%pathname-version from)
- (%pathname-version to))
- (frob %pathname-version)))))))))
+ (let* ((source-host (%pathname-host source))
+ (from-host (%pathname-host from))
+ (to-host (%pathname-host to))
+ (diddle-case
+ (and source-host to-host
+ (not (eq (host-customary-case source-host)
+ (host-customary-case to-host))))))
+ (macrolet ((frob (field &optional (op 'translate-component))
+ `(let ((result (,op (,field source)
+ (,field from)
+ (,field to)
+ diddle-case)))
+ (if (eq result :error)
+ (error "~S doesn't match ~S." source from)
+ result))))
+ (%make-maybe-logical-pathname
+ (or to-host source-host)
+ (frob %pathname-device)
+ (frob %pathname-directory translate-directories)
+ (frob %pathname-name)
+ (frob %pathname-type)
+ (if (eq from-host *unix-host*)
+ (if (eq (%pathname-version to) :wild)
+ (%pathname-version from)
+ (%pathname-version to))
+ (frob %pathname-version)))))))))
- found
- ;; This is the error signalled from e.g.
- ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
- ;; host, and ANSI specifies that that's a TYPE-ERROR.
- (error 'simple-type-error
- :datum thing
- ;; God only knows what ANSI expects us to use for
- ;; the EXPECTED-TYPE here. Maybe this will be OK..
- :expected-type
- '(and string (satisfies logical-pathname-translations))
- :format-control "logical host not yet defined: ~S"
- :format-arguments (list thing)))))
+ found
+ ;; This is the error signalled from e.g.
+ ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
+ ;; host, and ANSI specifies that that's a TYPE-ERROR.
+ (error 'simple-type-error
+ :datum thing
+ ;; God only knows what ANSI expects us to use for
+ ;; the EXPECTED-TYPE here. Maybe this will be OK..
+ :expected-type
+ '(and string (satisfies logical-pathname-translations))
+ :format-control "logical host not yet defined: ~S"
+ :format-arguments (list thing)))))
- (unless (and chunks (simple-string-p (caar chunks)))
- (error 'namestring-parse-error
- :complaint "expecting ~A, got ~:[nothing~;~S~]."
- :args (list what (caar chunks) (caar chunks))
- :namestring namestr
- :offset (if chunks (cdar chunks) end)))
- (caar chunks))
- (parse-host (chunks)
- (case (caadr chunks)
- (#\:
- (setq host
- (find-logical-host (expecting "a host name" chunks)))
- (parse-relative (cddr chunks)))
- (t
- (parse-relative chunks))))
- (parse-relative (chunks)
- (case (caar chunks)
- (#\;
- (directory :relative)
- (parse-directory (cdr chunks)))
- (t
- (directory :absolute) ; Assumption! Maybe revoked later.
- (parse-directory chunks))))
- (parse-directory (chunks)
- (case (caadr chunks)
- (#\;
- (directory
- (let ((res (expecting "a directory name" chunks)))
- (cond ((string= res "..") :up)
- ((string= res "**") :wild-inferiors)
- (t
- (maybe-make-logical-pattern namestr chunks)))))
- (parse-directory (cddr chunks)))
- (t
- (parse-name chunks))))
- (parse-name (chunks)
- (when chunks
- (expecting "a file name" chunks)
- (setq name (maybe-make-logical-pattern namestr chunks))
- (expecting-dot (cdr chunks))))
- (expecting-dot (chunks)
- (when chunks
- (unless (eql (caar chunks) #\.)
- (error 'namestring-parse-error
- :complaint "expecting a dot, got ~S."
- :args (list (caar chunks))
- :namestring namestr
- :offset (cdar chunks)))
- (if type
- (parse-version (cdr chunks))
- (parse-type (cdr chunks)))))
- (parse-type (chunks)
- (expecting "a file type" chunks)
- (setq type (maybe-make-logical-pattern namestr chunks))
- (expecting-dot (cdr chunks)))
- (parse-version (chunks)
- (let ((str (expecting "a positive integer, * or NEWEST"
- chunks)))
- (cond
- ((string= str "*") (setq version :wild))
- ((string= str "NEWEST") (setq version :newest))
- (t
- (multiple-value-bind (res pos)
- (parse-integer str :junk-allowed t)
- (unless (and res (plusp res))
- (error 'namestring-parse-error
- :complaint "expected a positive integer, ~
+ (unless (and chunks (simple-string-p (caar chunks)))
+ (error 'namestring-parse-error
+ :complaint "expecting ~A, got ~:[nothing~;~S~]."
+ :args (list what (caar chunks) (caar chunks))
+ :namestring namestr
+ :offset (if chunks (cdar chunks) end)))
+ (caar chunks))
+ (parse-host (chunks)
+ (case (caadr chunks)
+ (#\:
+ (setq host
+ (find-logical-host (expecting "a host name" chunks)))
+ (parse-relative (cddr chunks)))
+ (t
+ (parse-relative chunks))))
+ (parse-relative (chunks)
+ (case (caar chunks)
+ (#\;
+ (directory :relative)
+ (parse-directory (cdr chunks)))
+ (t
+ (directory :absolute) ; Assumption! Maybe revoked later.
+ (parse-directory chunks))))
+ (parse-directory (chunks)
+ (case (caadr chunks)
+ (#\;
+ (directory
+ (let ((res (expecting "a directory name" chunks)))
+ (cond ((string= res "..") :up)
+ ((string= res "**") :wild-inferiors)
+ (t
+ (maybe-make-logical-pattern namestr chunks)))))
+ (parse-directory (cddr chunks)))
+ (t
+ (parse-name chunks))))
+ (parse-name (chunks)
+ (when chunks
+ (expecting "a file name" chunks)
+ (setq name (maybe-make-logical-pattern namestr chunks))
+ (expecting-dot (cdr chunks))))
+ (expecting-dot (chunks)
+ (when chunks
+ (unless (eql (caar chunks) #\.)
+ (error 'namestring-parse-error
+ :complaint "expecting a dot, got ~S."
+ :args (list (caar chunks))
+ :namestring namestr
+ :offset (cdar chunks)))
+ (if type
+ (parse-version (cdr chunks))
+ (parse-type (cdr chunks)))))
+ (parse-type (chunks)
+ (expecting "a file type" chunks)
+ (setq type (maybe-make-logical-pattern namestr chunks))
+ (expecting-dot (cdr chunks)))
+ (parse-version (chunks)
+ (let ((str (expecting "a positive integer, * or NEWEST"
+ chunks)))
+ (cond
+ ((string= str "*") (setq version :wild))
+ ((string= str "NEWEST") (setq version :newest))
+ (t
+ (multiple-value-bind (res pos)
+ (parse-integer str :junk-allowed t)
+ (unless (and res (plusp res))
+ (error 'namestring-parse-error
+ :complaint "expected a positive integer, ~