X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=bf64660f4ef24120f2e5b0ca26f7eefc57795c6b;hb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;hp=f1dfb0eb0de5d59c3b3c86fe2ba4d7c87f52ea42;hpb=7ef5ec93744c7cc1c7a0280e46f8b42b74353713;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f1dfb0e..bf64660 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,10 +13,30 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;; 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)) ;;; pathname methods @@ -100,22 +120,22 @@ (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)) @@ -315,19 +335,19 @@ (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)) @@ -338,20 +358,20 @@ (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)) @@ -736,7 +756,7 @@ a host-structure or string." (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) @@ -749,7 +769,7 @@ a host-structure or string." (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) @@ -762,7 +782,7 @@ a host-structure or string." (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) @@ -777,7 +797,7 @@ a host-structure or string." &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) @@ -930,7 +950,7 @@ a host-structure or string." (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)) @@ -1050,7 +1070,7 @@ a host-structure or string." ;;;; logical pathname support. ANSI 92-102 specification. ;;;; ;;;; As logical-pathname translations are loaded they are -;;;; canonicalized as patterns to enable rapid efficent translation +;;;; canonicalized as patterns to enable rapid efficient translation ;;;; into physical pathnames. ;;;; utilities @@ -1066,7 +1086,7 @@ a host-structure or string." (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)) @@ -1119,7 +1139,7 @@ a host-structure or string." (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))) @@ -1153,7 +1173,7 @@ a host-structure or string." (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))))) @@ -1173,7 +1193,7 @@ a host-structure or string." (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)) @@ -1215,7 +1235,7 @@ a host-structure or string." (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 @@ -1238,7 +1258,7 @@ a host-structure or string." (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))))) @@ -1368,8 +1388,7 @@ a host-structure or string." (defun (setf logical-pathname-translations) (translations host) #!+sb-doc - "Set the translations list for the logical host argument. - Return translations." + "Set the translations list for the logical host argument." (declare (type (or string logical-host) host) (type list translations) (values list)) @@ -1378,9 +1397,15 @@ a host-structure or string." (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -(defun translate-logical-pathname (pathname &key) - #!+sb-doc - "Translate PATHNAME to a physical pathname, which is returned." +;;; KLUDGE: Ordinarily known functions aren't defined recursively, and +;;; it's common for compiler problems (e.g. missing/broken +;;; optimization transforms) to cause them to recurse inadvertently, +;;; so the compiler should warn about it. But the natural definition +;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want +;;; the warning, so we hide the definition of T-L-P in this +;;; differently named function so that the compiler won't warn about +;;; it. -- WHN 2001-09-16 +(defun %translate-logical-pathname (pathname) (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname @@ -1398,6 +1423,13 @@ a host-structure or string." (stream (translate-logical-pathname (pathname pathname))) (t (translate-logical-pathname (logical-pathname pathname))))) +(defun translate-logical-pathname (pathname &key) + #!+sb-doc + "Translate PATHNAME to a physical pathname, which is returned." + (declare (type pathname-designator pathname) + (values (or null pathname))) + (%translate-logical-pathname pathname)) + (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific