#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;; host methods
-
-(def!method print-object ((host host) stream)
- (print-unreadable-object (host stream :type t :identity t)))
+;;;; UNIX-HOST stuff
+
+(def!struct (unix-host
+ (: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))))
+
+(defvar *unix-host* (make-unix-host))
+
+(defun make-unix-host-load-form (host)
+ (declare (ignore host))
+ '*unix-host*)
+
+;;; Return a value suitable, e.g., for preinitializing
+;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
+;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
+(defun make-trivial-default-pathname ()
+ (%make-pathname *unix-host* nil nil nil nil :newest))
\f
;;; pathname methods
(let ((pieces1 (pattern-pieces pattern1))
(pieces2 (pattern-pieces pattern2)))
(and (= (length pieces1) (length pieces2))
- (every #'(lambda (piece1 piece2)
- (typecase piece1
- (simple-string
- (and (simple-string-p piece2)
- (string= piece1 piece2)))
- (cons
- (and (consp piece2)
- (eq (car piece1) (car piece2))
- (string= (cdr piece1) (cdr piece2))))
- (t
- (eq piece1 piece2))))
+ (every (lambda (piece1 piece2)
+ (typecase piece1
+ (simple-string
+ (and (simple-string-p piece2)
+ (string= piece1 piece2)))
+ (cons
+ (and (consp piece2)
+ (eq (car piece1) (car piece2))
+ (string= (cdr piece1) (cdr piece2))))
+ (t
+ (eq piece1 piece2))))
pieces1
pieces2))))
-;;; If the string matches the pattern returns the multiple values T and a
-;;; list of the matched strings.
+;;; If the string matches the pattern returns the multiple values T
+;;; and a list of the matched strings.
(defun pattern-matches (pattern string)
(declare (type pattern pattern)
(type simple-string string))
(typecase thing
(pattern
(make-pattern
- (mapcar #'(lambda (piece)
- (typecase piece
- (simple-base-string
- (funcall fun piece))
- (cons
- (case (car piece)
- (:character-set
- (cons :character-set
- (funcall fun (cdr piece))))
- (t
- piece)))
- (t
- piece)))
+ (mapcar (lambda (piece)
+ (typecase piece
+ (simple-base-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))
(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.
+ ;; 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))
+ ;; 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))
+ ;; 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.
+ ;; no letters? I guess just leave it.
thing))))
thing))
(defun host-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the name of the host in the pathname."
+ "Return a string representation of the name of the host in the pathname."
(declare (type pathname-designator pathname)
(values (or null simple-base-string)))
(with-pathname (pathname pathname)
(defun directory-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the directories used in the pathname."
+ "Return a string representation of the directories used in the pathname."
(declare (type pathname-designator pathname)
(values (or null simple-base-string)))
(with-pathname (pathname pathname)
(defun file-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the name used in the pathname."
+ "Return a string representation of the name used in the pathname."
(declare (type pathname-designator pathname)
(values (or null simple-base-string)))
(with-pathname (pathname pathname)
&optional
(defaults *default-pathname-defaults*))
#!+sb-doc
- "Returns an abbreviated pathname sufficent to identify the pathname relative
+ "Return an abbreviated pathname sufficent to identify the pathname relative
to the defaults."
(declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(collect ((subs))
(loop
(unless source
- (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
+ (unless (every (lambda (x) (eq x :wild-inferiors)) from)
(didnt-match-error orig-source orig-from))
(subs ())
(return))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
is not alphanumeric or hyphen:~% ~S"
- :arguments (list ch)
+ :args (list ch)
:namestring word :offset i))))
word))
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
word: ~S"
- :arguments (list chunk)
+ :args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(pattern (subseq chunk last-pos pos)))
(unless (member ch '(#\; #\: #\.))
(error 'namestring-parse-error
:complaint "illegal character for logical pathname:~% ~S"
- :arguments (list ch)
+ :args (list ch)
:namestring namestr
:offset i))
(chunks (cons ch i)))))
(unless (and chunks (simple-string-p (caar chunks)))
(error 'namestring-parse-error
:complaint "expecting ~A, got ~:[nothing~;~S~]."
- :arguments (list what (caar chunks) (caar chunks))
+ :args (list what (caar chunks) (caar chunks))
:namestring namestr
:offset (if chunks (cdar chunks) end)))
(caar chunks))
(unless (eql (caar chunks) #\.)
(error 'namestring-parse-error
:complaint "expecting a dot, got ~S."
- :arguments (list (caar chunks))
+ :args (list (caar chunks))
:namestring namestr
:offset (cdar chunks)))
(if type
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
got ~S"
- :arguments (list str)
+ :args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(setq version res)))))
projects / sbcl.git / blobdiff