X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpathname.lisp;h=bd0471faa40ecf30a95f1378b21fcab11d1f939c;hb=4255b37e50876702d2563f3418a44a3f5bf8a2e8;hp=efed3812c2116c024d3e764d3291b33e472e8701;hpb=6b8baeece6cf870e3f979a9f09c32985c64c04de;p=sbcl.git diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index efed381..bd0471f 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -126,3 +126,46 @@ 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))))