(let ((namestring (handler-case (namestring pathname)
(error nil))))
(if namestring
- (format stream "#.(logical-pathname ~S)" 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))))))
+ (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
;; but the arguments given in the X3J13 cleanup issue
;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
;; case, and uppercase is the ordinary way to do that.
- (flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x))))
+ (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
(if (typep host 'logical-host)
(%make-logical-pathname host
:unspecific
#!+sb-doc
"Makes a new pathname from the component arguments. Note that host is
a host-structure or string."
- (declare (type (or string host component-tokens) host)
- (type (or string component-tokens) device)
- (type (or list string pattern component-tokens) directory)
- (type (or string pattern component-tokens) name type)
- (type (or integer component-tokens (member :newest)) version)
+ (declare (type (or string host pathname-component-tokens) host)
+ (type (or string pathname-component-tokens) device)
+ (type (or list string pattern pathname-component-tokens) directory)
+ (type (or string pattern pathname-component-tokens) name type)
+ (type (or integer pathname-component-tokens (member :newest))
+ version)
(type (or pathname-designator null) defaults)
(type (member :common :local) case))
(let* ((defaults (when defaults
(defun pathname-host (pathname &key (case :local))
#!+sb-doc
- "Accessor for the pathname's host."
+ "Return PATHNAME's host."
(declare (type pathname-designator pathname)
(type (member :local :common) case)
(values host)
(defun pathname-device (pathname &key (case :local))
#!+sb-doc
- "Accessor for pathname's device."
+ "Return PATHNAME's device."
(declare (type pathname-designator pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(defun pathname-directory (pathname &key (case :local))
#!+sb-doc
- "Accessor for the pathname's directory list."
+ "Return PATHNAME's directory."
(declare (type pathname-designator pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
:lower)))))
(defun pathname-name (pathname &key (case :local))
#!+sb-doc
- "Accessor for the pathname's name."
+ "Return PATHNAME's name."
(declare (type pathname-designator pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(defun pathname-type (pathname &key (case :local))
#!+sb-doc
- "Accessor for the pathname's name."
+ "Return PATHNAME's type."
(declare (type pathname-designator pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(defun pathname-version (pathname)
#!+sb-doc
- "Accessor for the pathname's version."
+ "Return PATHNAME's version."
(declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(%pathname-version pathname)))
(defun substitute-into (pattern subs diddle-case)
(declare (type pattern pattern)
(type list subs)
- (values (or simple-base-string pattern)))
+ (values (or simple-base-string pattern) list))
(let ((in-wildcard nil)
(pieces nil)
(strings nil))
values)
(defun %enumerate-search-list (pathname function)
- (/show0 "entering %ENUMERATE-SEARCH-LIST")
- (let* ((pathname (if (typep pathname 'logical-pathname)
- (translate-logical-pathname pathname)
- pathname))
+ (let* ((pathname (physicalize-pathname pathname))
(search-list (extract-search-list pathname nil)))
- (/show0 "PATHNAME and SEARCH-LIST computed")
(cond
((not search-list)
- (/show0 "no search list")
(funcall function pathname))
((not (search-list-defined search-list))
- (/show0 "undefined search list")
(error "undefined search list: ~A"
(search-list-name search-list)))
(t
- (/show0 "general case")
(let ((tail (cddr (pathname-directory pathname))))
- (/show0 "TAIL computed")
(dolist (expansion
(search-list-expansions search-list))
- (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST")
(%enumerate-search-list (make-pathname :defaults pathname
:directory
(cons :absolute
;;;; utilities
-;;; Canonicalize a logical pathanme word by uppercasing it checking that it
+;;; Canonicalize a logical pathname word by uppercasing it checking that it
;;; contains only legal characters.
(defun logical-word-or-lose (word)
(declare (string word))
:namestring namestr
:offset (cdadr chunks)))))
(parse-host (logical-chunkify namestr start end)))
- (values host :unspecific
- (and (not (equal (directory)'(:absolute)))(directory))
- name type version))))
+ (values host :unspecific (directory) name type version))))
-;;; We can't initialize this yet because not all host methods are loaded yet.
+;;; We can't initialize this yet because not all host methods are
+;;; loaded yet.
(defvar *logical-pathname-defaults*)
(defun logical-pathname (pathspec)
;;; Unparse a logical pathname string.
(defun unparse-enough-namestring (pathname defaults)
- (let* ((path-dir (pathname-directory pathname))
- (def-dir (pathname-directory defaults))
- (enough-dir
+ (let* ((path-directory (pathname-directory pathname))
+ (def-directory (pathname-directory defaults))
+ (enough-directory
;; Go down the directory lists to see what matches. What's
;; left is what we want, more or less.
- (cond ((and (eq (first path-dir) (first def-dir))
- (eq (first path-dir) :absolute))
+ (cond ((and (eq (first path-directory) (first def-directory))
+ (eq (first path-directory) :absolute))
;; Both paths are :ABSOLUTE, so find where the
;; common parts end and return what's left
- (do* ((p (rest path-dir) (rest p))
- (d (rest def-dir) (rest d)))
+ (do* ((p (rest path-directory) (rest p))
+ (d (rest def-directory) (rest d)))
((or (endp p) (endp d)
(not (equal (first p) (first d))))
`(:relative ,@p))))
(t
;; At least one path is :RELATIVE, so just return the
;; original path. If the original path is :RELATIVE,
- ;; then that's the right one. If PATH-DIR is
+ ;; then that's the right one. If PATH-DIRECTORY is
;; :ABSOLUTE, we want to return that except when
- ;; DEF-DIR is :ABSOLUTE, as handled above. so return
+ ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
;; the original directory.
- path-dir))))
+ path-directory))))
(make-pathname :host (pathname-host pathname)
- :directory enough-dir
+ :directory enough-directory
:name (pathname-name pathname)
:type (pathname-type pathname)
:version (pathname-version pathname))))
(defun translate-logical-pathname (pathname &key)
#!+sb-doc
- "Translates pathname to a physical pathname, which is returned."
+ "Translate PATHNAME to a physical pathname, which is returned."
(declare (type pathname-designator pathname)
(values (or null pathname)))
(typecase pathname
projects / sbcl.git / blobdiff