X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=aba52a6bdbf65533e594f978d68e232e1de0cde8;hb=16f861fd9d7c9246a22a212c26d97fb2e3712607;hp=ecb6cd20eb94a8185b80ae73076cc7cc41efda51;hpb=45ec97e8200790c0b60e1a567f7eaf0e99e75399;p=sbcl.git

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index ecb6cd2..aba52a6 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -606,15 +606,33 @@ matching filenames."
                   #'string<
                   :key #'car))))
 
- (defun canonicalize-pathname (pathname)
-   ;; We're really only interested in :UNSPECIFIC -> NIL,
-   ;; and dealing with #p"foo/.." and #p"foo/."
-   (flet ((simplify (piece)
-            (unless (eq :unspecific piece)
-              piece)))
-     (let ((name (simplify (pathname-name pathname)))
-           (type (simplify (pathname-type pathname)))
-           (dir (pathname-directory pathname)))
+(defun canonicalize-pathname (pathname)
+  ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP,
+  ;; and dealing with #p"foo/.." and #p"foo/."
+  (labels ((simplify (piece)
+             (unless (eq :unspecific piece)
+               piece))
+           (canonicalize-directory (directory)
+             (let (pieces)
+               (dolist (piece directory)
+                 (if (and pieces (member piece '(:back :up)))
+                     ;; FIXME: We should really canonicalize when we construct
+                     ;; pathnames. This is just wrong.
+                     (case (car pieces)
+                       ((:absolute :wild-inferiors)
+                        (error 'simple-file-error
+                               :format-control "Invalid use of ~S after ~S."
+                               :format-arguments (list piece (car pieces))
+                               :pathname pathname))
+                       ((:relative :up :back)
+                        (push piece pieces))
+                       (t
+                        (pop pieces)))
+                     (push piece pieces)))
+               (nreverse pieces))))
+    (let ((name (simplify (pathname-name pathname)))
+          (type (simplify (pathname-type pathname)))
+          (dir (canonicalize-directory (pathname-directory pathname))))
       (cond ((equal "." name)
              (cond ((not type)
                     (make-pathname :name nil :defaults pathname))
@@ -624,8 +642,9 @@ matching filenames."
                                    :directory (butlast dir)
                                    :defaults pathname))))
             (t
-             (make-pathname :name name :type type :defaults pathname))))))
-
+             (make-pathname :name name :type type
+                            :directory dir
+                            :defaults pathname))))))
 
 ;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style
 ;;; interface to mapping over namestrings of entries in the corresponding