1 ;;;; the known-to-the-cross-compiler part of PATHNAME logic
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;;; data types used by pathnames
16 ;;; The HOST structure holds the functions that both parse the
17 ;;; pathname information into structure slot entries, and after
18 ;;; translation the inverse (unparse) functions.
19 (sb!xc
:defstruct
(host (:constructor nil
)
22 (print-unreadable-object
23 (host stream
:type t
:identity t
)))))
24 (parse (missing-arg) :type function
)
25 (parse-native (missing-arg) :type function
)
26 (unparse (missing-arg) :type function
)
27 (unparse-native (missing-arg) :type function
)
28 (unparse-host (missing-arg) :type function
)
29 (unparse-directory (missing-arg) :type function
)
30 (unparse-file (missing-arg) :type function
)
31 (unparse-enough (missing-arg) :type function
)
32 (unparse-directory-separator (missing-arg) :type simple-string
)
33 (simplify-namestring (missing-arg) :type function
)
34 (customary-case (missing-arg) :type
(member :upper
:lower
)))
39 (lambda (logical-host stream
)
40 (print-unreadable-object (logical-host stream
:type t
)
41 (prin1 (logical-host-name logical-host
) stream
))))
43 (parse #'parse-logical-namestring
)
46 (error "called PARSE-NATIVE-NAMESTRING using a ~
47 logical host: ~S" (first x
))))
48 (unparse #'unparse-logical-namestring
)
51 (error "called NATIVE-NAMESTRING using a ~
52 logical host: ~S" (first x
))))
55 (logical-host-name (%pathname-host x
))))
56 (unparse-directory #'unparse-logical-directory
)
57 (unparse-file #'unparse-logical-file
)
58 (unparse-enough #'unparse-enough-namestring
)
59 (unparse-directory-separator ";")
60 (simplify-namestring #'identity
)
61 (customary-case :upper
)))
62 (name "" :type simple-string
)
63 (translations nil
:type list
)
64 (canon-transls nil
:type list
))
67 (defmethod make-load-form ((logical-host logical-host
) &optional env
)
68 (declare (ignore env
))
69 (values `(find-logical-host ',(logical-host-name logical-host
))
72 ;;; A PATTERN is a list of entries and wildcards used for pattern
73 ;;; matches of translations.
74 (def!struct
(pattern (:constructor make-pattern
(pieces)))
75 (pieces nil
:type list
))
77 ;;;; PATHNAME structures
79 ;;; the various magic tokens that are allowed to appear in pretty much
80 ;;; all pathname components
81 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
82 (def!type pathname-component-tokens
()
83 '(member nil
:unspecific
:wild
:unc
)))
85 (sb!xc
:defstruct
(pathname (:conc-name %pathname-
)
86 (:constructor %make-pathname
(host
92 (:predicate pathnamep
))
93 ;; the host (at present either a UNIX or logical host)
94 (host nil
:type
(or host null
))
95 ;; the name of a logical or physical device holding files
96 (device nil
:type
(or simple-string pathname-component-tokens
))
97 ;; a list of strings that are the component subdirectory components
98 (directory nil
:type list
)
100 (name nil
:type
(or simple-string pattern pathname-component-tokens
))
101 ;; the type extension of the file
102 (type nil
:type
(or simple-string pattern pathname-component-tokens
))
103 ;; the version number of the file, a positive integer (not supported
104 ;; on standard Unix filesystems)
105 (version nil
:type
(or integer pathname-component-tokens
(member :newest
))))
107 ;;; Logical pathnames have the following format:
109 ;;; logical-namestring ::=
110 ;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
113 ;;; directory ::= word | wildcard-word | **
114 ;;; name ::= word | wildcard-word
115 ;;; type ::= word | wildcard-word
116 ;;; version ::= pos-int | newest | NEWEST | *
117 ;;; word ::= {uppercase-letter | digit | -}+
118 ;;; wildcard-word ::= [word] '* {word '*}* [word]
119 ;;; pos-int ::= integer > 0
121 ;;; Physical pathnames include all these slots and a device slot.
123 ;;; Logical pathnames are a subclass of PATHNAME. Their class
124 ;;; relations are mimicked using structures for efficiency.
125 (sb!xc
:defstruct
(logical-pathname (:conc-name %logical-pathname-
)
127 (:constructor %make-logical-pathname
135 ;;; This is used both for Unix and Windows: while we accept both
136 ;;; \ and / as directory separators on Windows, we print our
137 ;;; own always with /, which is much less confusing what with
138 ;;; being \ needing to be escaped.
139 #-sb-xc-host
; %PATHNAME-DIRECTORY is target-only
140 (defun unparse-physical-directory (pathname escape-char
)
141 (declare (pathname pathname
))
142 (unparse-physical-directory-list (%pathname-directory pathname
) escape-char
))
145 (defun unparse-physical-directory-list (directory escape-char
)
146 (declare (list directory
))
149 (ecase (pop directory
)
151 (let ((next (pop directory
)))
152 (cond ((eq :home next
)
154 ((and (consp next
) (eq :home
(car next
)))
156 (pieces (second next
)))
157 ((and (plusp (length next
)) (char= #\~
(char next
0)))
158 ;; The only place we need to escape the tilde.
162 (push next directory
)))
165 (dolist (dir directory
)
170 (error ":BACK cannot be represented in namestrings."))
171 ((member :wild-inferiors
)
173 ((or simple-string pattern
(member :wild
))
174 (pieces (unparse-physical-piece dir escape-char
))
177 (error "invalid directory component: ~S" dir
)))))
178 (apply #'concatenate
'simple-string
(pieces))))