(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
- ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
+ ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(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
-;;; <path-designator>).
-;;;
-;;; 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))))))
\f
;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
(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.
(%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.
(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))
:expected-type 'null
:format-control
"The host in the namestring, ~S,~@
- does not match the explicit HOST argument, ~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
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)
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))
(let ((host (%pathname-host pathname)))
(unless host
(error "can't determine the namestring for pathnames with no ~
- host:~% ~S" pathname))
+ host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
(defun host-namestring (pathname)
(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,
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
- TO pattern:~% ~S"
+ TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(typecase sub
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
- ~% ~S"
+ ~% ~S"
sub)))))))
(when strings
;;; Called when we can't see how source and from matched.
(defun didnt-match-error (source from)
(error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
- did not match:~% ~S ~S"
+ 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
(let ((match (pop subs-left)))
(when (listp match)
(error ":WILD-INFERIORS is not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(res (maybe-diddle-case match diddle-case))))
((member :wild-inferiors)
(aver subs-left)
(let ((match (pop subs-left)))
(unless (listp match)
(error ":WILD-INFERIORS not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
(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
(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)))))))))
\f
;;;; logical pathname support. ANSI 92-102 specification.
;;;;
(unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
- is not alphanumeric or hyphen:~% ~S"
+ is not alphanumeric or hyphen:~% ~S"
:args (list ch)
:namestring word :offset i))))
word))
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
- word: ~S"
+ word: ~S"
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
- got ~S"
+ got ~S"
:args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(defun unparse-logical-piece (thing)
(etypecase thing
+ ((member :wild) "*")
(simple-string thing)
(pattern
(collect ((strings))
(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))
(concatenate 'simple-string
(logical-host-name (%pathname-host pathname)) ":"
(unparse-logical-directory pathname)
- (unparse-unix-file pathname)))
+ (unparse-logical-file pathname)))
\f
;;;; logical pathname translations
projects / sbcl.git / blobdiff