Changeset 13768

Timestamp:

Jun 1, 2010, 12:12:11 PM (14 years ago)

Author:

R. Matthew Emerson

Message:

Import ASDF 2.000 release from upstream.

File:

• trunk/source/tools/asdf.lisp (modified) (50 diffs)

trunk/source/tools/asdf.lisp

@@ -50 +50 @@
 (cl:in-package :cl-user)
 
+#|(declaim (optimize (speed 2) (debug 2) (safety 3))
+#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
+
 #+ecl (require :cmp)
 
@@ -68 +71 @@
   (let* ((asdf-version
           ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:1.719" (1+ (length "VERSION"))))
+          (subseq "VERSION:2.000" (1+ (length "VERSION"))))
          (existing-asdf (find-package :asdf))
          (vername '#:*asdf-version*)
@@ -78 +81 @@
       #-gcl
       (when existing-asdf
-        (format *error-output*
+        (format *trace-output*
                 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
                 existing-version asdf-version))
@@ -325 +328 @@
            ((m module) added deleted plist &key)
          (declare (ignorable deleted plist))
+         (format *trace-output* "Updating ~A~%" m)
          (when (member 'components-by-name added)
            (compute-module-components-by-name m))))))
@@ -334 +338 @@
   "Exported interface to the version of ASDF currently installed. A string.
 You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
   *asdf-version*)
 
@@ -453 +457 @@
 (defgeneric traverse (operation component)
   (:documentation
-"Generate and return a plan for performing `operation` on `component`.
-
-The plan returned is a list of dotted-pairs. Each pair is the `cons`
-of ASDF operation object and a `component` object. The pairs will be
-processed in order by `operate`."))
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
 
 
@@ -477 +481 @@
   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
 and NIL NAME, TYPE and VERSION components"
-  (make-pathname :name nil :type nil :version nil :defaults pathname))
-
-(defun current-directory ()
-  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+  (when pathname
+    (make-pathname :name nil :type nil :version nil :defaults pathname)))
 
 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
@@ -491 +493 @@
          (defaults (pathname defaults))
          (directory (pathname-directory specified))
-         (directory (if (stringp directory) `(:absolute ,directory) directory))
+         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
@@ -514 +516 @@
              (values (pathname-host defaults)
                      (pathname-device defaults)
-                     (append (pathname-directory defaults) (cdr directory))
+                     (if (pathname-directory defaults)
+                         (append (pathname-directory defaults) (cdr directory))
+                         directory)
                      (unspecific-handler defaults)))
             #+gcl
@@ -534 +538 @@
   or "or a flag")
 
+(defun first-char (s)
+  (and (stringp s) (plusp (length s)) (char s 0)))
+
+(defun last-char (s)
+  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
 (defun asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
@@ -539 +549 @@
 
 (defun split-string (string &key max (separator '(#\Space #\Tab)))
-  "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
-return a list.
+  "Split STRING into a list of components separated by
+any of the characters in the sequence SEPARATOR.
 If MAX is specified, then no more than max(1,MAX) components will be returned,
 starting the separation from the end, e.g. when called with arguments
@@ -591 +601 @@
     (multiple-value-bind (relative components)
         (if (equal (first components) "")
-            (if (and (plusp (length s)) (eql (char s 0) #\/))
+            (if (equal (first-char s) #\/)
                 (values :absolute (cdr components))
                 (values :relative nil))
@@ -614 +624 @@
     :append (list k v)))
 
-(defun resolve-symlinks (path)
-  #-allegro (truenamize path)
-  #+allegro (excl:pathname-resolve-symbolic-links path))
-
 (defun getenv (x)
   #+abcl
@@ -624 +630 @@
   (sb-ext:posix-getenv x)
   #+clozure
-  (ccl::getenv x)
+  (ccl:getenv x)
   #+clisp
   (ext:getenv x)
@@ -639 +645 @@
 
 (defun directory-pathname-p (pathname)
-  "Does `pathname` represent a directory?
+  "Does PATHNAME represent a directory?
 
 A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be `nil`,
-`:unspecific` or the empty string.
-
-Note that this does _not_ check to see that `pathname` points to an
+ways that the filename components can be missing are for it to be NIL,
+:UNSPECIFIC or the empty string.
+
+Note that this does _not_ check to see that PATHNAME points to an
 actually-existing directory."
   (flet ((check-one (x)
@@ -729 +735 @@
       (when (typep p 'logical-pathname) (return p))
       (ignore-errors (return (truename p)))
-      (when (stringp directory)
-         (return p))
-      (when (not (eq :absolute (car directory)))
-        (return p))
+      #-sbcl (when (stringp directory) (return p))
+      (when (not (eq :absolute (car directory))) (return p))
       (let ((sofar (ignore-errors (truename (pathname-root p)))))
         (unless sofar (return p))
@@ -756 +760 @@
             (return (solution nil))))))))
 
+(defun resolve-symlinks (path)
+  #-allegro (truenamize path)
+  #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun default-directory ()
+  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+
 (defun lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
+
+(defparameter *wild-path*
+  (make-pathname :directory '(:relative :wild-inferiors)
+                 :name :wild :type :wild :version :wild))
+
+(defun wilden (path)
+  (merge-pathnames* *wild-path* path))
+
+(defun directorize-pathname-host-device (pathname)
+  (let* ((root (pathname-root pathname))
+         (wild-root (wilden root))
+         (absolute-pathname (merge-pathnames* pathname root))
+         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
+         (separator (last-char (namestring foo)))
+         (root-namestring (namestring root))
+         (root-string
+          (substitute-if #\/
+                         (lambda (x) (or (eql x #\:)
+                                         (eql x separator)))
+                         root-namestring)))
+    (multiple-value-bind (relative path filename)
+        (component-name-to-pathname-components root-string t)
+      (declare (ignore relative filename))
+      (let ((new-base
+             (make-pathname :defaults root
+                            :directory `(:absolute ,@path))))
+        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -770 +808 @@
   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
   #+cmu (:report print-object))
+
+(declaim (ftype (function (t) t)
+                format-arguments format-control
+                error-name error-pathname error-condition
+                duplicate-names-name
+                error-component error-operation
+                module-components module-components-by-name)
+         (ftype (function (t t) t) (setf module-components-by-name)))
+
 
 (define-condition formatted-system-definition-error (system-definition-error)
@@ -890 +937 @@
 
 (defun compute-module-components-by-name (module)
-  (let ((hash (module-components-by-name module)))
-    (clrhash hash)
+  (let ((hash (make-hash-table :test 'equal)))
+    (setf (module-components-by-name module) hash)
     (loop :for c :in (module-components module)
       :for name = (component-name c)
@@ -907 +954 @@
     :accessor module-components)
    (components-by-name
-    :initform (make-hash-table :test 'equal)
     :accessor module-components-by-name)
    ;; What to do if we can't satisfy a dependency of one of this module's
@@ -935 +981 @@
              (merge-pathnames*
              (component-relative-pathname component)
-             (component-parent-pathname component))))
+             (pathname-directory-pathname (component-parent-pathname component)))))
         (unless (or (null pathname) (absolute-pathname-p pathname))
           (error "Invalid relative pathname ~S for component ~S" pathname component))
@@ -1009 +1055 @@
 
 (defun map-systems (fn)
-  "Apply `fn` to each defined system.
-
-`fn` should be a function of one argument. It will be
+  "Apply FN to each defined system.
+
+FN should be a function of one argument. It will be
 called with an object of type asdf:system."
   (maphash (lambda (_ datum)
@@ -1024 +1070 @@
 
 (defparameter *system-definition-search-functions*
-  '(sysdef-central-registry-search sysdef-source-registry-search))
+  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
+
+(defun sysdef-find-asdf (system)
+  (let ((name (coerce-name system)))
+    (when (equal name "asdf")
+      (eval
+       `(defsystem :asdf
+          :pathname ,(or *compile-file-truename* *load-truename*)
+          :depends-on () :components ())))))
 
 (defun system-definition-pathname (system)
@@ -1049 +1103 @@
 Going forward, we recommend new users should be using the source-registry.
 ")
+
+(defun probe-asd (name defaults)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (let ((file
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name name
+              :type "asd")))
+        (when (probe-file file)
+          (return file)))
+      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+      (let ((shortcut
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name (concatenate 'string name ".asd")
+              :type "lnk")))
+        (when (probe-file shortcut)
+          (let ((target (parse-windows-shortcut shortcut)))
+            (when target
+              (return (pathname target)))))))))
 
 (defun sysdef-central-registry-search (system)
@@ -1068 +1143 @@
                                    (message
                                     (format nil
-                                            "~@<While searching for system `~a`: `~a` evaluated ~
-to `~a` which is not a directory.~@:>"
+                                            "~@<While searching for system ~S: ~S evaluated ~
+to ~S which is not a directory.~@:>"
                                             system dir defaults)))
                               (error message))
@@ -1167 +1242 @@
 
 (defmethod find-component ((module module) (name string))
-  (when (slot-boundp module 'components-by-name)
-    (values (gethash name (module-components-by-name module)))))
+  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
+    (compute-module-components-by-name module))
+  (values (gethash name (module-components-by-name module))))
 
 (defmethod find-component ((component component) (name symbol))
@@ -1598 +1674 @@
       flag))
 
-(defmethod traverse ((operation operation) (c component))
-  ;; cerror'ing a feature that seems to have NEVER EVER worked
-  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
-  ;; It was both fixed and disabled in the 1.700 rewrite.
-  (when (consp (operation-forced operation))
-    (cerror "Continue nonetheless."
-            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
-    (setf (operation-forced operation)
-          (mapcar #'coerce-name (operation-forced operation))))
-  (flatten-tree
-   (while-collecting (collect)
-     (do-traverse operation c #'collect))))
-
 (defun flatten-tree (l)
   ;; You collected things into a list.
@@ -1626 +1689 @@
                (dolist (x l) (r x))))
       (r* l))))
+
+(defmethod traverse ((operation operation) (c component))
+  ;; cerror'ing a feature that seems to have NEVER EVER worked
+  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
+  ;; It was both fixed and disabled in the 1.700 rewrite.
+  (when (consp (operation-forced operation))
+    (cerror "Continue nonetheless."
+            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
+    (setf (operation-forced operation)
+          (mapcar #'coerce-name (operation-forced operation))))
+  (flatten-tree
+   (while-collecting (collect)
+     (do-traverse operation c #'collect))))
 
 (defmethod perform ((operation operation) (c source-file))
@@ -1899 +1975 @@
   "Operate does three things:
 
-1. It creates an instance of `operation-class` using any keyword parameters
+1. It creates an instance of OPERATION-CLASS using any keyword parameters
 as initargs.
-2. It finds the  asdf-system specified by `system` (possibly loading
+2. It finds the  asdf-system specified by SYSTEM (possibly loading
 it from disk).
-3. It then calls `traverse` with the operation and system as arguments
-
-The traverse operation is wrapped in `with-compilation-unit` and error
-handling code. If a `version` argument is supplied, then operate also
-ensures that the system found satisfies it using the `version-satisfies`
+3. It then calls TRAVERSE with the operation and system as arguments
+
+The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
+handling code. If a VERSION argument is supplied, then operate also
+ensures that the system found satisfies it using the VERSION-SATISFIES
 method.
 
@@ -1945 +2021 @@
 ;;;; Defsystem
 
+(defun load-pathname ()
+  (let ((pn (or *load-pathname* *compile-file-pathname*)))
+    (if *resolve-symlinks*
+        (and pn (resolve-symlinks pn))
+        pn)))
+
 (defun determine-system-pathname (pathname pathname-supplied-p)
-  ;; called from the defsystem macro.
-  ;; the pathname of a system is either
+  ;; The defsystem macro calls us to determine
+  ;; the pathname of a system as follows:
   ;; 1. the one supplied,
-  ;; 2. derived from the *load-truename* (see below), or
-  ;; 3. taken from *default-pathname-defaults*
-  ;;
-  ;; if using *load-truename*, then we also deal with whether or not
-  ;; to resolve symbolic links. If not resolving symlinks, then we use
-  ;; *load-pathname* instead of *load-truename* since in some
-  ;; implementations, the latter has *already resolved it.
-  (let ((file-pathname
-         (when (or *load-pathname* *compile-file-pathname*)
-           (pathname-directory-pathname
-            (if *resolve-symlinks*
-                (resolve-symlinks (or *load-truename* *compile-file-truename*))
-                *load-pathname*)))))
-    (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
+  ;; 2. derived from *load-pathname* via load-pathname
+  ;; 3. taken from the *default-pathname-defaults* via default-directory
+  (let* ((file-pathname (load-pathname))
+         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
+    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
         file-pathname
-        (current-directory))))
+        (default-directory))))
 
 (defmacro defsystem (name &body options)
@@ -1985 +2058 @@
                   (register-system (quote ,name)
                                    (make-instance ',class :name ',name))))
-           (%set-system-source-file *load-truename*
+           (%set-system-source-file (load-pathname)
                                     (cdr (system-registered-p ',name))))
          (parse-component-form
@@ -2174 +2247 @@
 
 (defun run-shell-command (control-string &rest args)
-  "Interpolate `args` into `control-string` as if by `format`, and
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 synchronously execute the result using a Bourne-compatible shell, with
-output to `*verbose-out*`.  Returns the shell's exit code."
+output to *VERBOSE-OUT*.  Returns the shell's exit code."
   (let ((command (apply #'format nil control-string args)))
     (asdf-message "; $ ~A~%" command)
@@ -2447 +2520 @@
     (funcall validator (car forms))))
 
+(defun hidden-file-p (pathname)
+  (equal (first-char (pathname-name pathname)) #\.))
+
 (defun validate-configuration-directory (directory tag validator)
   (let ((files (sort (ignore-errors
-                       (directory (make-pathname :name :wild :type :wild :defaults directory)
-                                  #+sbcl :resolve-symlinks #+sbcl nil))
+                       (remove-if
+                        'hidden-file-p
+                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
+                                   #+sbcl :resolve-symlinks #+sbcl nil)))
                      #'string< :key #'namestring)))
     `(,tag
@@ -2507 +2585 @@
   (values))
 
-(defparameter *wild-path*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type :wild :version :wild))
-
 (defparameter *wild-asd*
   (make-pathname :directory '(:relative :wild-inferiors)
                  :name :wild :type "asd" :version :newest))
 
-(defun wilden (path)
-  (merge-pathnames* *wild-path* path))
+
+(declaim (ftype (function (t &optional boolean) (or null pathname))
+                resolve-location))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+  (let* ((r (etypecase x
+              (pathname x)
+              (string x)
+              (cons
+               (let ((car (resolve-relative-location-component super (car x) nil)))
+                 (if (null (cdr x))
+                     car
+                     (let ((cdr (resolve-relative-location-component
+                                 (merge-pathnames* car super) (cdr x) wildenp)))
+                       (merge-pathnames* cdr car)))))
+              ((eql :default-directory)
+               (relativize-pathname-directory (default-directory)))
+              ((eql :implementation) (implementation-identifier))
+              ((eql :implementation-type) (string-downcase (implementation-type)))
+              #-(and (or win32 windows mswindows mingw32) (not cygwin))
+              ((eql :uid) (princ-to-string (get-uid)))))
+         (d (if (pathnamep x) r (ensure-directory-pathname r)))
+         (s (if (and wildenp (not (pathnamep x)))
+                (wilden d)
+                d)))
+    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
+      (error "pathname ~S is not relative to ~S" s super))
+    (merge-pathnames* s super)))
 
 (defun resolve-absolute-location-component (x wildenp)
@@ -2538 +2638 @@
             ((eql :user-cache) (resolve-location *user-cache* nil))
             ((eql :system-cache) (resolve-location *system-cache* nil))
-            ((eql :current-directory) (current-directory))))
+            ((eql :default-directory) (default-directory))))
          (s (if (and wildenp (not (pathnamep x)))
                 (wilden r)
@@ -2545 +2645 @@
       (error "Not an absolute pathname ~S" s))
     s))
-
-(defun resolve-relative-location-component (super x &optional wildenp)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string x)
-              (cons
-               (let ((car (resolve-relative-location-component super (car x) nil)))
-                 (if (null (cdr x))
-                     car
-                     (let ((cdr (resolve-relative-location-component
-                                 (merge-pathnames* car super) (cdr x) wildenp)))
-                       (merge-pathnames* cdr car)))))
-              ((eql :current-directory)
-               (relativize-pathname-directory (current-directory)))
-              ((eql :implementation) (implementation-identifier))
-              ((eql :implementation-type) (string-downcase (implementation-type)))
-              ((eql :uid) (princ-to-string (get-uid)))))
-         (d (if (pathnamep x) r (ensure-directory-pathname r)))
-         (s (if (and wildenp (not (pathnamep x)))
-                (wilden d)
-                d)))
-    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
-      (error "pathname ~S is not relative to ~S" s super))
-    (merge-pathnames* s super)))
 
 (defun resolve-location (x &optional wildenp)
@@ -2675 +2751 @@
     ;; so we must disable translations for implementation paths.
     #+sbcl (,(getenv "SBCL_HOME") ())
-    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
-    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
+    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
+    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
@@ -2700 +2776 @@
 
 (defgeneric process-output-translations (spec &key inherit collect))
+(declaim (ftype (function (t &key (:collect (or symbol function))) t)
+                inherit-output-translations))
+(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
+                process-output-translations-directive))
+
 (defmethod process-output-translations ((x symbol) &key
                                         (inherit *default-output-translations*)
@@ -2827 +2908 @@
        :finally (return p)))))
 
-(defun last-char (s)
-  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-(defun directorize-pathname-host-device (pathname)
-  (let* ((root (pathname-root pathname))
-         (wild-root (wilden root))
-         (absolute-pathname (merge-pathnames* pathname root))
-         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
-         (separator (last-char (namestring foo)))
-         (root-namestring (namestring root))
-         (root-string
-          (substitute-if #\/
-                         (lambda (x) (or (eql x #\:)
-                                         (eql x separator)))
-                         root-namestring)))
-    (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string t)
-      (declare (ignore relative filename))
-      (let ((new-base
-             (make-pathname :defaults root
-                            :directory `(:absolute ,@path))))
-        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
-
 (defmethod output-files :around (operation component)
   "Translate output files, unless asked not to"
@@ -2992 +3050 @@
 
 ;; Using ack 1.2 exclusions
-(defvar *default-exclusions*
+(defvar *default-source-registry-exclusions*
   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     "_sgbak" "autom4te.cache" "cover_db" "_build"))
+
+(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
 
 (defvar *source-registry* ()
@@ -3017 +3077 @@
   (setf *source-registry* '())
   (values))
-
-(defun probe-asd (name defaults)
-  (block nil
-    (when (directory-pathname-p defaults)
-      (let ((file
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name name
-              :type "asd")))
-        (when (probe-file file)
-          (return file)))
-      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
-      (let ((shortcut
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name (concatenate 'string name ".asd")
-              :type "lnk")))
-        (when (probe-file shortcut)
-          (let ((target (parse-windows-shortcut shortcut)))
-            (when target
-              (return (pathname target)))))))))
-
-(defun sysdef-source-registry-search (system)
-  (ensure-source-registry)
-  (loop :with name = (coerce-name system)
-    :for defaults :in (source-registry)
-    :for file = (probe-asd name defaults)
-    :when file :return file))
 
 (defun validate-source-registry-directive (directive)
@@ -3054 +3086 @@
                (and (length=n-p rest 1)
                     (typep (car rest) '(or pathname string null))))
-              ((:exclude)
+              ((:exclude :also-exclude)
                (every #'stringp rest))
               (null rest))))
@@ -3140 +3172 @@
   `(:source-registry
     #+sbcl (:tree ,(getenv "SBCL_HOME"))
-   :inherit-configuration))
+    :inherit-configuration
+    #+cmu (:tree #p"modules:")))
 (defun default-source-registry ()
   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
@@ -3179 +3212 @@
 
 (defgeneric process-source-registry (spec &key inherit register))
+(declaim (ftype (function (t &key (:register (or symbol function))) t)
+                inherit-source-registry))
+(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
+                process-source-registry-directive))
+
 (defmethod process-source-registry ((x symbol) &key inherit register)
   (process-source-registry (funcall x) :inherit inherit :register register))
@@ -3198 +3236 @@
   (inherit-source-registry inherit :register register))
 (defmethod process-source-registry ((form cons) &key inherit register)
-  (let ((*default-exclusions* *default-exclusions*))
+  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
     (dolist (directive (cdr (validate-source-registry-form form)))
       (process-source-registry-directive directive :inherit inherit :register register))))
@@ -3219 +3257 @@
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
+           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
       ((:exclude)
-       (setf *default-exclusions* rest))
+       (setf *source-registry-exclusions* rest))
+      ((:also-exclude)
+       (appendf *source-registry-exclusions* rest))
       ((:default-registry)
        (inherit-source-registry '(default-source-registry) :register register))
@@ -3227 +3267 @@
        (inherit-source-registry inherit :register register))
       ((:ignore-inherited-configuration)
-       nil))))
+       nil)))
+  nil)
 
 (defun flatten-source-registry (&optional parameter)
@@ -3262 +3303 @@
       (initialize-source-registry)))
 
+(defun sysdef-source-registry-search (system)
+  (ensure-source-registry)
+  (loop :with name = (coerce-name system)
+    :for defaults :in (source-registry)
+    :for file = (probe-asd name defaults)
+    :when file :return file))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
@@ -3272 +3320 @@
          (missing-component (constantly nil))
          (error (lambda (e)
-                  (format *error-output* "ASDF could not load ~A because ~A.~%"
+                  (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
                           name e))))
       (let* ((*verbose-out* (make-broadcast-stream))
-             (system (find-system name nil)))
+             (system (find-system (string-downcase name) nil)))
         (when system
-          (load-system name)
+          (load-system system)
           t))))
   (pushnew 'module-provide-asdf
            #+abcl sys::*module-provider-functions*
-           #+clozure ccl::*module-provider-functions*
+           #+clozure ccl:*module-provider-functions*
            #+cmu ext:*module-provider-functions*
            #+ecl si:*module-provider-functions*
@@ -3314 +3362 @@
 
 (pushnew :asdf *features*)
-;; this is a release candidate for ASDF 2.0
 (pushnew :asdf2 *features*)