From a83f8cf03ee9b0cdf48abef443acc1af9b0dc2c3 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Thu, 19 Jun 2008 21:28:52 +0000 Subject: [PATCH] Make DIRECTORY work faster when there are a large number of files. Basically, don't use delete-duplicates but do it ourselves since the list is already sorted. From Lynn Quam, cmucl-imp, 2008/06/05, slightly modified. code/filesys.lisp: o New DIRECTORY function general-info/release-19f.txt: o Update --- code/filesys.lisp | 62 +++++++++++++++++++++--------------- general-info/release-19f.txt | 2 ++ 2 files changed, 38 insertions(+), 26 deletions(-) diff --git a/code/filesys.lisp b/code/filesys.lisp index dadb0ee55..ce2bc3f37 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.105 2008/06/18 15:57:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.106 2008/06/19 21:28:51 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1068,7 +1068,7 @@ optionally keeping some of the most recent old versions." ;;; DIRECTORY -- public. ;;; (defun directory (pathname &key (all t) (check-for-subdirs t) - (truenamep t) (follow-links t)) + (truenamep t) (follow-links t)) "Returns a list of pathnames, one for each file that matches the given pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL, @@ -1077,30 +1077,40 @@ optionally keeping some of the most recent old versions." defined to be the TRUENAME of the pathname (the truename of a link may well be in another directory). If FOLLOW-LINKS is NIL then symbolic links are not followed." - (let ((results nil)) - (enumerate-search-list - (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild - :defaults *default-pathname-defaults*) - :wild)) - (enumerate-matches (name pathname nil :follow-links follow-links) - (when (or all - (let ((slash (position #\/ name :from-end t))) - (or (null slash) - (= (1+ slash) (length name)) - (char/= (schar name (1+ slash)) #\.)))) - (push name results)))) - (let ((*ignore-wildcards* t)) - (mapcar #'(lambda (name) - (let ((name (if (and check-for-subdirs - (eq (unix:unix-file-kind name) - :directory)) - (concatenate 'string name "/") - name))) - (if truenamep (truename name) (pathname name)))) - (sort (delete-duplicates results :test #'string=) #'string<))))) + (flet ((ordered-strings-remove-duplicates (list) + (let ((results '()) + (prev nil)) + (dolist (elem list) + (when (or (null prev) + (not (string= elem prev))) + (push elem results)) + (setf prev elem)) + (nreverse results)))) + (let ((results nil)) + (enumerate-search-list + (pathname (merge-pathnames pathname + (make-pathname :name :wild + :type :wild + :version :wild + :defaults *default-pathname-defaults*) + :wild)) + (enumerate-matches (name pathname nil :follow-links follow-links) + (when (or all + (let ((slash (position #\/ name :from-end t))) + (or (null slash) + (= (1+ slash) (length name)) + (char/= (schar name (1+ slash)) #\.)))) + (push name results)))) + (let ((*ignore-wildcards* t)) + (mapcar #'(lambda (name) + (let ((name (if (and check-for-subdirs + (eq (unix:unix-file-kind name) + :directory)) + (concatenate 'string name "/") + name))) + (if truenamep (truename name) (pathname name)))) + (ordered-strings-remove-duplicates (sort results #'string<))))))) + ;;;; Printing directories. diff --git a/general-info/release-19f.txt b/general-info/release-19f.txt index ebbbab5bf..3709b1c77 100644 --- a/general-info/release-19f.txt +++ b/general-info/release-19f.txt @@ -59,6 +59,8 @@ New in this release: instead of a floating-point zero of the correct type. - Fix some issues in creating the debug arglist string when the arglist contains items that can't be printed readably. + - DIRECTORY is now faster for directories with a large number of + files. * Trac Tickets: - #16: Read-time hash-table issue -- GitLab