Changeset 12765

Timestamp:

06/25/10 10:46:06 (13 years ago)

Author:

Mark Evenson

Message:

Update to ASDF-2.003 with local patches.

Local patches differentiate output location by FASL and Java version.

Location:

trunk/abcl

Files:

• doc/asdf/asdf.texinfo (modified) (29 diffs)
• src/org/armedbear/lisp/asdf.lisp (modified) (64 diffs)

trunk/abcl/doc/asdf/asdf.texinfo

@@ -171 +171 @@
 
 @emph{Nota Bene}:
-We are preparing for a release of ASDF 2, hopefully for May 2010,
-which will have version 2.000 and later.
-Current releases, in the 1.700 series and beyond,
-should be considered as release candidates.
-We're still working on polishing the code and documentation.
+We have released ASDF 2.000 on May 31st 2010.
+It hopefully will have been it included
+in all CL maintained implementations shortly afterwards.
 @xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
 
@@ -242 +240 @@
 If it returns @code{NIL} then ASDF is not installed.
 
-If you are running a version older than 1.711,
+If you are running a version older than 2.000,
 we recommend that you load a newer ASDF using the method below.
 
@@ -341 +339 @@
 
 The simplest way to add a path to your search path,
-say @file{/foo/bar/baz/quux/}
+say @file{/home/luser/.asd-link-farm/}
 is to create the directory
 @file{~/.config/common-lisp/source-registry.conf.d/}
-and there create a file with any name of your choice,
-for instance @file{42-bazquux.conf}
+and there create a file with any name of your choice but the type @file{conf},
+for instance @file{42-asd-link-farm.conf}
 containing the line:
 
-@kbd{(:directory "/foo/bar/baz/quux/")}
-
-If you want all the subdirectories under @file{/foo/bar/baz/}
+@kbd{(:directory "/home/luser/.asd-link-farm/")}
+
+If you want all the subdirectories under @file{/home/luser/lisp/}
 to be recursively scanned for @file{.asd} files, instead use:
 
-@kbd{(:tree "/foo/bar/baz/quux/")}
+@kbd{(:tree "/home/luser/lisp/")}
 
 Note that your Operating System distribution or your system administrator
 may already have configured system-managed libraries for you.
 
-Also note that when choosing a filename, the convention is to use
-the @file{.conf} extension
-(and a non-empty extension is required for CLISP compatibility),
-and it is customary to start the filename with two digits
+The required @file{.conf} extension allows you to have disabled files
+or editor backups (ending in @file{~}), and works portably
+(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
+Excluded are files the name of which start with a @file{.} character.
+It is customary to start the filename with two digits
 that specify the order in which the directories will be scanned.
 
@@ -486 +485 @@
 is to create the directory
 @file{~/.config/common-lisp/asdf-output-translations.conf.d/}
-and there create a file with any name of your choice,
+and there create a file with any name of your choice and the type @file{conf},
 for instance @file{42-bazquux.conf}
 containing the line:
@@ -511 +510 @@
 @xref{Controlling where ASDF searches for systems}, for full details.
 
-
-Also note that when choosing a filename, the convention is to use
-the @file{.conf} extension
-(and a non-empty extension is required for CLISP compatibility),
-and it is customary to start the filename with two digits
+The required @file{.conf} extension allows you to have disabled files
+or editor backups (ending in @file{~}), and works portably
+(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
+Excluded are files the name of which start with a @file{.} character.
+It is customary to start the filename with two digits
 that specify the order in which the directories will be scanned.
 
@@ -536 +535 @@
 ASDF-Binary-Locations, cl-launch, common-lisp-controller.
 ASDF-Binary-Locations is now not needed anymore and should not be used.
-cl-launch 2.900 and common-lisp-controller 7.1 have been updated
+cl-launch 3.000 and common-lisp-controller 7.2 have been updated
 to just delegate this functionality to ASDF.
 
@@ -814 +813 @@
 
 @subsection Pathname specifiers
+@cindex pathname specifiers
 
 A pathname specifier (@code{pathname-specifier})
@@ -846 +846 @@
 will be interpreted as the pathname @file{#p"foo/bar.quux"}.
 
+ASDF does not interpret the string @code{".."} to designate the parent
+directory.  This string will be passed through to the underlying
+operating system for interpretation.  We @emph{believe} that this will
+work on all platforms where ASDF is deployed, but do not guarantee this
+behavior.  A pathname object with a relative directory component of
+@code{:up} or @code{:back} is the only guaranteed way to specify a
+parent directory.
+
 If a symbol is given, it will be translated into a string,
 and downcased in the process.
@@ -857 +865 @@
 which is reported not to work on some implementations.
 
-Pathnames objects may be given to override the path for a component.
+Pathname objects may be given to override the path for a component.
 Such objects are typically specified using reader macros such as @code{#p}
 or @code{#.(make-pathname ...)}.
-Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)}
-and that the behavior @code{parse-namestring} is completely non-portable,
-unless you are using Common Lisp @code{logical-pathname}s.
-(@xref{The defsystem grammar,,Warning about logical pathnames}, below.)
+Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)}
+and that the behavior of @code{parse-namestring} is completely non-portable,
+unless you are using Common Lisp @code{logical-pathname}s
+(@pxref{The defsystem grammar,,Warning about logical pathnames}, below).
 Pathnames made with @code{#.(make-pathname ...)}
 can usually be done more easily with the string syntax above.
 The only case that you really need a pathname object is to override
 the component-type default file type for a given component.
-Therefore, it is a rare case that pathname objects should be used at all.
+Therefore, pathname objects should only rarely be used.
 Unhappily, ASDF 1 didn't properly support
 parsing component names as strings specifying paths with directories,
 and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
-Note that when specifying pathname objects, no magic interpretation of the pathname
-is made depending on the component type.
+
+Note that when specifying pathname objects, 
+ASDF does not do any special interpretation of the pathname
+influenced by the component type, unlike the procedure for
+pathname-specifying strings.
 On the one hand, you have to be careful to provide a pathname that correctly
 fulfills whatever constraints are required from that component type
@@ -882 +893 @@
 
 @subsection Warning about logical pathnames
+@cindex logical pathnames 
+
+We recommend that you not use logical pathnames
+in your asdf system definitions at this point,
+but logical pathnames @emph{are} supported.
 
 To use logical pathnames,
@@ -889 +905 @@
 
 You only have to specify such logical pathname for your system or
-some top-level component, as sub-components using the usual string syntax
-for names will be properly merged with the pathname of their parent.
+some top-level component.  Sub-components' relative pathnames, specified
+using the string syntax
+for names, will be properly merged with the pathnames of their parents.
 The specification of a logical pathname host however is @emph{not}
 otherwise directly supported in the ASDF syntax
 for pathname specifiers as strings.
 
-Logical pathnames are not specifically recommended to newcomers,
-but are otherwise supported.
-Moreover, the @code{asdf-output-translation} layer will
-avoid trying to resolve and translate logical-pathnames,
-so you can define yourself what translations you want to use
+The @code{asdf-output-translation} layer will
+avoid trying to resolve and translate logical-pathnames.
+The advantage of this is that you can define yourself what translations you want to use
 with the logical pathname facility.
-
-The user of logical pathnames will have to configure logical pathnames himself,
-before they may be used, and ASDF provides no specific support for that.
+The disadvantage is that if you do not define such translations, any
+system that uses logical pathnames will be have differently under
+asdf-output-translations than other systems you use.
+
+If you wish to use logical pathnames you will have to configure the
+translations yourself before they may be used.
+ASDF currently provides no specific support
+for defining logical pathname translations.
 
 
 @subsection Serial dependencies
+@cindex serial dependencies
 
 If the @code{:serial t} option is specified for a module,
@@ -914 +935 @@
 
 @lisp
+:serial t
 :components ((:file "a") (:file "b") (:file "c"))
-:serial t
 @end lisp
 
@@ -1714 +1735 @@
 ;; A directive is one of the following:
 DIRECTIVE :=
+    ;; INHERITANCE DIRECTIVE:
+    ;; Your configuration expression MUST contain
+    ;; exactly one of either of these:
+    :inherit-configuration | ; splices inherited configuration (often specified last)
+    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+
     ;; add a single directory to be scanned (no recursion)
     (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
@@ -1720 +1747 @@
     (:tree DIRECTORY-PATHNAME-DESIGNATOR) |
 
-    ;; override the default defaults for exclusion patterns
+    ;; override the defaults for exclusion patterns
     (:exclude PATTERN ...) |
+    ;; augment the defaults for exclusion patterns
+    (:also-exclude PATTERN ...) |
 
     ;; splice the parsed contents of another config file
     (:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
-
-    ;; Your configuration expression MUST contain
-    ;; exactly one of either of these:
-    :inherit-configuration | ; splices contents of inherited configuration
-    :ignore-inherited-configuration | ; drop contents of inherited configuration
 
     ;; This directive specifies that some default must be spliced.
@@ -1737 +1761 @@
   against the name of a any subdirectory in the directory component
         of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
+@end example
+
+For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
+which is the default place ASDF looks for this configuration,
+once contained:
+@example
+(:source-registry
+  (:tree "/home/fare/cl/")
+  :inherit-configuration)
 @end example
 
@@ -1747 +1780 @@
 the lists of directives of these files with be concatenated in order.
 An implicit @code{:inherit-configuration} will be included
-at the end of the list.
+at the @emph{end} of the list.
 
 This allows for packaging software that has file granularity
@@ -1765 +1798 @@
 @example
   (:include "/foo/bar/")
+@end example
+
+Hence, to achieve the same effect as
+my example @file{~/.config/common-lisp/source-registry.conf} above,
+I could simply create a file
+@file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf}
+alone in its directory with the following contents:
+@example
+(:tree "/home/fare/cl/")
 @end example
 
@@ -1809 +1851 @@
 If none is found, the search continues.
 
-Exclude statements specify patterns of subdirectories the systems of which
-to ignore. Typically you don't want to use copies of files kept by such
+Exclude statements specify patterns of subdirectories
+the systems from which to ignore.
+Typically you don't want to use copies of files kept by such
 version control systems as Darcs.
+Exclude statements are not propagated to further included or inherited
+configuration files or expressions;
+instead the defaults are reset around every configuration statement
+to the default defaults from @code{asdf::*default-source-registry-exclusions*}.
 
 Include statements cause the search to recurse with the path specifications
@@ -2058 +2105 @@
 Recent versions of same packages use
 the new @code{asdf-output-translations} API as defined below:
-@code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00);
+@code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000).
 @code{ASDF-Binary-Locations} is fully superseded and not to be used anymore.
 
@@ -2111 +2158 @@
 ;; A directive is one of the following:
 DIRECTIVE :=
+    ;; INHERITANCE DIRECTIVE:
+    ;; Your configuration expression MUST contain
+    ;; exactly one of either of these:
+    :inherit-configuration | ; splices inherited configuration (often specified last)
+    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+
     ;; include a configuration file or directory
     (:include PATHNAME-DESIGNATOR) |
-
-    ;; Your configuration expression MUST contain
-    ;; exactly one of either of these:
-    :inherit-configuration | ; splices contents of inherited configuration
-    :ignore-inherited-configuration | ; drop contents of inherited configuration
 
     ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
@@ -2233 +2281 @@
 the lists of directives of these files with be concatenated in order.
 An implicit @code{:inherit-configuration} will be included
-at the end of the list.
+at the @emph{end} of the list.
 
 This allows for packaging software that has file granularity
@@ -2495 +2543 @@
 @subsection What are ASDF 1 and ASDF 2?
 
-We are preparing for a release of ASDF 2,
-which will have version 2.000 and later.
-While the code and documentation are essentially complete
-we are still working on polishing them before release.
-
-Releases in the 1.700 series and beyond
-should be considered as release candidates.
-For all practical purposes,
-ASDF 2 refers to releases later than 1.656,
-and ASDF 1 to any release earlier than 1.369 or so.
-If your ASDF doesn't have a version, it's old.
-
-ASDF 2 release candidates and beyond will have
+On May 31st 2010, we have released ASDF 2.
+ASDF 2 refers to release 2.000 and later.
+(Releases between 1.656 and 1.728 were development releases for ASDF 2.)
+ASDF 1 to any release earlier than 1.369 or so.
+If your ASDF doesn't sport a version, it's an old ASDF 1.
+
+ASDF 2 and its release candidates push
 @code{:asdf2} onto @code{*features*} so that if you are writing
 ASDF-dependent code you may check for this feature
@@ -2514 +2556 @@
 
 If you are experiencing problems or limitations of any sort with ASDF 1,
-we recommend that you should upgrade to ASDF 2 or its latest release candidate.
+we recommend that you should upgrade to ASDF 2,
+or whatever is the latest release.
 
 
@@ -2538 +2581 @@
 @code{asdf::merge-component-name-type}.
 
+On the other hand, there are places where systems used to accept namestrings
+where you must now use an explicit pathname object:
+@code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+must now be written with the @code{#p} syntax:
+@code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+
 @xref{The defsystem grammar,,Pathname specifiers}.
 
@@ -2636 +2685 @@
 The internal test suite used to massively fail on many implementations.
 While still incomplete, it now fully passes
-on all implementations supported by the test suite.
+on all implementations supported by the test suite,
+except for GCL (due to GCL bugs).
 
 @item
 Support was lacking for some implementations.
-ABCL was notably wholly broken.
+ABCL and GCL were notably wholly broken.
 ECL extensions were not integrated in the ASDF release.
 
@@ -2661 +2711 @@
 that everyone can rely on from now on.
 Use @code{#+asdf2} to detect presence of ASDF 2,
-@code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
+@code{(asdf:version-satisfies (asdf:asdf-version) "2.000")}
 to check the availability of a version no earlier than required.
 
@@ -2733 +2783 @@
 @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
 But thou shall not load ABL on top of ASDF 2.
+
+@item
+ASDF pathname designators are now specified in places where they were unspecified,
+and a few small adjustments have to be made to some non-portable defsystems.
+Notably, in the @code{:pathname} argument to a @code{defsystem} and its components,
+a logical pathname (or implementation-dependent hierarchical pathname)
+must now be specified with @code{#p} syntax
+where the namestring might have previously sufficed;
+moreover when evaluation is desired @code{#.} must be used,
+where it wasn't necessary in the toplevel @code{:pathname} argument.
 
 @end itemize
@@ -3090 +3150 @@
 @section Missing bits in implementation
 
-** all of the above
-
 ** reuse the same scratch package whenever a system is reloaded from disk
-
-** rules for system pathname defaulting are not yet implemented properly
 
 ** proclamations probably aren't
@@ -3103 +3159 @@
 like take the list of kids and @code{setf} the slot to @code{nil},
 then transfer children from old to new list as they're found.
-
-**  traverse may become a normal function
-
-If you're defining methods on @code{traverse}, speak up.
-
-
-** a lot of load-op methods can be rewritten to use input-files
-
-so should be.
-
 
 ** (stuff that might happen later)

trunk/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -48 +48 @@
 #+xcvb (module ())
 
-(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)
-
-;;;; Create packages in a way that is compatible with hot-upgrade.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more at the end of the file.
-
-#+gcl
-(eval-when (:compile-toplevel :load-toplevel)
-  (defpackage :asdf-utilities (:use :cl))
-  (defpackage :asdf (:use :cl :asdf-utilities)))
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
+(cl:in-package :cl)
+(defpackage :asdf-bootstrap (:use :cl))
+(in-package :asdf-bootstrap)
+
+;; Implementation-dependent tweaks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
                 :test 'equalp :key 'car))
-  (let* ((asdf-version
-          ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:1.719" (1+ (length "VERSION"))))
+  #+ecl (require :cmp)
+  #+gcl
+  (eval-when (:compile-toplevel :load-toplevel)
+    (defpackage :asdf-utilities (:use :cl))
+    (defpackage :asdf (:use :cl :asdf-utilities))))
+
+;;;; Create packages in a way that is compatible with hot-upgrade.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;; See more at the end of the file.
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
+          (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
          (existing-asdf (find-package :asdf))
          (vername '#:*asdf-version*)
@@ -81 +81 @@
       #-gcl
       (when existing-asdf
-        (format *error-output*
+        (format *trace-output*
                 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
                 existing-version asdf-version))
@@ -156 +156 @@
             ((pkgdcl (name &key nicknames use export
                            redefined-functions unintern fmakunbound shadow)
-               `(ensure-package
-                 ',name :nicknames ',nicknames :use ',use :export ',export
-                 :shadow ',shadow
-                 :unintern ',(append #-(or gcl ecl) redefined-functions
-                                     unintern)
-                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
-                                        fmakunbound))))
+                 `(ensure-package
+                   ',name :nicknames ',nicknames :use ',use :export ',export
+                   :shadow ',shadow
+                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
+                   :fmakunbound ',(append fmakunbound))))
           (pkgdcl
            :asdf-utilities
@@ -291 +289 @@
             #:ensure-output-translations
             #:apply-output-translations
+            #:compile-file*
             #:compile-file-pathname*
             #:enable-asdf-binary-locations-compatibility
@@ -328 +327 @@
            ((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))))))
@@ -337 +337 @@
   "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*)
 
@@ -345 +345 @@
 Defaults to `t`.")
 
-(defvar *compile-file-warnings-behaviour* :warn)
-
-(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+(defvar *compile-file-warnings-behaviour* :warn
+  "How should ASDF react if it encounters a warning when compiling a
+file?  Valid values are :error, :warn, and :ignore.")
+
+(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
+        "How should ASDF react if it encounters a failure \(per the
+ANSI spec of COMPILE-FILE\) when compiling a file?  Valid values are
+:error, :warn, and :ignore.  Note that ASDF ALWAYS raises an error
+if it fails to create an output file when compiling.")
 
 (defvar *verbose-out* nil)
@@ -366 +372 @@
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
-
-(defgeneric perform-with-restarts (operation component))
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(defmacro defgeneric* (name formals &rest options)
+  `(progn
+     #+(or gcl ecl) (fmakunbound ',name)
+     (defgeneric ,name ,formals ,@options)))
+
+(defgeneric* perform-with-restarts (operation component))
+(defgeneric* perform (operation component))
+(defgeneric* operation-done-p (operation component))
+(defgeneric* explain (operation component))
+(defgeneric* output-files (operation component))
+(defgeneric* input-files (operation component))
 (defgeneric component-operation-time (operation component))
 
-(defgeneric system-source-file (system)
+(defgeneric* system-source-file (system)
   (:documentation "Return the source file in which system is defined."))
 
@@ -397 +407 @@
 (defgeneric version-satisfies (component version))
 
-(defgeneric find-component (base path)
+(defgeneric* find-component (base path)
   (:documentation "Finds the component with PATH starting from BASE module;
 if BASE is nil, then the component is assumed to be a system."))
@@ -456 +466 @@
 (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."))
 
 
@@ -467 +477 @@
 
 (defmacro while-collecting ((&rest collectors) &body body)
+  "COLLECTORS should be a list of names for collections.  A collector
+defines a function that, when applied to an argument inside BODY, will
+add its argument to the corresponding collection.  Returns multiple values,
+a list for each collection, in order.
+   E.g.,
+\(while-collecting \(foo bar\)
+           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
+             \(foo \(first x\)\)
+             \(bar \(second x\)\)\)\)
+Returns two values: \(A B C\) and \(1 2 3\)."
   (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
         (initial-values (mapcar (constantly nil) collectors)))
@@ -480 +500 @@
   "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*))
@@ -494 +512 @@
          (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)))
@@ -517 +535 @@
              (values (pathname-host defaults)
                      (pathname-device defaults)
-                     (if (null (pathname-directory defaults))
-                         directory
-                         (append (pathname-directory defaults) (cdr directory)))
+                     (if (pathname-directory defaults)
+                         (append (pathname-directory defaults) (cdr directory))
+                         directory)
                      (unspecific-handler defaults)))
             #+gcl
@@ -539 +557 @@
   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))
@@ -544 +568 @@
 
 (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
@@ -596 +620 @@
     (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))
           (values :relative components))
+      (setf components (remove "" components :test #'equal))
       (cond
         ((equal last-comp "")
-         (values relative (butlast components) nil))
+         (values relative components nil)) ; "" already removed
         (force-directory
          (values relative components nil))
@@ -618 +643 @@
     :unless (eq k key)
     :append (list k v)))
-
-(defun resolve-symlinks (path)
-  #-allegro (truenamize path)
-  #+allegro (excl:pathname-resolve-symbolic-links path))
 
 (defun getenv (x)
@@ -629 +650 @@
   (sb-ext:posix-getenv x)
   #+clozure
-  (ccl::getenv x)
+  (ccl:getenv x)
   #+clisp
   (ext:getenv x)
@@ -644 +665 @@
 
 (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)
@@ -734 +755 @@
       (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))
@@ -761 +780 @@
             (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))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -775 +828 @@
   ;; 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)
@@ -895 +957 @@
 
 (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)
@@ -912 +974 @@
     :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
@@ -940 +1001 @@
              (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))
@@ -1014 +1075 @@
 
 (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)
@@ -1029 +1090 @@
 
 (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 system-definition-pathname (system)
@@ -1054 +1115 @@
 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)
@@ -1073 +1155 @@
                                    (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))
@@ -1123 +1205 @@
 
 (defun find-system (name &optional (error-p t))
-  (let* ((name (coerce-name name))
-         (in-memory (system-registered-p name))
-         (on-disk (system-definition-pathname name)))
-    (when (and on-disk
-               (or (not in-memory)
-                   (< (car in-memory) (safe-file-write-date on-disk))))
-      (let ((package (make-temporary-package)))
-        (unwind-protect
-             (handler-bind
-                 ((error (lambda (condition)
-                           (error 'load-system-definition-error
-                                  :name name :pathname on-disk
-                                  :condition condition))))
-               (let ((*package* package))
-                 (asdf-message
-                  "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
-                  on-disk *package*)
-                 (load on-disk)))
-          (delete-package package))))
-    (let ((in-memory (system-registered-p name)))
-      (if in-memory
-          (progn (when on-disk (setf (car in-memory)
-                                     (safe-file-write-date on-disk)))
-                 (cdr in-memory))
-          (when error-p (error 'missing-component :requires name))))))
+  (catch 'find-system
+    (let* ((name (coerce-name name))
+           (in-memory (system-registered-p name))
+           (on-disk (system-definition-pathname name)))
+      (when (and on-disk
+                 (or (not in-memory)
+                     (< (car in-memory) (safe-file-write-date on-disk))))
+        (let ((package (make-temporary-package)))
+          (unwind-protect
+               (handler-bind
+                   ((error (lambda (condition)
+                             (error 'load-system-definition-error
+                                    :name name :pathname on-disk
+                                    :condition condition))))
+                 (let ((*package* package))
+                   (asdf-message
+                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+                    on-disk *package*)
+                   (load on-disk)))
+            (delete-package package))))
+      (let ((in-memory (system-registered-p name)))
+        (if in-memory
+            (progn (when on-disk (setf (car in-memory)
+                                       (safe-file-write-date on-disk)))
+                   (cdr in-memory))
+            (when error-p (error 'missing-component :requires name)))))))
 
 (defun register-system (name system)
@@ -1153 +1236 @@
   (setf (gethash (coerce-name name) *defined-systems*)
         (cons (get-universal-time) system)))
+
+(defun sysdef-find-asdf (system)
+  (let ((name (coerce-name system)))
+    (when (equal name "asdf")
+      (let* ((registered (cdr (gethash name *defined-systems*)))
+             (asdf (or registered
+                       (make-instance
+                        'system :name "asdf"
+                        :source-file (or *compile-file-truename* *load-truename*)))))
+        (unless registered
+          (register-system "asdf" asdf))
+        (throw 'find-system asdf)))))
 
 
@@ -1172 +1267 @@
 
 (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))
@@ -1603 +1699 @@
       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.
@@ -1632 +1715 @@
       (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))
   (sysdef-error
@@ -1673 +1769 @@
         (get-universal-time)))
 
+(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
+                          (values t t t))
+                compile-file*))
+
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
@@ -1678 +1778 @@
   #-:broken-fasl-loader
   (let ((source-file (component-pathname c))
-        (output-file (car (output-files operation c))))
+        (output-file (car (output-files operation c)))
+        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
+        (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply #'compile-file source-file :output-file output-file
+        (apply #'compile-file* source-file :output-file output-file
                (compile-op-flags operation))
       (when warnings-p
@@ -1856 +1958 @@
 ;;;; Invoking Operations
 
-(defgeneric operate (operation-class system &key &allow-other-keys))
+(defgeneric* operate (operation-class system &key &allow-other-keys))
 
 (defmethod operate (operation-class system &rest args
@@ -1904 +2006 @@
   "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.
 
@@ -1950 +2052 @@
 ;;;; 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)
@@ -1990 +2089 @@
                   (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
@@ -1999 +2098 @@
                ',component-options))))))
 
-
 (defun class-for-type (parent type)
-  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
-                              (find-symbol (symbol-name type)
-                                           (load-time-value
-                                            (package-name :asdf)))))
-         (class (dolist (symbol (if (keywordp type)
-                                    extra-symbols
-                                    (cons type extra-symbols)))
-                  (when (and symbol
-                             (find-class symbol nil)
-                             (subtypep symbol 'component))
-                    (return (find-class symbol))))))
-    (or class
-        (and (eq type :file)
-             (or (module-default-component-class parent)
-                 (find-class 'cl-source-file)))
-        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
+  (or (loop :for symbol :in (list
+                             (unless (keywordp type) type)
+                             (find-symbol (symbol-name type) *package*)
+                             (find-symbol (symbol-name type) :asdf))
+        :for class = (and symbol (find-class symbol nil))
+        :when (and class (subtypep class 'component))
+        :return class)
+      (and (eq type :file)
+           (or (module-default-component-class parent)
+               (find-class *default-component-class*)))
+      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
 
 (defun maybe-add-tree (tree op1 op2 c)
@@ -2179 +2272 @@
 
 (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)
@@ -2334 +2427 @@
     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-    #+(or  mcl sbcl scl) s
+    #+(or cormanlisp mcl sbcl scl) s
     #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
           ecl gcl lispworks mcl sbcl scl) s))
@@ -2454 +2547 @@
     (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
@@ -2514 +2612 @@
   (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)
@@ -2545 +2665 @@
             ((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)
@@ -2552 +2672 @@
       (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)
@@ -2682 +2778 @@
     ;; 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
@@ -2707 +2803 @@
 
 (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*)
@@ -2834 +2935 @@
        :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"
@@ -2867 +2945 @@
    t))
 
-(defun compile-file-pathname* (input-file &rest keys)
-  (apply-output-translations
-   (apply #'compile-file-pathname
-          (truenamize (lispize-pathname input-file))
-          keys)))
+(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+  (or output-file
+      (apply-output-translations
+       (apply 'compile-file-pathname
+              (truenamize (lispize-pathname input-file))
+              keys))))
+
+(defun tmpize-pathname (x)
+  (make-pathname
+   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :defaults x))
+
+(defun delete-file-if-exists (x)
+  (when (probe-file x)
+    (delete-file x)))
+
+(defun compile-file* (input-file &rest keys &key &allow-other-keys)
+  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
+         (tmp-file (tmpize-pathname output-file))
+         (status :error))
+    (multiple-value-bind (output-truename warnings-p failure-p)
+        (apply 'compile-file input-file :output-file tmp-file keys)
+      (cond
+        (failure-p
+         (setf status *compile-file-failure-behaviour*))
+        (warnings-p
+         (setf status *compile-file-warnings-behaviour*))
+        (t
+         (setf status :success)))
+      (ecase status
+        ((:success :warn :ignore)
+         (delete-file-if-exists output-file)
+         (when output-truename
+           (rename-file output-truename output-file)
+           (setf output-truename output-file)))
+        (:error
+         (delete-file-if-exists output-truename)
+         (setf output-truename nil)))
+      (values output-truename warnings-p failure-p))))
 
 #+abcl
@@ -2999 +3111 @@
 
 ;; 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* ()
@@ -3024 +3138 @@
   (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)
@@ -3061 +3147 @@
                (and (length=n-p rest 1)
                     (typep (car rest) '(or pathname string null))))
-              ((:exclude)
+              ((:exclude :also-exclude)
                (every #'stringp rest))
               (null rest))))
@@ -3147 +3233 @@
   `(: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)))
@@ -3186 +3273 @@
 
 (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))
@@ -3205 +3297 @@
   (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))))
@@ -3226 +3318 @@
        (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))
@@ -3234 +3328 @@
        (inherit-source-registry inherit :register register))
       ((:ignore-inherited-configuration)
-       nil))))
+       nil)))
+  nil)
 
 (defun flatten-source-registry (&optional parameter)
@@ -3269 +3364 @@
       (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
@@ -3279 +3381 @@
          (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*
@@ -3313 +3415 @@
 ;;;; Done!
 (when *load-verbose*
-  (asdf-message ";; ASDF, version ~a" (asdf-version)))
+  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
 
 #+allegro
@@ -3321 +3423 @@
 
 (pushnew :asdf *features*)
-;; this is a release candidate for ASDF 2.0
 (pushnew :asdf2 *features*)