Commit 4e214360 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert P. Goldman

Add the same kludge in DIRECTORY-FILES for GCL as for CLISP.

Fix DIRECTORY tests in test-utilities.script.
parent 18e851e4
...@@ -152,6 +152,7 @@ ...@@ -152,6 +152,7 @@
which suggests brokenness in handler-bind and/or error. which suggests brokenness in handler-bind and/or error.
*** `#5(1 ,@`(2 3)))` returns #(1 2 3), *** `#5(1 ,@`(2 3)))` returns #(1 2 3),
rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3).
*** (DIRECTORY #p"*.*") fails to match files with pathname type NIL.
** ABCL has a few bugs. ** ABCL has a few bugs.
*** ABCL fails the timestamp propagation test. *** ABCL fails the timestamp propagation test.
......
...@@ -206,22 +206,20 @@ ...@@ -206,22 +206,20 @@
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))) (assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))) (assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
;;; check to make sure DIRECTORY-FILES doesn't list subdirectories (DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories")
(let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/"))) (let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/")))
(directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/")))) (directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/"))))
(assert (every 'pathname-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x")))) (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x")))
(assert (every 'pathname-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2"))))) (assert-pathnames-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2"))))
;;; check to make sure SUBDIRECTORIES does list subdirectories (DBG "check to make sure SUBDIRECTORIES does list subdirectories")
(let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/"))) (let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/")))
(directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/")))) (directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/"))))
(assert (set-equality directory-a (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/b/")))
(list (subpathname *build-directory* "deleteme/a/b/")) (assert-pathnames-equal
:test 'pathname-equal)) (sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x)))))
(assert (set-equality directory-b (list (subpathname *build-directory* "deleteme/a/b/c/")
(list (subpathname *build-directory* "deleteme/a/b/c/") (subpathname *build-directory* "deleteme/a/b/d/")
(subpathname *build-directory* "deleteme/a/b/d/") (subpathname *build-directory* "deleteme/a/b/e/"))))
(subpathname *build-directory* "deleteme/a/b/e/"))
:test 'pathname-equal)))
(delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/")) (delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/"))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))) (assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))))
(delete-directory-tree (subpathname *build-directory* "deleteme/") (delete-directory-tree (subpathname *build-directory* "deleteme/")
......
...@@ -212,7 +212,7 @@ permits this." ...@@ -212,7 +212,7 @@ permits this."
(setf pattern (make-pathname-logical pattern (pathname-host dir)))) (setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let* ((pat (merge-pathnames* pattern dir)) (let* ((pat (merge-pathnames* pattern dir))
(entries (append (ignore-errors (directory* pat)) (entries (append (ignore-errors (directory* pat))
#+clisp #+(or clisp gcl)
(when (equal :wild (pathname-type pattern)) (when (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(remove-if 'directory-pathname-p (remove-if 'directory-pathname-p
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment