X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=86d1f21525f6c9faf92e53c807f60cee2fdacfd1;hb=bfe145acc01eb7a43790173db4f08610ae9cb07a;hp=c76ee42ca10a91c55ea8ffe998b45499c4ffda95;hpb=ecad36c71e99fa4155b80af8bed38d02b9bdb83d;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index c76ee42..86d1f21 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -58,27 +58,6 @@ (def!method make-load-form ((pathname pathname) &optional environment) (make-load-form-saving-slots pathname :environment environment)) - -;;; The potential conflict with search lists requires isolating the -;;; printed representation to use the i/o macro #.(logical-pathname -;;; ). -;;; -;;; FIXME: We don't use search lists any more, so that comment is -;;; stale, right? -(def!method print-object ((pathname logical-pathname) stream) - (let ((namestring (handler-case (namestring pathname) - (error nil)))) - (if 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)))))) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type @@ -97,7 +76,9 @@ (upcase-maybe name) (upcase-maybe type) version) - (%make-pathname host device directory name type version)))) + (progn + (aver (eq host *unix-host*)) + (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. @@ -267,8 +248,9 @@ (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) (%pathname-type pathname2)) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2)))) + (or (eq (%pathname-host pathname1) *unix-host*) + (compare-component (%pathname-version pathname1) + (%pathname-version pathname2))))) ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or ;;; stream), into a pathname in pathname. @@ -383,7 +365,8 @@ (flet ((add (dir) (if (and (eq dir :back) results - (not (eq (car results) :back))) + (not (member (car results) + '(:back :wild-inferiors)))) (pop results) (push dir results)))) (dolist (dir (maybe-diddle-case dir2 diddle-case)) @@ -426,6 +409,7 @@ (maybe-diddle-case (%pathname-type defaults) diddle-case)) (or (%pathname-version pathname) + (and (not (%pathname-name pathname)) (%pathname-version defaults)) default-version)))))) (defun import-directory (directory diddle-case) @@ -732,9 +716,8 @@ a host-structure or string." host (defaults *default-pathname-defaults*) &key (start 0) end junk-allowed) - (declare (type pathname-designator thing) + (declare (type pathname-designator thing defaults) (type (or list host string (member :unspecific)) host) - (type pathname defaults) (type index start) (type (or index null) end) (type (or t null) junk-allowed) @@ -791,8 +774,18 @@ a host-structure or string." supported in this implementation:~% ~S" host)) (host - host)))) - (declare (type (or null host) found-host)) + host))) + ;; According to ANSI defaults may be any valid pathname designator + (defaults (etypecase defaults + (pathname + defaults) + (string + (aver (pathnamep *default-pathname-defaults*)) + (parse-namestring defaults)) + (stream + (truename defaults))))) + (declare (type (or null host) found-host) + (type pathname defaults)) (etypecase thing (simple-string (%parse-namestring thing found-host defaults start end junk-allowed)) @@ -919,7 +912,8 @@ a host-structure or string." (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))) + (or (eq (%pathname-host wildname) *unix-host*) + (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well, @@ -978,7 +972,8 @@ a host-structure or string." did not match:~% ~S ~S" source from)) -;;; Do TRANSLATE-COMPONENT for all components except host and directory. +;;; Do TRANSLATE-COMPONENT for all components except host, directory +;;; and version. (defun translate-component (source from to diddle-case) (typecase to (pattern @@ -1115,6 +1110,7 @@ a host-structure or string." (with-pathname (from from-wildname) (with-pathname (to to-wildname) (let* ((source-host (%pathname-host source)) + (from-host (%pathname-host from)) (to-host (%pathname-host to)) (diddle-case (and source-host to-host @@ -1134,7 +1130,11 @@ a host-structure or string." (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))))) + (if (eq from-host *unix-host*) + (if (eq (%pathname-version to) :wild) + (%pathname-version from) + (%pathname-version to)) + (frob %pathname-version))))))))) ;;;; logical pathname support. ANSI 92-102 specification. ;;;; @@ -1387,6 +1387,7 @@ a host-structure or string." (defun unparse-logical-piece (thing) (etypecase thing + ((member :wild) "*") (simple-string thing) (pattern (collect ((strings)) @@ -1401,6 +1402,36 @@ a host-structure or string." (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) +(defun unparse-logical-file (pathname) + (declare (type pathname pathname)) + (collect ((strings)) + (let* ((name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (type-supplied (not (or (null type) (eq type :unspecific)))) + (version-supplied (not (or (null version) + (eq version :unspecific))))) + (when name + (when (and (null type) (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (strings (unparse-logical-piece name))) + (when type-supplied + (unless name + (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'simple-base-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-logical-piece type))) + (when version-supplied + (unless type-supplied + (error "cannot specify the version without a type: ~S" pathname)) + (etypecase version + ((member :newest) (strings ".NEWEST")) + ((member :wild) (strings ".*")) + (fixnum (strings ".") (strings (format nil "~D" version)))))) + (apply #'concatenate 'simple-string (strings)))) + ;;; Unparse a logical pathname string. (defun unparse-enough-namestring (pathname defaults) (let* ((path-directory (pathname-directory pathname)) @@ -1437,7 +1468,7 @@ a host-structure or string." (concatenate 'simple-string (logical-host-name (%pathname-host pathname)) ":" (unparse-logical-directory pathname) - (unparse-unix-file pathname))) + (unparse-logical-file pathname))) ;;;; logical pathname translations @@ -1506,7 +1537,10 @@ a host-structure or string." (values (member t nil))) (if (find-logical-host host nil) ;; This host is already defined, all is well and good. - t + nil ;; ANSI: "The specific nature of the search is ;; implementation-defined." SBCL: doesn't search at all + ;; + ;; FIXME: now that we have a SYS host that the system uses, it + ;; might be cute to search in "SYS:TRANSLATIONS;.LISP" (error "logical host ~S not found" host)))