From f3c8215dff31546bcdc260ce5d00b5ad671f7637 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Thu, 21 Oct 2010 13:42:36 -0700
Subject: [PATCH] 2.140: Make subdirectories actually work with ABCL, Allegro,
 CMUCL, CormanLisp, Scieneer Also, save defsystem-depends-on information for
 the sake of introspection by e.g. quicklisp. Some documentation
 clarifications.

---
 asdf.lisp                      | 55 +++++++++++++++++++++++-----------
 doc/asdf.texinfo               |  6 +++-
 test/test-configuration.script |  9 ++++++
 3 files changed, 51 insertions(+), 19 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index c319771c..51bb36f7 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -72,7 +72,7 @@
   (defvar *asdf-version* nil)
   (defvar *upgraded-p* nil)
   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:2.139" (1+ (length "VERSION"))))
+          (subseq "VERSION:2.140" (1+ (length "VERSION"))))
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -305,6 +305,7 @@
             #:split-string
             #:component-name-to-pathname-components
             #:split-name-type
+            #:subdirectories
             #:truenamize
             #:while-collecting)))
         (setf *asdf-version* asdf-version
@@ -695,11 +696,14 @@ ways that the filename components can be missing are for it to be NIL,
 
 Note that this does _not_ check to see that PATHNAME points to an
 actually-existing directory."
-  (flet ((check-one (x)
-           (member x '(nil :unspecific "") :test 'equal)))
-    (and (check-one (pathname-name pathname))
-         (check-one (pathname-type pathname))
-         t)))
+  (when pathname
+    (let ((pathname (pathname pathname)))
+      (flet ((check-one (x)
+               (member x '(nil :unspecific "") :test 'equal)))
+        (and (not (wild-pathname-p pathname))
+             (check-one (pathname-name pathname))
+             (check-one (pathname-type pathname))
+             t)))))
 
 (defun* ensure-directory-pathname (pathspec)
   "Converts the non-wild pathname designator PATHSPEC to directory form."
@@ -1069,7 +1073,8 @@ with given pathname and if it exists return its truename."
    (licence :accessor system-licence :initarg :licence
             :accessor system-license :initarg :license)
    (source-file :reader system-source-file :initarg :source-file
-                :writer %set-system-source-file)))
+                :writer %set-system-source-file)
+   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; version-satisfies
@@ -2156,7 +2161,7 @@ details."
   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
                             defsystem-depends-on &allow-other-keys)
       options
-    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
+    (let ((component-options (remove-keys '(:class) options)))
       `(progn
          ;; system must be registered before we parse the body, otherwise
          ;; we recur when trying to find an existing system of the same name
@@ -3247,17 +3252,31 @@ with a different configuration, so the configuration would be re-read then."
                     #+clisp #+clisp :circle t))
        t))
 
-(defparameter *wild-subdir*
-  (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
-
 (defun subdirectories (directory)
-  (ignore-errors
-    (directory (merge-pathnames* *wild-subdir* directory)
-               #+sbcl #+sbcl :resolve-symlinks nil
-               #+ccl #+ccl :follow-links nil
-               #+ccl #+ccl :directories t
-               #+ccl #+ccl :files nil
-               #+clisp #+clisp :circle t)))
+  (let* ((directory (ensure-directory-pathname directory))
+         #-cormanlisp
+         (wild (merge-pathnames*
+                #-(or abcl allegro scl)
+                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+                #+(or abcl allegro scl) "*.*"
+                directory))
+         (dirs
+          #-cormanlisp
+          (ignore-errors
+            (directory wild .
+              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+                    #+ccl '(:follow-links nil :directories t :files nil)
+                    #+clisp '(:circle t :if-does-not-exist :ignore)
+                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
+                    #+digitool '(:directories t)
+                    #+sbcl '(:resolve-symlinks nil))))
+          #+cormanlisp (cl::directory-subdirs directory))
+         #+(or abcl allegro scl)
+         (dirs (remove-if-not #+abcl #'extensions:probe-directory
+                              #+allegro #'excl:probe-directory
+                              #+scl #'directory-pathname-p
+                              dirs)))
+    dirs))
 
 (defun collect-subdirs (directory collectp recursep collector)
   (when (funcall collectp directory)
diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo
index 1dcf3ced..b054f075 100644
--- a/doc/asdf.texinfo
+++ b/doc/asdf.texinfo
@@ -1717,6 +1717,9 @@ to be found, for systems to be found the current directory
 (at the time that the configuration is initialized) as well as
 @code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
 @code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}.
+For instance, SBCL will include directories for its contribs
+when it can find them; it will look for them where SBCL was installed,
+or at the location specified by the @code{SBCL_HOME} environment variable.
 
 @end enumerate
 
@@ -1796,6 +1799,8 @@ DIRECTIVE :=
     (:exclude PATTERN ...) |
     ;; augment the defaults for exclusion patterns
     (:also-exclude PATTERN ...) |
+    ;; Note that the scope of a an exclude pattern specification is
+    ;; the rest of the current configuration expression or file.
 
     ;; splice the parsed contents of another config file
     (:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
@@ -1840,7 +1845,6 @@ once contained:
   :inherit-configuration)
 @end example
 
-
 @section Configuration Directories
 
 Configuration directories consist in files each contains
diff --git a/test/test-configuration.script b/test/test-configuration.script
index ae3364bc..96477fa5 100644
--- a/test/test-configuration.script
+++ b/test/test-configuration.script
@@ -46,6 +46,8 @@
 
 (cl-user::quit-on-error
 
+(format t "~&subdirectories of dir2/: ~S~%" (subdirectories (under-test-directory "dir2/")))
+(assert (= 2 (length (subdirectories (under-test-directory "dir2/")))))
 (assert
  (equal (parse-output-translations-string "/foo:/bar::/baz:/quux")
         '(:output-translations
@@ -74,6 +76,13 @@
  `(:source-registry (:include ,(under-test-directory "conf.d/"))
                     :ignore-inherited-configuration))
 
+(format t "~&Source Registry: ~S~%"
+        asdf::*source-registry*)
+(assert (find-system :foo0 nil))
+(assert (find-system :foo1 nil))
+(assert (find-system :foo2 nil))
+(assert (find-system :foo3 nil))
+
 (assert
  (equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
         (under-test-directory "dir2/bar/baz.lisp")))
-- 
GitLab