Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv26192/src/code
220.127.116.11: two regressions from the 1.0.28. series
* from 18.104.22.168: when destructuring a constant :INITIAL-CONTENTS to
MAKE-ARRAY, take care to quote the elements.
* from 22.214.171.124: handle :BACK and :UP in CANONICALIZE-PATHNAME, and
make sure they do not appear after :WILD-INFERIORS or :ABSOLUTE.
I'm more and more concinved that MAKE-PATHNAME should canonicalize,
though, so that these checks don't need to be carried out by users
of pathnames -- but leaving that for later.
...how appropriate that it is .71 that fixes both.
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -d -r1.80 -r1.81
--- filesys.lisp 22 May 2009 06:16:20 -0000 1.80
+++ filesys.lisp 2 Jun 2009 15:03:03 -0000 1.81
@@ -606,15 +606,33 @@
- (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)
- (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)
+ (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))
+ (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 @@
:directory (butlast dir)
- (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