;;; pathname information into structure slot entries, and after
;;; translation the inverse (unparse) functions.
(def!struct (host (:constructor nil))
- (parse (required-argument) :type function)
- (unparse (required-argument) :type function)
- (unparse-host (required-argument) :type function)
- (unparse-directory (required-argument) :type function)
- (unparse-file (required-argument) :type function)
- (unparse-enough (required-argument) :type function)
- (customary-case (required-argument) :type (member :upper :lower)))
+ (parse (missing-arg) :type function)
+ (parse-native (missing-arg) :type function)
+ (unparse (missing-arg) :type function)
+ (unparse-native (missing-arg) :type function)
+ (unparse-host (missing-arg) :type function)
+ (unparse-directory (missing-arg) :type function)
+ (unparse-file (missing-arg) :type function)
+ (unparse-enough (missing-arg) :type function)
+ (unparse-directory-separator (missing-arg) :type simple-string)
+ (customary-case (missing-arg) :type (member :upper :lower)))
(def!method print-object ((host host) stream)
(print-unreadable-object (host stream :type t :identity t)))
(def!struct (logical-host
- (:make-load-form-fun make-logical-host-load-form-fun)
- (:include host
- (:parse #'parse-logical-namestring)
- (:unparse #'unparse-logical-namestring)
- (:unparse-host
- (lambda (x)
- (logical-host-name (%pathname-host x))))
- (:unparse-directory #'unparse-logical-directory)
- (:unparse-file #'unparse-unix-file)
- (:unparse-enough #'unparse-enough-namestring)
- (:customary-case :upper)))
- (name "" :type simple-base-string)
+ (:make-load-form-fun make-logical-host-load-form-fun)
+ (:include host
+ (parse #'parse-logical-namestring)
+ (parse-native
+ (lambda (&rest x)
+ (error "called PARSE-NATIVE-NAMESTRING using a ~
+ logical host: ~S" (first x))))
+ (unparse #'unparse-logical-namestring)
+ (unparse-native
+ (lambda (&rest x)
+ (error "called NATIVE-NAMESTRING using a ~
+ logical host: ~S" (first x))))
+ (unparse-host
+ (lambda (x)
+ (logical-host-name (%pathname-host x))))
+ (unparse-directory #'unparse-logical-directory)
+ (unparse-file #'unparse-logical-file)
+ (unparse-enough #'unparse-enough-namestring)
+ (unparse-directory-separator ";")
+ (customary-case :upper)))
+ (name "" :type simple-string)
(translations nil :type list)
(canon-transls nil :type list))
(print-unreadable-object (logical-host stream :type t)
(prin1 (logical-host-name logical-host) stream)))
-;;; What would it mean to dump a logical host and reload it into
-;;; another Lisp image? It's not clear, so we don't support it.
(defun make-logical-host-load-form-fun (logical-host)
- (error "~@<A logical host can't be dumped as a constant: ~2I~_~S~:>"
- logical-host))
+ (values `(find-logical-host ',(logical-host-name logical-host))
+ nil))
;;; A PATTERN is a list of entries and wildcards used for pattern
;;; matches of translations.
-(sb!xc:defstruct (pattern (:constructor make-pattern (pieces)))
+(def!struct (pattern (:constructor make-pattern (pieces)))
(pieces nil :type list))
\f
;;;; PATHNAME structures
;;; the various magic tokens that are allowed to appear in pretty much
;;; all pathname components
-(sb!xc:deftype pathname-component-tokens ()
- '(member nil :unspecific :wild))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ (def!type pathname-component-tokens ()
+ '(member nil :unspecific :wild :unc)))
(sb!xc:defstruct (pathname (:conc-name %pathname-)
- (:constructor %make-pathname (host
- device
- directory
- name
- type
- version))
- (:predicate pathnamep))
+ (:constructor %make-pathname (host
+ device
+ directory
+ name
+ type
+ version))
+ (:predicate pathnamep))
;; the host (at present either a UNIX or logical host)
(host nil :type (or host null))
;; the name of a logical or physical device holding files
;;; Logical pathnames have the following format:
;;;
;;; logical-namestring ::=
-;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
+;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
;;;
;;; host ::= word
;;; directory ::= word | wildcard-word | **
;;; Logical pathnames are a subclass of PATHNAME. Their class
;;; relations are mimicked using structures for efficiency.
(sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-)
- (:include pathname)
- (:constructor %make-logical-pathname
- (host
- device
- directory
- name
- type
- version))))
+ (:include pathname)
+ (:constructor %make-logical-pathname
+ (host
+ device
+ directory
+ name
+ type
+ version))))
+
+;;; This is used both for Unix and Windows: while we accept both
+;;; \ and / as directory separators on Windows, we print our
+;;; own always with /, which is much less confusing what with
+;;; being \ needing to be escaped.
+(defun unparse-physical-directory (pathname)
+ (declare (pathname pathname))
+ (unparse-physical-directory-list (%pathname-directory pathname)))
+
+(defun unparse-physical-directory-list (directory)
+ (declare (list directory))
+ (collect ((pieces))
+ (when directory
+ (ecase (pop directory)
+ (:absolute
+ (let ((next (pop directory)))
+ (cond ((eq :home next)
+ (pieces "~"))
+ ((and (consp next) (eq :home (car next)))
+ (pieces "~")
+ (pieces (second next)))
+ ((and (plusp (length next)) (char= #\~ (char next 0)))
+ ;; The only place we need to escape the tilde.
+ (pieces "\\")
+ (pieces next))
+ (next
+ (push next directory)))
+ (pieces "/")))
+ (:relative))
+ (dolist (dir directory)
+ (typecase dir
+ ((member :up)
+ (pieces "../"))
+ ((member :back)
+ (error ":BACK cannot be represented in namestrings."))
+ ((member :wild-inferiors)
+ (pieces "**/"))
+ ((or simple-string pattern (member :wild))
+ (pieces (unparse-physical-piece dir))
+ (pieces "/"))
+ (t
+ (error "invalid directory component: ~S" dir)))))
+ (apply #'concatenate 'simple-string (pieces))))
projects / sbcl.git / blobdiff