X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=32a48ef84e080379d735d977da94f2ee0f5c5046;hb=c3699db2053ff3b5ac6a98d4431c3789496002d8;hp=2841bf5509df4310d1fd8274dbc23a7e4e25bba7;hpb=69cd16d7335a7f66985752b84f78d18e45f9783e;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 2841bf5..32a48ef 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -54,7 +54,7 @@ checked for whatever they may have protected." (declare (type simple-base-string namestr) (type index start end)) - (let* ((result (make-string (- end start))) + (let* ((result (make-string (- end start) :element-type 'base-char)) (dst 0) (quoted nil)) (do ((src start (1+ src))) @@ -521,9 +521,9 @@ (let ((piece (car tail))) (etypecase piece (simple-string - (let ((head (concatenate 'string head piece))) + (let ((head (concatenate 'base-string head piece))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head "/") + (%enumerate-directories (concatenate 'base-string head "/") (cdr tail) pathname verify-existence follow-links nodes function)))) @@ -532,7 +532,7 @@ verify-existence follow-links nodes function) (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'string head name))) + (let ((subdir (concatenate 'base-string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -543,14 +543,14 @@ (eql (cdr dir) ino)) (return t))) (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir "/"))) + (subdir (concatenate 'base-string subdir "/"))) (%enumerate-directories subdir tail pathname verify-existence follow-links nodes function)))))))) ((or pattern (member :wild)) (dolist (name (directory-lispy-filenames head)) (when (or (eq piece :wild) (pattern-matches piece name)) - (let ((subdir (concatenate 'string head name))) + (let ((subdir (concatenate 'base-string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -558,15 +558,15 @@ (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)) (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir "/"))) + (subdir (concatenate 'base-string subdir "/"))) (%enumerate-directories subdir (rest tail) pathname verify-existence follow-links nodes function)))))))) ((member :up) (with-directory-node-removed (head) - (let ((head (concatenate 'string head ".."))) + (let ((head (concatenate 'base-string head ".."))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head "/") + (%enumerate-directories (concatenate 'base-string head "/") (rest tail) pathname verify-existence follow-links nodes function))))))) @@ -608,19 +608,19 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'string + (concatenate 'base-string directory complete-filename)))))) (t (/noshow0 "default case") - (let ((file (concatenate 'string directory name))) + (let ((file (concatenate 'base-string directory name))) (/noshow "computed basic FILE") (unless (or (null type) (eq type :unspecific)) (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") - (setf file (concatenate 'string file "." type))) - (unless (member version '(nil :newest :wild)) + (setf file (concatenate 'base-string file "." type))) + (unless (member version '(nil :newest :wild :unspecific)) (/noshow0 "tweaking FILE for more-or-less-:WILD case") - (setf file (concatenate 'string file "." + (setf file (concatenate 'base-string file "." (quick-integer-to-string version)))) (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) @@ -638,11 +638,11 @@ ((zerop n) "0") ((eql n 1) "1") ((minusp n) - (concatenate 'simple-string "-" - (the simple-string (quick-integer-to-string (- n))))) + (concatenate 'simple-base-string "-" + (the simple-base-string (quick-integer-to-string (- n))))) (t (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len)) + (res (make-string len :element-type 'base-char)) (i (1- len) (1- i)) (q n) (r 0)) @@ -713,7 +713,6 @@ :format-arguments (list (namestring pathname)))) result)) -;;; If PATHNAME exists, return its truename, otherwise NIL. (defun probe-file (pathname) #!+sb-doc "Return a pathname which is the truename of the file if it exists, or NIL @@ -725,8 +724,11 @@ (when (and namestring (sb!unix:unix-file-kind namestring t)) (let ((trueishname (sb!unix:unix-resolve-links namestring))) (when trueishname - (let ((*ignore-wildcards* t)) - (pathname (sb!unix:unix-simplify-pathname trueishname)))))))) + (let* ((*ignore-wildcards* t) + (name (sb!unix:unix-simplify-pathname trueishname))) + (if (eq (sb!unix:unix-file-kind name) :directory) + (pathname (concatenate 'string name "/")) + (pathname name)))))))) ;;;; miscellaneous other operations @@ -824,16 +826,19 @@ ;; (which can arise when e.g. multiple symlinks map to the ;; same truename). (truenames (make-hash-table :test #'equal)) - (merged-pathname (merge-pathnames pathname - *default-pathname-defaults*))) + (merged-pathname (merge-pathnames pathname))) (!enumerate-matches (match merged-pathname) (let* ((*ignore-wildcards* t) - (truename (truename (if (eq (sb!unix:unix-file-kind match) - :directory) - (concatenate 'string match "/") - match)))) - (setf (gethash (namestring truename) truenames) - truename))) + ;; FIXME: Why not TRUENAME? As reported by Milan Zamazal + ;; sbcl-devel 2003-10-05, using TRUENAME causes a race + ;; condition whereby removal of a file during the + ;; directory operation causes an error. It's not clear + ;; what the right thing to do is, though. -- CSR, + ;; 2003-10-13 + (truename (probe-file match))) + (when truename + (setf (gethash (namestring truename) truenames) + truename)))) (mapcar #'cdr ;; Sorting isn't required by the ANSI spec, but sorting ;; into some canonical order seems good just on the