Changeset 12986

Timestamp:

10/31/10 08:40:27 (12 years ago)

Author:

Mark Evenson

Message:

Upgrade to ASDF-2.010.1.

Location:

trunk/abcl

Files:

• doc/asdf/asdf.texinfo (modified) (43 diffs)
• src/org/armedbear/lisp/asdf.lisp (modified) (157 diffs)

trunk/abcl/doc/asdf/asdf.texinfo

@@ -66 +66 @@
 
 @titlepage
-@title asdf: another system definition facility
+@title ASDF: Another System Definition Facility
 
 @c The following two commands start the copyright page.
@@ -207 +207 @@
 Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
 and you can load it that way.
-
+If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
+if you are using the latest version of your Lisp vendor's software,
+you may also send a bug report to your Lisp vendor and complain about
+their failing to provide ASDF.
 
 @section Checking whether ASDF is loaded
@@ -240 +243 @@
 If it returns @code{NIL} then ASDF is not installed.
 
-If you are running a version older than 2.000,
+If you are running a version older than 2.008,
 we recommend that you load a newer ASDF using the method below.
 
@@ -552 +555 @@
 @end example
 
-On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
+On some implementations (namely recent versions of
+ABCL, Clozure CL, CLISP, CMUCL, ECL, SBCL and SCL),
 ASDF hooks into the @code{CL:REQUIRE} facility
 and you can just use:
@@ -565 +569 @@
 we recommend that you upgrade to ASDF 2.
 @xref{Loading ASDF,,Loading an otherwise installed ASDF}.
+
+Note the name of a system is specified as a string or a symbol,
+typically a keyword.
+If a symbol (including a keyword), its name is taken and lowercased.
+The name must be a suitable value for the @code{:name} initarg
+to @code{make-pathname} in whatever filesystem the system is to be found.
+The lower-casing-symbols behaviour is unconventional,
+but was selected after some consideration.
+Observations suggest that the type of systems we want to support
+either have lowercase as customary case (unix, mac, windows)
+or silently convert lowercase to uppercase (lpns),
+so this makes more sense than attempting to use @code{:case :common},
+which is reported not to work on some implementations
 
 
@@ -720 +737 @@
 (defsystem "foo"
   :version "1.0"
-  :components ((:module "foo" :components ((:file "bar") (:file"baz")
-                                           (:file "quux"))
-                :perform (compile-op :after (op c)
-                          (do-something c))
-                :explain (compile-op :after (op c)
-                          (explain-something c)))
-               (:file "blah")))
+  :components ((:module "mod"
+                            :components ((:file "bar")
+                                                  (:file"baz")
+                                                  (:file "quux"))
+                            :perform (compile-op :after (op c)
+                                                  (do-something c))
+                            :explain (compile-op :after (op c)
+                                            (explain-something c)))
+                         (:file "blah")))
 @end lisp
 
-The method-form tokens need explaining: essentially, this part:
+The @code{:module} component named @code{"mod"} is a collection of three files,
+which will be located in a subdirectory of the main code directory named
+@file{mod} (this location can be overridden; see the discussion of the
+@code{:pathname} option in @ref{The defsystem grammar}).
+
+The method-form tokens provide a shorthand for defining methods on
+particular components.  This part
 
 @lisp
@@ -747 +772 @@
 @end lisp
 
-where @code{...} is the component in question;
-note that although this also supports @code{:before} methods,
-they may not do what you want them to ---
-a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
-will run after all the dependencies and sub-components have been processed,
-but before the component in question has been compiled.
+where @code{...} is the component in question.
+In this case @code{...} would expand to something like
+
+@lisp
+(find-component (find-system "foo") "mod")
+@end lisp
+
+For more details on the syntax of such forms, see @ref{The defsystem
+grammar}.
+For more details on what these methods do, @pxref{Operations} in
+@ref{The object model of ASDF}.
+
+@c The following plunge into the weeds is not appropriate in this
+@c location. [2010/10/03:rpg]
+@c note that although this also supports @code{:before} methods,
+@c they may not do what you want them to ---
+@c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
+@c will run after all the dependencies and sub-components have been processed,
+@c but before the component in question has been compiled.
 
 @node  The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
@@ -758 +796 @@
 @section The defsystem grammar
 
+@c FIXME: @var typesetting not consistently used here.  We should either expand
+@c its use to everywhere, or we should kill it everywhere.
+
+
 @example
-system-definition := ( defsystem system-designator @var{option}* )
-
-option := :components component-list
+system-definition := ( defsystem system-designator @var{system-option}* )
+
+system-option := :defsystem-depends-on system-list
+                 | module-option
+                 | option
+
+module-option := :components component-list
+                 | :serial [ t | nil ]
+                 | :if-component-dep-fails component-dep-fail-option
+
+option :=
         | :pathname pathname-specifier
-        | :default-component-class
+        | :default-component-class class-name
         | :perform method-form
         | :explain method-form
@@ -769 +819 @@
         | :operation-done-p method-form
         | :depends-on ( @var{dependency-def}* )
-        | :serial [ t | nil ]
         | :in-order-to ( @var{dependency}+ )
+
+
+system-list := ( @var{simple-component-name}* )
 
 component-list := ( @var{component-def}* )
@@ -797 +849 @@
 method-form := (operation-name qual lambda-list @&rest body)
 qual := method qualifier
+
+component-dep-fail-option := :fail | :try-next | :ignore
 @end example
+
+
 
 @subsection Component names
@@ -811 +867 @@
 the current package @code{my-system-asd} can be specified as
 @code{:my-component-type}, or @code{my-component-type}.
+
+@subsection Defsystem depends on
+
+The @code{:defsystem-depends-on} option to @code{defsystem} allows the
+programmer to specify another ASDF-defined system or set of systems that
+must be loaded @emph{before} the system definition is processed.
+Typically this is used to load an ASDF extension that is used in the
+system definition.
 
 @subsection Pathname specifiers
@@ -881 +945 @@
 and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
 
-Note that when specifying pathname objects, 
+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
@@ -893 +957 @@
 
 @subsection Warning about logical pathnames
-@cindex logical pathnames 
+@cindex logical pathnames
 
 We recommend that you not use logical pathnames
@@ -917 +981 @@
 with the logical pathname facility.
 The disadvantage is that if you do not define such translations, any
-system that uses logical pathnames will be have differently under
+system that uses logical pathnames will behave differently under
 asdf-output-translations than other systems you use.
 
@@ -930 +994 @@
 
 If the @code{:serial t} option is specified for a module,
-ASDF will add dependencies for each each child component,
+ASDF will add dependencies for each child component,
 on all the children textually preceding it.
 This is done as if by @code{:depends-on}.
@@ -993 +1057 @@
 from within an editor without clobbering its source location)
 @end itemize
+
+@subsection if-component-dep-fails option
+
+This option is only appropriate for module components (including
+systems), not individual source files.
+
+For more information about this option, @pxref{Pre-defined subclasses of component}.
 
 @node Other code in .asd files,  , The defsystem grammar, Defining systems with defsystem
@@ -1452 +1523 @@
 This is detailed elsewhere. @xref{Defining systems with defsystem}.
 
-The answer to the frequently asked question
-``how do I create a system definition
-where all the source files have a @file{.cl} extension''
-is thus
-
-@lisp
-(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys))))
-  "cl")
-@end lisp
 
 @subsubsection properties
@@ -1672 +1734 @@
 @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
 
-Each of these configuration is specified as a SEXP
-in a trival domain-specific language (defined below).
+Each of these configurations is specified as an s-expression
+in a trivial domain-specific language (defined below).
 Additionally, a more shell-friendly syntax is available
 for the environment variable (defined yet below).
@@ -1705 +1770 @@
 we try to use folder configuration from the registry regarding
 @code{Common AppData} and similar directories.
-However, support querying the Windows registry is limited as of ASDF 2,
+However, support for querying the Windows registry is limited as of ASDF 2,
 and on many implementations, we may fall back to always using the defaults
 without consulting the registry.
@@ -1712 +1777 @@
 @section Backward Compatibility
 
-For backward compatibility as well as for a practical backdoor for hackers,
+For backward compatibility as well as to provide a practical backdoor for hackers,
 ASDF will first search for @code{.asd} files in the directories specified in
 @code{asdf:*central-registry*}
@@ -1726 +1791 @@
 @section Configuration DSL
 
-Here is the grammar of the SEXP DSL for source-registry configuration:
+Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
 
 @example
-;; A configuration is single SEXP starting with keyword :source-registry
+;; A configuration is a single SEXP starting with keyword :source-registry
 ;; followed by a list of directives.
 CONFIGURATION := (:source-registry DIRECTIVE ...)
@@ -1751 +1816 @@
     ;; 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
@@ -1757 +1824 @@
     ;; This directive specifies that some default must be spliced.
     :default-registry
+
+REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file
+DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name
+
+PATHNAME-DESIGNATOR :=
+    NULL | ;; Special: skip this entry.
+    ABSOLUTE-COMPONENT-DESIGNATOR |
+    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
+
+ABSOLUTE-COMPONENT-DESIGNATOR :=
+    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
+    PATHNAME | ;; pathname (better be an absolute path, or bust)
+    :HOME | ;; designates the user-homedir-pathname ~/
+    :USER-CACHE | ;; designates the default location for the user cache
+    :SYSTEM-CACHE ;; designates the default location for the system cache
+
+RELATIVE-COMPONENT-DESIGNATOR :=
+    STRING | ;; namestring (directory assumed where applicable)
+    PATHNAME | ;; pathname
+    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
+    :UID | ;; current UID -- not available on Windows
+    :USER ;; current USER name -- NOT IMPLEMENTED(!)
 
 PATTERN := a string without wildcards, that will be matched exactly
@@ -1768 +1858 @@
 @example
 (:source-registry
-  (:tree "/home/fare/cl/")
+  (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
   :inherit-configuration)
 @end example
-
 
 @section Configuration Directories
@@ -1835 +1924 @@
 
 @section Search Algorithm
+@vindex *default-source-registry-exclusions*
 
 In case that isn't clear, the semantics of the configuration is that
@@ -1897 +1987 @@
    undoes any source registry configuration
    and clears any cache for the search algorithm.
-   You might want to call that before you
-   dump an image that would be resumed with a different configuration,
+   You might want to call this function
+   (or better, @code{clear-configuration})
+   before you dump an image that would be resumed
+   with a different configuration,
    and return an empty configuration.
    Note that this does not include clearing information about
@@ -1909 +2001 @@
    If not, initialize it with the given @var{PARAMETER}.
 @end defun
+
+Every time you use ASDF's @code{find-system}, or
+anything that uses it (such as @code{operate}, @code{load-system}, etc.),
+@code{ensure-source-registry} is called with parameter NIL,
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-source-registry} again,
+or maybe simply to @code{clear-source-registry} (or @code{clear-configuration})
+which will cause the initialization to happen next time around.
 
 
@@ -2190 +2291 @@
     :HOME | ;; designates the user-homedir-pathname ~/
     :USER-CACHE | ;; designates the default location for the user cache
-    :SYSTEM-CACHE | ;; designates the default location for the system cache
-    :CURRENT-DIRECTORY ;; the current directory
+    :SYSTEM-CACHE ;; designates the default location for the system cache
 
 RELATIVE-COMPONENT-DESIGNATOR :=
@@ -2198 +2298 @@
     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
     :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
-    :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute
     :UID | ;; current UID -- not available on Windows
     :USER ;; current USER name -- NOT IMPLEMENTED(!)
@@ -2381 +2480 @@
    undoes any output translation configuration
    and clears any cache for the mapping algorithm.
-   You might want to call that before you
-   dump an image that would be resumed with a different configuration,
+   You might want to call this function
+   (or better, @code{clear-configuration})
+   before you dump an image that would be resumed
+   with a different configuration,
    and return an empty configuration.
    Note that this does not include clearing information about
@@ -2399 +2500 @@
    (calls @code{ensure-output-translations} for the translations).
 @end defun
+
+Every time you use ASDF's @code{output-files}, or
+anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.),
+@code{ensure-output-translations} is called with parameter NIL,
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-output-translations} again,
+or maybe @code{clear-output-translations} (or @code{clear-configuration}),
+which will cause the initialization to happen next time around.
 
 
@@ -2495 +2605 @@
 @defun system-source-directory system-designator
 
-ASDF does not provide a turnkey solution for locating data (or other
-miscellaneous) files that are distributed together with the source code
-of a system.  Programmers can use @code{system-source-directory} to find
-such files.  Returns a pathname object.  The @var{system-designator} may
-be a string, symbol, or ASDF system object.
+ASDF does not provide a turnkey solution for locating
+data (or other miscellaneous) files
+that are distributed together with the source code of a system.
+Programmers can use @code{system-source-directory} to find such files.
+Returns a pathname object.
+The @var{system-designator} may be a string, symbol, or ASDF system object.
 @end defun
 
+@defun clear-system system-designator
+
+It is sometimes useful to force recompilation of a previously loaded system.
+In these cases, it may be useful to @code{(asdf:clear-system :foo)}
+to remove the system from the table of currently loaded systems;
+the next time the system @code{foo} or one that depends on it is re-loaded,
+@code{foo} will then be loaded again.
+Alternatively, you could touch @code{foo.asd} or
+remove the corresponding fasls from the output file cache.
+(It was once conceived that one should provide
+a list of systems the recompilation of which to force
+as the @code{:force} keyword argument to @code{load-system};
+but this has never worked, and though the feature was fixed in ASDF 2.000,
+it remains @code{cerror}'ed out as nobody ever used it.)
+
+Note that this does not and cannot by itself undo the previous loading
+of the system. Common Lisp has no provision for such an operation,
+and its reliance on irreversible side-effects to global datastructures
+makes such a thing impossible in the general case.
+If the software being re-loaded is not conceived with hot upgrade in mind,
+this re-loading may cause many errors, warnings or subtle silent problems,
+as packages, generic function signatures, structures, types, macros, constants, etc.
+are being redefined incompatibly.
+It is up to the user to make sure that reloading is possible and has the desired effect.
+In some cases, extreme measures such as recursively deleting packages,
+unregistering symbols, defining methods on @code{update-instance-for-redefined-class}
+and much more are necessary for reloading to happen smoothly.
+ASDF itself goes through notable pains to make such a hot upgrade possible
+with respect to its own code, and what it does is ridiculously complex;
+look at the beginning of @file{asdf.lisp} to see what it does.
+@end defun
 
 @node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
@@ -2535 +2677 @@
 ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
 
-If you're unsure about whether something is a bug, of for general discussion,
+If you're unsure about whether something is a bug, or for general discussion,
 use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
 
@@ -2757 +2899 @@
 
 
-@subsection Pitfalls of ASDF 2
+@subsection Pitfalls of the transition to ASDF 2
 
 The main pitfalls in upgrading to ASDF 2 seem to be related
@@ -2783 +2925 @@
 @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
 But thou shall not load ABL on top of ASDF 2.
+
+@end itemize
+
+Other issues include the following:
+
+@itemize
 
 @item
@@ -2793 +2941 @@
 moreover when evaluation is desired @code{#.} must be used,
 where it wasn't necessary in the toplevel @code{:pathname} argument.
-
-@end itemize
-
-Other issues include the following:
-
-@itemize
 
 @item
@@ -2818 +2960 @@
 On Windows, only LispWorks supports proper default configuration pathnames
 based on the Windows registry.
-Other implementations make do.
-Windows support is largely untested, so please help report and fix bugs.
+Other implementations make do with environment variables.
+Windows support is somewhat less tested than Unix support.
+Please help report and fix bugs.
+
+@item
+The mechanism by which one customizes a system so that Lisp files
+may use a different extension from the default @file{.lisp} has changed.
+Previously, the pathname for a component was lazily computed when operating on a system,
+and you would
+@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
+  (declare (ignorable component system)) "cl")}.
+Now, the pathname for a component is eagerly computed when defining the system,
+and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))}
+and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
+as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
+
+@findex source-file-type
+
 
 @end itemize
@@ -2840 +2998 @@
 
 Starting with current candidate releases of ASDF 2,
-it should always be a good time to upgrade to a recent version of ASDF.
+it should always be a good time to upgrade to a recent ASDF.
 You may consult with the maintainer for which specific version they recommend,
 but the latest RELEASE should be correct.
@@ -2851 +3009 @@
 @itemize
 @item
-If ASDF isn't installed yet, then @code{(require :asdf)}
+If ASDF isn't loaded yet, then @code{(require :asdf)}
 should load the version of ASDF that is bundled with your system.
 You may have it load some other version configured by the user,
@@ -2859 +3017 @@
 If your system provides a mechanism to hook into @code{CL:REQUIRE},
 then it would be nice to add ASDF to this hook the same way that
-ABCL, CCL, CMUCL, ECL and SBCL do it.
+ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it.
 
 @item
@@ -2877 +3035 @@
 but @file{asdf.asd} if included at all,
 should be secluded from the magic systems,
-in a separate file hierarchy,
-or you may otherwise rename the system and its file to e.g.
+in a separate file hierarchy;
+alternatively, you may provide the system
+after renaming it and its @file{.asd} file to e.g.
 @code{asdf-ecl} and @file{asdf-ecl.asd}, or
 @code{sb-asdf} and @file{sb-asdf.asd}.
@@ -3087 +3246 @@
 (if the component class doesn't specifies a pathname type).
 
+@subsection How do I create a system definition where all the source files have a .cl extension?
+
+First, create a new @code{cl-source-file} subclass that provides an
+initform for the @code{type} slot:
+
+@lisp
+(defclass my-cl-source-file (cl-source-file)
+   ((type :initform "cl")))
+@end lisp
+
+To support both ASDF 1 and ASDF 2,
+you may omit the above @code{type} slot definition and instead define:
+
+@lisp
+(defmethod source-file-type ((f my-cl-source-file) (m module))
+  (declare (ignorable f m))
+  "cl")
+@end lisp
+
+Then make your system use this subclass in preference to the standard
+one:
+
+@lisp
+(defsystem my-cl-system
+  :default-component-class my-cl-source-file
+   ....
+)
+@end lisp
+
+We assume that these definitions are loaded into a package that uses
+@code{ASDF}.
+
+
 
 @node  TODO list, Inspiration, FAQ, Top
@@ -3264 +3456 @@
 whereas this one centres on a protocol for system introspection.
 
-@section kmp's ``The Description of Large Systems'', MIT AI Memu 801
+@section kmp's ``The Description of Large Systems'', MIT AI Memo 801
 
 Available in updated-for-CL form on the web at

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

@@ -48 +48 @@
 #+xcvb (module ())
 
-(cl:in-package :cl)
-(defpackage :asdf-bootstrap (:use :cl))
-(in-package :asdf-bootstrap)
-
-;; Implementation-dependent tweaks
+(cl:in-package :cl-user)
+
+#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
+  ;;; make package if it doesn't exist yet.
+  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
+  (unless (find-package :asdf)
+    (make-package :asdf :use '(:cl)))
+  ;;; Implementation-dependent tweaks
+  ;; (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))
-  #+ecl (require :cmp)
-  #+gcl
-  (eval-when (:compile-toplevel :load-toplevel)
-    (defpackage :asdf-utilities (:use :cl))
-    (defpackage :asdf (:use :cl :asdf-utilities))))
+  #+ecl (require :cmp))
+
+(in-package :asdf)
 
 ;;;; Create packages in a way that is compatible with hot-upgrade.
@@ -70 +72 @@
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111.
-         (existing-asdf (find-package :asdf))
-         (vername '#:*asdf-version*)
-         (versym (and existing-asdf
-                      (find-symbol (string vername) existing-asdf)))
-         (existing-version (and versym (boundp versym) (symbol-value versym)))
+  (defvar *asdf-version* nil)
+  (defvar *upgraded-p* nil)
+  (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147
+         (existing-asdf (fboundp 'find-system))
+         (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
-      #-gcl
       (when existing-asdf
-        (format *trace-output*
+        (format *error-output*
                 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
                 existing-version asdf-version))
       (labels
-          ((rename-away (package)
-             (loop :with name = (package-name package)
-               :for i :from 1 :for new = (format nil "~A.~D" name i)
-               :unless (find-package new) :do
-               (rename-package-name package name new)))
-           (rename-package-name (package old new)
-             (let* ((old-names (cons (package-name package)
-                                     (package-nicknames package)))
-                    (new-names (subst new old old-names :test 'equal))
-                    (new-name (car new-names))
-                    (new-nicknames (cdr new-names)))
-               (rename-package package new-name new-nicknames)))
+          ((unlink-package (package)
+             (let ((u (find-package package)))
+               (when u
+                 (ensure-unintern u
+                   (loop :for s :being :each :present-symbol :in u :collect s))
+                 (loop :for p :in (package-used-by-list u) :do
+                   (unuse-package u p))
+                 (delete-package u))))
            (ensure-exists (name nicknames use)
-             (let* ((previous
-                     (remove-duplicates
-                      (remove-if
-                       #'null
-                       (mapcar #'find-package (cons name nicknames)))
-                      :from-end t)))
-               (cond
-                 (previous
-                  ;; do away with packages with conflicting (nick)names
-                  (map () #'rename-away (cdr previous))
-                  ;; reuse previous package with same name
-                  (let ((p (car previous)))
+             (let ((previous
+                    (remove-duplicates
+                     (mapcar #'find-package (cons name nicknames))
+                     :from-end t)))
+               ;; do away with packages with conflicting (nick)names
+               (map () #'unlink-package (cdr previous))
+               ;; reuse previous package with same name
+               (let ((p (car previous)))
+                 (cond
+                   (p
                     (rename-package p name nicknames)
                     (ensure-use p use)
-                    p))
-                 (t
-                  (make-package name :nicknames nicknames :use use)))))
+                    p)
+                   (t
+                    (make-package name :nicknames nicknames :use use))))))
            (find-sym (symbol package)
              (find-symbol (string symbol) package))
@@ -123 +116 @@
                (when sym
                  (unexport sym package)
-                 (unintern sym package))))
+                 (unintern sym package)
+                 sym)))
            (ensure-unintern (package symbols)
-             (dolist (sym symbols) (remove-symbol sym package)))
+             (loop :with packages = (list-all-packages)
+               :for sym :in symbols
+               :for removed = (remove-symbol sym package)
+               :when removed :do
+               (loop :for p :in packages :do
+                 (when (eq removed (find-sym sym p))
+                   (unintern removed p)))))
            (ensure-shadow (package symbols)
              (shadow symbols package))
@@ -139 +139 @@
                :when sym :do (fmakunbound sym)))
            (ensure-export (package export)
-             (let ((syms (loop :for x :in export :collect
-                           (intern* x package))))
-               (do-external-symbols (sym package)
-                 (unless (member sym syms)
-                   (remove-symbol sym package)))
-               (dolist (sym syms)
-                 (export sym package))))
+             (let ((formerly-exported-symbols nil)
+                   (bothly-exported-symbols nil)
+                   (newly-exported-symbols nil))
+               (loop :for sym :being :each :external-symbol :in package :do
+                 (if (member sym export :test 'string-equal)
+                     (push sym bothly-exported-symbols)
+                     (push sym formerly-exported-symbols)))
+               (loop :for sym :in export :do
+                 (unless (member sym bothly-exported-symbols :test 'string-equal)
+                   (push sym newly-exported-symbols)))
+               (loop :for user :in (package-used-by-list package)
+                 :for shadowing = (package-shadowing-symbols user) :do
+                 (loop :for new :in newly-exported-symbols
+                   :for old = (find-sym new user)
+                   :when (and old (not (member old shadowing)))
+                   :do (unintern old user)))
+               (loop :for x :in newly-exported-symbols :do
+                 (export (intern* x package)))))
            (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
-             (let ((p (ensure-exists name nicknames use)))
+             (let* ((p (ensure-exists name nicknames use)))
                (ensure-unintern p unintern)
                (ensure-shadow p shadow)
@@ -162 +173 @@
                    :fmakunbound ',(append fmakunbound))))
           (pkgdcl
-           :asdf-utilities
-           :nicknames (#:asdf-extensions)
-           :use (#:common-lisp)
-           :unintern (#:split #:make-collector)
-           :export
-           (#:absolute-pathname-p
-            #:aif
-            #:appendf
-            #:asdf-message
-            #:coerce-name
-            #:directory-pathname-p
-            #:ends-with
-            #:ensure-directory-pathname
-            #:getenv
-            #:get-uid
-            #:length=n-p
-            #:merge-pathnames*
-            #:pathname-directory-pathname
-            #:read-file-forms
-            #:remove-keys
-            #:remove-keyword
-            #:resolve-symlinks
-            #:split-string
-            #:component-name-to-pathname-components
-            #:split-name-type
-            #:system-registered-p
-            #:truenamize
-            #:while-collecting))
-          (pkgdcl
            :asdf
-           :use (:common-lisp :asdf-utilities)
+           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
+           :use (:common-lisp)
            :redefined-functions
            (#:perform #:explain #:output-files #:operation-done-p
             #:perform-with-restarts #:component-relative-pathname
-            #:system-source-file #:operate #:find-component)
+            #:system-source-file #:operate #:find-component #:find-system
+            #:apply-output-translations #:translate-pathname* #:resolve-location)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
@@ -208 +192 @@
            (#:defsystem #:oos #:operate #:find-system #:run-shell-command
             #:system-definition-pathname #:find-component ; miscellaneous
-            #:compile-system #:load-system #:test-system
+            #:compile-system #:load-system #:test-system #:clear-system
             #:compile-op #:load-op #:load-source-op
             #:test-op
@@ -216 +200 @@
             #:version-satisfies
 
-            #:input-files #:output-files #:perform ; operation methods
+            #:input-files #:output-files #:output-file #:perform ; operation methods
             #:operation-done-p #:explain
 
@@ -255 +239 @@
             #:operation-on-warnings
             #:operation-on-failure
+            #:component-visited-p
             ;;#:*component-parent-pathname*
             #:*system-definition-search-functions*
@@ -284 +269 @@
             #:remove-entry-from-registry
 
+            #:clear-configuration
             #:initialize-output-translations
             #:disable-output-translations
@@ -292 +278 @@
             #:compile-file-pathname*
             #:enable-asdf-binary-locations-compatibility
-
             #:*default-source-registries*
             #:initialize-source-registry
@@ -298 +283 @@
             #:clear-source-registry
             #:ensure-source-registry
-            #:process-source-registry)))
-        (let* ((version (intern* vername :asdf))
-               (upvar (intern* '#:*upgraded-p* :asdf))
-               (upval0 (and (boundp upvar) (symbol-value upvar)))
-               (upval1 (if existing-version (cons existing-version upval0) upval0)))
-          (eval `(progn
-                   (defparameter ,version ,asdf-version)
-                   (defparameter ,upvar ',upval1))))))))
-
-(in-package :asdf)
+            #:process-source-registry
+            #:system-registered-p
+            #:asdf-message
+
+            ;; Utilities
+            #:absolute-pathname-p
+      ;; #:aif #:it
+            ;; #:appendf
+            #:coerce-name
+            #:directory-pathname-p
+            ;; #:ends-with
+            #:ensure-directory-pathname
+            #:getenv
+            ;; #:get-uid
+            ;; #:length=n-p
+            #:merge-pathnames*
+            #:pathname-directory-pathname
+            #:read-file-forms
+      ;; #:remove-keys
+      ;; #:remove-keyword
+            #:resolve-symlinks
+            #:split-string
+            #:component-name-to-pathname-components
+            #:split-name-type
+            #:subdirectories
+            #:truenamize
+            #:while-collecting)))
+        (setf *asdf-version* asdf-version
+              *upgraded-p* (if existing-version
+                               (cons existing-version *upgraded-p*)
+                               *upgraded-p*))))))
 
 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-#+gcl
-(eval-when (:compile-toplevel :load-toplevel)
-  (defvar *asdf-version* nil)
-  (defvar *upgraded-p* nil))
 (when *upgraded-p*
    #+ecl
@@ -327 +329 @@
            ((m module) added deleted plist &key)
          (declare (ignorable deleted plist))
-         (format *trace-output* "Updating ~A~%" m)
+         (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
          (when (member 'components-by-name added)
-           (compute-module-components-by-name m))))))
+           (compute-module-components-by-name m))
+         (when (and (typep m 'system) (member 'source-file added))
+           (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -343 +347 @@
   "Determine whether or not ASDF resolves symlinks when defining systems.
 
-Defaults to `t`.")
-
-(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.")
+Defaults to T.")
+
+(defvar *compile-file-warnings-behaviour*
+  (or #+clisp :ignore :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*
+  (or #+sbcl :error #+clisp :ignore :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)
@@ -372 +377 @@
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
-(defmacro defgeneric* (name formals &rest options)
-  `(progn
-     #+(or gcl ecl) (fmakunbound ',name)
-     (defgeneric ,name ,formals ,@options)))
-
+(macrolet
+    ((defdef (def* def)
+       `(defmacro ,def* (name formals &rest rest)
+          `(progn
+             #+(or ecl gcl) (fmakunbound ',name)
+             ,(when (and #+ecl (symbolp name))
+                `(declaim (notinline ,name))) ; fails for setf functions on ecl
+             (,',def ,name ,formals ,@rest)))))
+  (defdef defgeneric* defgeneric)
+  (defdef defun* defun))
+
+(defgeneric* find-system (system &optional error-p))
 (defgeneric* perform-with-restarts (operation component))
 (defgeneric* perform (operation component))
@@ -383 +395 @@
 (defgeneric* output-files (operation component))
 (defgeneric* input-files (operation component))
-(defgeneric component-operation-time (operation component))
+(defgeneric* component-operation-time (operation component))
+(defgeneric* operation-description (operation component)
+  (:documentation "returns a phrase that describes performing this operation
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
 
 (defgeneric* system-source-file (system)
   (:documentation "Return the source file in which system is defined."))
 
-(defgeneric component-system (component)
+(defgeneric* component-system (component)
   (:documentation "Find the top-level system containing COMPONENT"))
 
-(defgeneric component-pathname (component)
+(defgeneric* component-pathname (component)
   (:documentation "Extracts the pathname applicable for a particular component."))
 
-(defgeneric component-relative-pathname (component)
+(defgeneric* component-relative-pathname (component)
   (:documentation "Returns a pathname for the component argument intended to be
 interpreted relative to the pathname of that component's parent.
@@ -401 +417 @@
 another pathname in a degenerate way."))
 
-(defgeneric component-property (component property))
-
-(defgeneric (setf component-property) (new-value component property))
-
-(defgeneric version-satisfies (component version))
+(defgeneric* component-property (component property))
+
+(defgeneric* (setf component-property) (new-value component property))
+
+(defgeneric* version-satisfies (component version))
 
 (defgeneric* find-component (base path)
@@ -411 +427 @@
 if BASE is nil, then the component is assumed to be a system."))
 
-(defgeneric source-file-type (component system))
-
-(defgeneric operation-ancestor (operation)
+(defgeneric* source-file-type (component system))
+
+(defgeneric* operation-ancestor (operation)
   (:documentation
    "Recursively chase the operation's parent pointer until we get to
 the head of the tree"))
 
-(defgeneric component-visited-p (operation component)
+(defgeneric* component-visited-p (operation component)
   (:documentation "Returns the value stored by a call to
 VISIT-COMPONENT, if that has been called, otherwise NIL.
@@ -431 +447 @@
 operations needed to be performed."))
 
-(defgeneric visit-component (operation component data)
+(defgeneric* visit-component (operation component data)
   (:documentation "Record DATA as being associated with OPERATION
 and COMPONENT.  This is a side-effecting function:  the association
@@ -439 +455 @@
 non-NIL.  Using the data field is probably very risky; if there is
 already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded."))
-
-(defgeneric (setf visiting-component) (new-value operation component))
-
-(defgeneric component-visiting-p (operation component))
-
-(defgeneric component-depends-on (operation component)
+discarded instead of recorded.
+  Starting with 2.006, TRAVERSE will store an integer in data,
+so that nodes can be sorted in decreasing order of traversal."))
+
+
+(defgeneric* (setf visiting-component) (new-value operation component))
+
+(defgeneric* component-visiting-p (operation component))
+
+(defgeneric* component-depends-on (operation component)
   (:documentation
    "Returns a list of dependencies needed by the component to perform
@@ -462 +481 @@
     list."))
 
-(defgeneric component-self-dependencies (operation component))
-
-(defgeneric traverse (operation component)
+(defgeneric* component-self-dependencies (operation component))
+
+(defgeneric* traverse (operation component)
   (:documentation
 "Generate and return a plan for performing OPERATION on COMPONENT.
@@ -497 +516 @@
   `(let ((it ,test)) (if it ,then ,else)))
 
-(defun pathname-directory-pathname (pathname)
+(defun* pathname-directory-pathname (pathname)
   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
 and NIL NAME, TYPE and VERSION components"
@@ -503 +522 @@
     (make-pathname :name nil :type nil :version nil :defaults pathname)))
 
-(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
+(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
@@ -512 +531 @@
          (defaults (pathname defaults))
          (directory (pathname-directory specified))
-         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
+         (directory
+          (cond
+            #-(or sbcl cmu scl)
+            ((stringp directory) `(:absolute ,directory) directory)
+            #+gcl
+            ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
+             `(:relative ,@directory))
+            ((or (null directory)
+                 (and (consp directory) (member (first directory) '(:absolute :relative))))
+             directory)
+            (t
+             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
@@ -521 +551 @@
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
-          (#-gcl ecase #+gcl case (first directory)
+          (ecase (first directory)
             ((nil)
              (values (pathname-host defaults)
@@ -538 +568 @@
                          (append (pathname-directory defaults) (cdr directory))
                          directory)
-                     (unspecific-handler defaults)))
-            #+gcl
-            (t
-             (assert (stringp (first directory)))
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (append (pathname-directory defaults) directory)
                      (unspecific-handler defaults))))
         (make-pathname :host host :device device :directory directory
@@ -557 +580 @@
   or "or a flag")
 
-(defun first-char (s)
+(defun* first-char (s)
   (and (stringp s) (plusp (length s)) (char s 0)))
 
-(defun last-char (s)
+(defun* last-char (s)
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
 
-(defun asdf-message (format-string &rest format-args)
+(defun* asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
   (apply #'format *verbose-out* format-string format-args))
 
-(defun split-string (string &key max (separator '(#\Space #\Tab)))
+(defun* split-string (string &key max (separator '(#\Space #\Tab)))
   "Split STRING into a list of components separated by
 any of the characters in the sequence SEPARATOR.
@@ -587 +610 @@
           (setf end start))))))
 
-(defun split-name-type (filename)
+(defun* split-name-type (filename)
   (let ((unspecific
          ;; Giving :unspecific as argument to make-pathname is not portable.
@@ -599 +622 @@
           (values name type)))))
 
-(defun component-name-to-pathname-components (s &optional force-directory)
+(defun* component-name-to-pathname-components (s &key force-directory force-relative)
   "Splits the path string S, returning three values:
 A flag that is either :absolute or :relative, indicating
@@ -616 +639 @@
 pathnames."
   (check-type s string)
+  (when (find #\: s)
+    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
   (let* ((components (split-string s :separator "/"))
          (last-comp (car (last components))))
@@ -621 +646 @@
         (if (equal (first components) "")
             (if (equal (first-char s) #\/)
-                (values :absolute (cdr components))
+                (progn
+                  (when force-relative
+                    (error "absolute pathname designator not allowed: ~S" s))
+                  (values :absolute (cdr components)))
                 (values :relative nil))
           (values :relative components))
@@ -633 +661 @@
          (values relative (butlast components) last-comp))))))
 
-(defun remove-keys (key-names args)
+(defun* remove-keys (key-names args)
   (loop :for (name val) :on args :by #'cddr
     :unless (member (symbol-name name) key-names
@@ -639 +667 @@
     :append (list name val)))
 
-(defun remove-keyword (key args)
+(defun* remove-keyword (key args)
   (loop :for (k v) :on args :by #'cddr
     :unless (eq k key)
     :append (list k v)))
 
-(defun getenv (x)
-  #+abcl
-  (ext:getenv x)
-  #+sbcl
-  (sb-ext:posix-getenv x)
-  #+clozure
-  (ccl:getenv x)
-  #+clisp
-  (ext:getenv x)
-  #+cmu
-  (cdr (assoc (intern x :keyword) ext:*environment-list*))
-  #+lispworks
-  (lispworks:environment-variable x)
-  #+allegro
-  (sys:getenv x)
-  #+gcl
-  (system:getenv x)
-  #+ecl
-  (si:getenv x))
-
-(defun directory-pathname-p (pathname)
+(defun* getenv (x)
+  (#+abcl ext:getenv
+   #+allegro sys:getenv
+   #+clisp ext:getenv
+   #+clozure ccl:getenv
+   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
+   #+ecl si:getenv
+   #+gcl system:getenv
+   #+lispworks lispworks:environment-variable
+   #+sbcl sb-ext:posix-getenv
+   x))
+
+(defun* directory-pathname-p (pathname)
   "Does PATHNAME represent a directory?
 
@@ -673 +693 @@
 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)))
-
-(defun ensure-directory-pathname (pathspec)
+  (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."
   (cond
@@ -687 +710 @@
     (error "Invalid pathname designator ~S" pathspec))
    ((wild-pathname-p pathspec)
-    (error "Can't reliably convert wild pathnames."))
+    (error "Can't reliably convert wild pathname ~S" pathspec))
    ((directory-pathname-p pathspec)
     pathspec)
@@ -697 +720 @@
                    :defaults pathspec))))
 
-(defun absolute-pathname-p (pathspec)
-  (eq :absolute (car (pathname-directory (pathname pathspec)))))
-
-(defun length=n-p (x n) ;is it that (= (length x) n) ?
+(defun* absolute-pathname-p (pathspec)
+  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
+
+(defun* length=n-p (x n) ;is it that (= (length x) n) ?
   (check-type n (integer 0 *))
   (loop
@@ -709 +732 @@
       ((not (consp l)) (return nil)))))
 
-(defun ends-with (s suffix)
+(defun* ends-with (s suffix)
   (check-type s string)
   (check-type suffix string)
@@ -716 +739 @@
          (string-equal s suffix :start1 start))))
 
-(defun read-file-forms (file)
+(defun* read-file-forms (file)
   (with-open-file (in file)
     (loop :with eof = (list nil)
@@ -725 +748 @@
 #-(and (or win32 windows mswindows mingw32) (not cygwin))
 (progn
-#+clisp (defun get-uid () (posix:uid))
-#+sbcl (defun get-uid () (sb-unix:unix-getuid))
-#+cmu (defun get-uid () (unix:unix-getuid))
-#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
-         '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
-#+ecl (defun get-uid ()
-        #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
-            '(ffi:c-inline () () :int "getuid()" :one-liner t)
-            '(ext::getuid)))
-#+allegro (defun get-uid () (excl.osi:getuid))
-#-(or cmu sbcl clisp allegro ecl)
-(defun get-uid ()
-  (let ((uid-string
-         (with-output-to-string (*verbose-out*)
-           (run-shell-command "id -ur"))))
-    (with-input-from-string (stream uid-string)
-      (read-line stream)
-      (handler-case (parse-integer (read-line stream))
-        (error () (error "Unable to find out user ID")))))))
-
-(defun pathname-root (pathname)
+  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
+                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
+  (defun* get-uid ()
+    #+allegro (excl.osi:getuid)
+    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
+            :for f = (ignore-errors (read-from-string s))
+                  :when f :return (funcall f))
+    #+(or cmu scl) (unix:unix-getuid)
+    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
+                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
+                   '(ext::getuid))
+    #+sbcl (sb-unix:unix-getuid)
+    #-(or allegro clisp cmu ecl sbcl scl)
+    (let ((uid-string
+           (with-output-to-string (*verbose-out*)
+             (run-shell-command "id -ur"))))
+      (with-input-from-string (stream uid-string)
+        (read-line stream)
+        (handler-case (parse-integer (read-line stream))
+          (error () (error "Unable to find out user ID")))))))
+
+(defun* pathname-root (pathname)
   (make-pathname :host (pathname-host pathname)
                  :device (pathname-device pathname)
@@ -751 +775 @@
                  :name nil :type nil :version nil))
 
-(defun truenamize (p)
+(defun* probe-file* (p)
+  "when given a pathname P, probes the filesystem for a file or directory
+with given pathname and if it exists return its truename."
+  (etypecase p
+   (null nil)
+   (string (probe-file* (parse-namestring p)))
+   (pathname (unless (wild-pathname-p p)
+               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
+               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
+         '(ignore-errors (truename p)))))))
+
+(defun* truenamize (p)
   "Resolve as much of a pathname as possible"
   (block nil
@@ -758 +793 @@
            (directory (pathname-directory p)))
       (when (typep p 'logical-pathname) (return p))
-      (ignore-errors (return (truename p)))
-      #-sbcl (when (stringp directory) (return p))
+      (let ((found (probe-file* p)))
+        (when found (return found)))
+      #-(or sbcl cmu) (when (stringp directory) (return p))
       (when (not (eq :absolute (car directory))) (return p))
-      (let ((sofar (ignore-errors (truename (pathname-root p)))))
+      (let ((sofar (probe-file* (pathname-root p))))
         (unless sofar (return p))
         (flet ((solution (directories)
@@ -773 +809 @@
           (loop :for component :in (cdr directory)
             :for rest :on (cdr directory)
-            :for more = (ignore-errors
-                          (truename
-                           (merge-pathnames*
-                            (make-pathname :directory `(:relative ,component))
-                            sofar))) :do
+            :for more = (probe-file*
+                         (merge-pathnames*
+                          (make-pathname :directory `(:relative ,component))
+                          sofar)) :do
             (if more
                 (setf sofar more)
@@ -784 +819 @@
             (return (solution nil))))))))
 
-(defun resolve-symlinks (path)
+(defun* resolve-symlinks (path)
   #-allegro (truenamize path)
   #+allegro (excl:pathname-resolve-symbolic-links path))
 
-(defun default-directory ()
+(defun* default-directory ()
   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
 
-(defun lispize-pathname (input-file)
+(defun* lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
@@ -798 +833 @@
                  :name :wild :type :wild :version :wild))
 
-(defun wilden (path)
+(defun* wilden (path)
   (merge-pathnames* *wild-path* path))
 
-(defun directorize-pathname-host-device (pathname)
+(defun* directorize-pathname-host-device (pathname)
   (let* ((root (pathname-root pathname))
          (wild-root (wilden root))
@@ -814 +849 @@
                          root-namestring)))
     (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string t)
+        (component-name-to-pathname-components root-string :force-directory t)
       (declare (ignore relative filename))
       (let ((new-base
@@ -838 +873 @@
                 duplicate-names-name
                 error-component error-operation
-                module-components module-components-by-name)
+                module-components module-components-by-name
+                circular-dependency-components)
          (ftype (function (t t) t) (setf module-components-by-name)))
 
@@ -857 +893 @@
 
 (define-condition circular-dependency (system-definition-error)
-  ((components :initarg :components :reader circular-dependency-components)))
+  ((components :initarg :components :reader circular-dependency-components))
+  (:report (lambda (c s)
+             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
 
 (define-condition duplicate-names (system-definition-error)
@@ -893 +931 @@
          "Component name: designator for a string composed of portable pathname characters")
    (version :accessor component-version :initarg :version)
+   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
+   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
+   ;; http://www.cliki.net/poiu
+   (load-dependencies :accessor component-load-dependencies :initform nil)
+   ;; In the ASDF object model, dependencies exist between *actions*
+   ;; (an action is a pair of operation and component). They are represented
+   ;; alists of operations to dependencies (other actions) in each component.
+   ;; There are two kinds of dependencies, each stored in its own slot:
+   ;; in-order-to and do-first dependencies. These two kinds are related to
+   ;; the fact that some actions modify the filesystem,
+   ;; whereas other actions modify the current image, and
+   ;; this implies a difference in how to interpret timestamps.
+   ;; in-order-to dependencies will trigger re-performing the action
+   ;; when the timestamp of some dependency
+   ;; makes the timestamp of current action out-of-date;
+   ;; do-first dependencies do not trigger such re-performing.
+   ;; Therefore, a FASL must be recompiled if it is obsoleted
+   ;; by any of its FASL dependencies (in-order-to); but
+   ;; it needn't be recompiled just because one of these dependencies
+   ;; hasn't yet been loaded in the current image (do-first).
+   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
    (in-order-to :initform nil :initarg :in-order-to
                 :accessor component-in-order-to)
-   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
-   (load-dependencies :accessor component-load-dependencies :initform nil)
-   ;; XXX crap name, but it's an official API name!
    (do-first :initform nil :initarg :do-first
              :accessor component-do-first)
@@ -916 +972 @@
                :initform nil)))
 
-(defun component-find-path (component)
+(defun* component-find-path (component)
   (reverse
    (loop :for c = component :then (component-parent c)
@@ -932 +988 @@
           (call-next-method c nil) (missing-required-by c)))
 
-(defun sysdef-error (format &rest arguments)
+(defun* sysdef-error (format &rest arguments)
   (error 'formatted-system-definition-error :format-control
          format :format-arguments arguments))
@@ -939 +995 @@
 
 (defmethod print-object ((c missing-component) s)
-   (format s "~@<component ~S not found~
-             ~@[ in ~A~]~@:>"
+  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
           (missing-requires c)
           (when (missing-parent c)
@@ -946 +1001 @@
 
 (defmethod print-object ((c missing-component-of-version) s)
-  (format s "~@<component ~S does not match version ~A~
-              ~@[ in ~A~]~@:>"
-           (missing-requires c)
-           (missing-version c)
-           (when (missing-parent c)
-             (component-name (missing-parent c)))))
+  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
+          (missing-requires c)
+          (missing-version c)
+          (when (missing-parent c)
+            (component-name (missing-parent c)))))
 
 (defmethod component-system ((component component))
@@ -960 +1014 @@
 (defvar *default-component-class* 'cl-source-file)
 
-(defun compute-module-components-by-name (module)
+(defun* compute-module-components-by-name (module)
   (let ((hash (make-hash-table :test 'equal)))
     (setf (module-components-by-name module) hash)
@@ -990 +1044 @@
     :accessor module-default-component-class)))
 
-(defun component-parent-pathname (component)
+(defun* component-parent-pathname (component)
   ;; No default anymore (in particular, no *default-pathname-defaults*).
   ;; If you force component to have a NULL pathname, you better arrange
@@ -1007 +1061 @@
              (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))
+          (error "Invalid relative pathname ~S for component ~S"
+                 pathname (component-find-path component)))
         (setf (slot-value component 'absolute-pathname) pathname)
         pathname)))
@@ -1031 +1086 @@
             :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)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1058 +1114 @@
 ;;;; Finding systems
 
-(defun make-defined-systems-table ()
+(defun* make-defined-systems-table ()
   (make-hash-table :test 'equal))
 
@@ -1068 +1124 @@
 of which is a system object.")
 
-(defun coerce-name (name)
+(defun* coerce-name (name)
   (typecase name
     (component (component-name name))
@@ -1075 +1131 @@
     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
 
-(defun system-registered-p (name)
+(defun* system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
 
-(defun clear-system (name)
+(defun* clear-system (name)
   "Clear the entry for a system in the database of systems previously loaded.
 Note that this does NOT in any way cause the code of the system to be unloaded."
@@ -1089 +1145 @@
   (setf (gethash (coerce-name name) *defined-systems*) nil))
 
-(defun map-systems (fn)
+(defun* map-systems (fn)
   "Apply FN to each defined system.
 
@@ -1107 +1163 @@
   '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
 
-(defun system-definition-pathname (system)
+(defun* system-definition-pathname (system)
   (let ((system-name (coerce-name system)))
     (or
@@ -1131 +1187 @@
 ")
 
-(defun probe-asd (name defaults)
+(defun* probe-asd (name defaults)
   (block nil
     (when (directory-pathname-p defaults)
@@ -1152 +1208 @@
               (return (pathname target)))))))))
 
-(defun sysdef-central-registry-search (system)
+(defun* sysdef-central-registry-search (system)
   (let ((name (coerce-name system))
         (to-remove nil)
@@ -1170 +1226 @@
                                    (message
                                     (format nil
-                                            "~@<While searching for system ~S: ~S evaluated ~
-to ~S which is not a directory.~@:>"
+                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
                                             system dir defaults)))
                               (error message))
@@ -1194 +1249 @@
                           (subseq *central-registry* (1+ position))))))))))
 
-(defun make-temporary-package ()
+(defun* make-temporary-package ()
   (flet ((try (counter)
            (ignore-errors
@@ -1203 +1258 @@
          (package package))))
 
-(defun safe-file-write-date (pathname)
+(defun* safe-file-write-date (pathname)
   ;; If FILE-WRITE-DATE returns NIL, it's possible that
   ;; the user or some other agent has deleted an input file.
@@ -1214 +1269 @@
   (or (and pathname (probe-file pathname) (file-write-date pathname))
       (progn
-        (when pathname
+        (when (and pathname *asdf-verbose*)
           (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
                 pathname))
         0)))
 
-(defun find-system (name &optional (error-p t))
+(defmethod find-system (name &optional (error-p t))
+  (find-system (coerce-name name) error-p))
+
+(defmethod find-system ((name string) &optional (error-p t))
   (catch 'find-system
-    (let* ((name (coerce-name name))
-           (in-memory (system-registered-p name))
+    (let* ((in-memory (system-registered-p name))
            (on-disk (system-definition-pathname name)))
       (when (and on-disk
@@ -1241 +1298 @@
             (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)
+        (cond
+          (in-memory
+           (when on-disk
+             (setf (car in-memory) (safe-file-write-date on-disk)))
+           (cdr in-memory))
+          (error-p
+           (error 'missing-component :requires name)))))))
+
+(defun* register-system (name system)
   (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
   (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)))))
+(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
+  (setf fallback (coerce-name fallback)
+        source-file (or source-file *compile-file-truename* *load-truename*)
+        requested (coerce-name requested))
+  (when (equal requested fallback)
+    (let* ((registered (cdr (gethash fallback *defined-systems*)))
+           (system (or registered
+                       (apply 'make-instance 'system
+            :name fallback :source-file source-file keys))))
+      (unless registered
+        (register-system fallback system))
+      (throw 'find-system system))))
+
+(defun* sysdef-find-asdf (name)
+  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
 
 
@@ -1318 +1381 @@
   (source-file-explicit-type component))
 
-(defun merge-component-name-type (name &key type defaults)
+(defun* merge-component-name-type (name &key type defaults)
   ;; The defaults are required notably because they provide the default host
   ;; to the below make-pathname, which may crucially matter to people using
@@ -1325 +1388 @@
   ;; but that should only matter if you either (a) use absolute pathnames, or
   ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
-  ;; ASDF-UTILITIES:MERGE-PATHNAMES*
+  ;; ASDF:MERGE-PATHNAMES*
   (etypecase name
     (pathname
@@ -1333 +1396 @@
     (string
      (multiple-value-bind (relative path filename)
-         (component-name-to-pathname-components name (eq type :directory))
+         (component-name-to-pathname-components name :force-directory (eq type :directory)
+                                                :force-relative t)
        (multiple-value-bind (name type)
            (cond
@@ -1370 +1434 @@
    ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    ;;   to force systems named in a given list
-   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
+   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
    (forced :initform nil :initarg :force :accessor operation-forced)
    (original-initargs :initform nil :initarg :original-initargs
@@ -1390 +1454 @@
   (values))
 
-(defun node-for (o c)
+(defun* node-for (o c)
   (cons (class-name (class-of o)) c))
 
@@ -1399 +1463 @@
 
 
-(defun make-sub-operation (c o dep-c dep-o)
+(defun* make-sub-operation (c o dep-c dep-o)
   "C is a component, O is an operation, DEP-C is another
 component, and DEP-O, confusingly enough, is an operation
@@ -1544 +1608 @@
 recursive calls to traverse.")
 
-(defgeneric do-traverse (operation component collect))
-
-(defun %do-one-dep (operation c collect required-op required-c required-v)
+(defgeneric* do-traverse (operation component collect))
+
+(defun* %do-one-dep (operation c collect required-op required-c required-v)
   ;; collects a partial plan that results from performing required-op
   ;; on required-c, possibly with a required-vERSION
@@ -1562 +1626 @@
     (do-traverse op dep-c collect)))
 
-(defun do-one-dep (operation c collect required-op required-c required-v)
-  ;; this function is a thin, error-handling wrapper around
-  ;; %do-one-dep.  Returns a partial plan per that function.
+(defun* do-one-dep (operation c collect required-op required-c required-v)
+  ;; this function is a thin, error-handling wrapper around %do-one-dep.
+  ;; Collects a partial plan per that function.
   (loop
     (restart-case
@@ -1572 +1636 @@
         :report (lambda (s)
                   (format s "~@<Retry loading component ~S.~@:>"
-                          required-c))
+                          (component-find-path required-c)))
         :test
         (lambda (c)
-          #|
-          (print (list :c1 c (typep c 'missing-dependency)))
-          (when (typep c 'missing-dependency)
-          (print (list :c2 (missing-requires c) required-c
-          (equalp (missing-requires c)
-          required-c))))
-          |#
           (or (null c)
               (and (typep c 'missing-dependency)
@@ -1587 +1644 @@
                            required-c))))))))
 
-(defun do-dep (operation c collect op dep)
+(defun* do-dep (operation c collect op dep)
   ;; type of arguments uncertain:
   ;; op seems to at least potentially be a symbol, rather than an operation
@@ -1626 +1683 @@
            flag))))
 
-(defun do-collect (collect x)
+(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
+
+(defun* do-collect (collect x)
   (funcall collect x))
 
@@ -1711 +1770 @@
                  (do-collect collect (cons operation c)))))
              (setf (visiting-component operation c) nil)))
-      (visit-component operation c flag)
+      (visit-component operation c (when flag (incf *visit-count*)))
       flag))
 
-(defun flatten-tree (l)
+(defun* flatten-tree (l)
   ;; You collected things into a list.
   ;; Most elements are just things to collect again.
@@ -1741 +1800 @@
   (flatten-tree
    (while-collecting (collect)
-     (do-traverse operation c #'collect))))
+     (let ((*visit-count* 0))
+       (do-traverse operation c #'collect)))))
 
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
-   "~@<required method PERFORM not implemented ~
-    for operation ~A, component ~A~@:>"
+   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    (class-of operation) (class-of c)))
 
@@ -1754 +1813 @@
 
 (defmethod explain ((operation operation) (component component))
-  (asdf-message "~&;;; ~A on ~A~%" operation component))
+  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
+
+(defmethod operation-description (operation component)
+  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1768 +1830 @@
           :initform #-ecl nil #+ecl '(:system-p t))))
 
+(defun output-file (operation component)
+  "The unique output file of performing OPERATION on COMPONENT"
+  (let ((files (output-files operation component)))
+    (assert (length=n-p files 1))
+    (first files)))
+
 (defmethod perform :before ((operation compile-op) (c source-file))
   (map nil #'ensure-directories-exist (output-files operation c)))
@@ -1784 +1852 @@
         (get-universal-time)))
 
-(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
+(declaim (ftype (function ((or pathname string)
+                           &rest t &key (:output-file t) &allow-other-keys)
                           (values t t t))
                 compile-file*))
@@ -1793 +1862 @@
   #-:broken-fasl-loader
   (let ((source-file (component-pathname c))
-        (output-file (car (output-files operation c)))
+        ;; on some implementations, there are more than one output-file,
+        ;; but the first one should always be the primary fasl that gets loaded.
+        (output-file (first (output-files operation c)))
         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
@@ -1836 +1907 @@
   nil)
 
+(defmethod operation-description ((operation compile-op) component)
+  (declare (ignorable operation))
+  (format nil "compiling component ~S" (component-find-path component)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1845 +1919 @@
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  #-ecl (mapcar #'load (input-files o c))
-  #+ecl (loop :for i :in (input-files o c)
-          :unless (string= (pathname-type i) "fas")
-          :collect (let ((output (compile-file-pathname (lispize-pathname i))))
-                     (load output))))
+  (map () #'load
+       #-ecl (input-files o c)
+       #+ecl (loop :for i :in (input-files o c)
+               :unless (string= (pathname-type i) "fas")
+               :collect (compile-file-pathname (lispize-pathname i)))))
 
 (defmethod perform-with-restarts (operation component)
@@ -1912 +1986 @@
         (call-next-method)))
 
+(defmethod operation-description ((operation load-op) component)
+  (declare (ignorable operation))
+  (format nil "loading component ~S" (component-find-path component)))
+
+
 ;;;; -------------------------------------------------------------------------
 ;;;; load-source-op
@@ -1949 +2028 @@
              (component-property c 'last-loaded-as-source)))
       nil t))
+
+(defmethod operation-description ((operation load-source-op) component)
+  (declare (ignorable operation))
+  (format nil "loading component ~S" (component-find-path component)))
 
 
@@ -1999 +2082 @@
                 :report
                 (lambda (s)
-                  (format s "~@<Retry performing ~S on ~S.~@:>"
-                          op component)))
+                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
               (accept ()
                 :report
                 (lambda (s)
-                  (format s "~@<Continue, treating ~S on ~S as ~
-                                   having been successful.~@:>"
-                          op component))
+                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
+                          (operation-description op component)))
                 (setf (gethash (type-of op)
                                (component-operation-times component))
                       (get-universal-time))
-                (return)))))))
-    op))
-
-(defun oos (operation-class system &rest args &key force verbose version
+                (return))))))
+      (values op steps))))
+
+(defun* oos (operation-class system &rest args &key force verbose version
             &allow-other-keys)
   (declare (ignore force verbose version))
@@ -2043 +2124 @@
         operate-docstring))
 
-(defun load-system (system &rest args &key force verbose version
+(defun* load-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
 details."
   (declare (ignore force verbose version))
-  (apply #'operate 'load-op system args))
-
-(defun compile-system (system &rest args &key force verbose version
+  (apply #'operate 'load-op system args)
+  t)
+
+(defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
 for details."
   (declare (ignore force verbose version))
-  (apply #'operate 'compile-op system args))
-
-(defun test-system (system &rest args &key force verbose version
+  (apply #'operate 'compile-op system args)
+  t)
+
+(defun* test-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
 details."
   (declare (ignore force verbose version))
-  (apply #'operate 'test-op system args))
+  (apply #'operate 'test-op system args)
+  t)
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Defsystem
 
-(defun load-pathname ()
+(defun* load-pathname ()
   (let ((pn (or *load-pathname* *compile-file-pathname*)))
     (if *resolve-symlinks*
@@ -2073 +2157 @@
         pn)))
 
-(defun determine-system-pathname (pathname pathname-supplied-p)
+(defun* determine-system-pathname (pathname pathname-supplied-p)
   ;; The defsystem macro calls us to determine
   ;; the pathname of a system as follows:
@@ -2082 +2166 @@
          (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
     (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
-        file-pathname
+        directory-pathname
         (default-directory))))
 
@@ -2089 +2173 @@
                             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
@@ -2113 +2197 @@
                ',component-options))))))
 
-(defun class-for-type (parent type)
+(defun* class-for-type (parent type)
   (or (loop :for symbol :in (list
                              (unless (keywordp type) type)
@@ -2126 +2210 @@
       (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
 
-(defun maybe-add-tree (tree op1 op2 c)
+(defun* maybe-add-tree (tree op1 op2 c)
   "Add the node C at /OP1/OP2 in TREE, unless it's there already.
 Returns the new tree (which probably shares structure with the old one)"
@@ -2141 +2225 @@
         (acons op1 (list (list op2 c)) tree))))
 
-(defun union-of-dependencies (&rest deps)
+(defun* union-of-dependencies (&rest deps)
   (let ((new-tree nil))
     (dolist (dep deps)
@@ -2154 +2238 @@
 (defvar *serial-depends-on* nil)
 
-(defun sysdef-error-component (msg type name value)
+(defun* sysdef-error-component (msg type name value)
   (sysdef-error (concatenate 'string msg
                              "~&The value specified for ~(~A~) ~A is ~S")
                 type name value))
 
-(defun check-component-input (type name weakly-depends-on
+(defun* check-component-input (type name weakly-depends-on
                               depends-on components in-order-to)
   "A partial test of the values of a component."
@@ -2175 +2259 @@
                             type name in-order-to)))
 
-(defun %remove-component-inline-methods (component)
+(defun* %remove-component-inline-methods (component)
   (dolist (name +asdf-methods+)
     (map ()
@@ -2187 +2271 @@
   (setf (component-inline-methods component) nil))
 
-(defun %define-component-inline-methods (ret rest)
+(defun* %define-component-inline-methods (ret rest)
   (dolist (name +asdf-methods+)
     (let ((keyword (intern (symbol-name name) :keyword)))
@@ -2201 +2285 @@
            (component-inline-methods ret)))))))
 
-(defun %refresh-component-inline-methods (component rest)
+(defun* %refresh-component-inline-methods (component rest)
   (%remove-component-inline-methods component)
   (%define-component-inline-methods component rest))
 
-(defun parse-component-form (parent options)
+(defun* parse-component-form (parent options)
   (destructuring-bind
         (type name &rest rest &key
@@ -2286 +2370 @@
 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
 
-(defun run-shell-command (control-string &rest args)
+(defun* run-shell-command (control-string &rest args)
   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 synchronously execute the result using a Bourne-compatible shell, with
@@ -2358 +2442 @@
   (system-source-file (find-system system-name)))
 
-(defun system-source-directory (system-designator)
+(defun* system-source-directory (system-designator)
   "Return a pathname object corresponding to the
 directory in which the system specification (.asd file) is
@@ -2366 +2450 @@
                  :defaults (system-source-file system-designator)))
 
-(defun relativize-directory (directory)
+(defun* relativize-directory (directory)
   (cond
     ((stringp directory)
@@ -2375 +2459 @@
      directory)))
 
-(defun relativize-pathname-directory (pathspec)
+(defun* relativize-pathname-directory (pathspec)
   (let ((p (pathname pathspec)))
     (make-pathname
@@ -2381 +2465 @@
      :defaults p)))
 
-(defun system-relative-pathname (system name &key type)
+(defun* system-relative-pathname (system name &key type)
   (merge-pathnames*
    (merge-component-name-type name :type type)
@@ -2394 +2478 @@
 
 (defparameter *implementation-features*
-  '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
-    :corman :cormanlisp :armedbear :gcl :ecl :scl))
+  '((:acl :allegro)
+    (:lw :lispworks)
+    (:digitool) ; before clozure, so it won't get preempted by ccl
+    (:ccl :clozure)
+    (:corman :cormanlisp)
+    (:abcl :armedbear)
+    :sbcl :cmu :clisp :gcl :ecl :scl))
 
 (defparameter *os-features*
-  '((:windows :mswindows :win32 :mingw32)
+  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
     (:solaris :sunos)
-    :linux ;; for GCL at least, must appear before :bsd.
-    :macosx :darwin :apple
+    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
+    (:macosx :darwin :darwin-target :apple)
     :freebsd :netbsd :openbsd :bsd
     :unix))
 
 (defparameter *architecture-features*
-  '((:x86-64 :amd64 :x86_64 :x8664-target)
-    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
-    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
-    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
-
-
-(defun lisp-version-string ()
+  '((:amd64 :x86-64 :x86_64 :x8664-target)
+    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+    :hppa64
+    :hppa
+    (:ppc64 :ppc64-target)
+    (:ppc32 :ppc32-target :ppc :powerpc)
+    :sparc64
+    (:sparc32 :sparc)
+    (:arm :arm-target)
+    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
+
+(defun* lisp-version-string ()
   (let ((s (lisp-implementation-version)))
     (declare (ignorable s))
@@ -2429 +2523 @@
     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     #+clisp (subseq s 0 (position #\space s))
-    #+clozure (format nil "~d.~d-fasl~d"
+    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
                       ccl::*openmcl-major-version*
                       ccl::*openmcl-minor-version*
@@ -2447 +2541 @@
           ecl gcl lispworks mcl sbcl scl) s))
 
-(defun first-feature (features)
+(defun* first-feature (features)
   (labels
       ((fp (thing)
@@ -2463 +2557 @@
       :when (fp f) :return :it)))
 
-(defun implementation-type ()
+(defun* implementation-type ()
   (first-feature *implementation-features*))
 
-(defun implementation-identifier ()
+(defun* implementation-identifier ()
   (labels
       ((maybe-warn (value fstring &rest args)
@@ -2481 +2575 @@
                             *architecture-features*))
           (version (maybe-warn (lisp-version-string)
-                               "Don't know how to get Lisp ~
-                                          implementation version.")))
+                               "Don't know how to get Lisp implementation version.")))
       (substitute-if
        #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
@@ -2496 +2589 @@
   #-(or unix cygwin) #\;)
 
-(defun user-homedir ()
+(defun* user-homedir ()
   (truename (user-homedir-pathname)))
 
-(defun try-directory-subpath (x sub &key type)
+(defun* try-directory-subpath (x sub &key type)
   (let* ((p (and x (ensure-directory-pathname x)))
-         (tp (and p (ignore-errors (truename p))))
+         (tp (and p (probe-file* p)))
          (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
-         (ts (and sp (ignore-errors (truename sp)))))
+         (ts (and sp (probe-file* sp))))
     (and ts (values sp ts))))
-(defun user-configuration-directories ()
+(defun* user-configuration-directories ()
   (remove-if
    #'null
@@ -2518 +2611 @@
            ,(try (getenv "APPDATA") "common-lisp/config/"))
        ,(try (user-homedir) ".config/common-lisp/")))))
-(defun system-configuration-directories ()
+(defun* system-configuration-directories ()
   (remove-if
    #'null
@@ -2528 +2621 @@
         ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     (list #p"/etc/common-lisp/"))))
-(defun in-first-directory (dirs x)
+(defun* in-first-directory (dirs x)
   (loop :for dir :in dirs
-    :thereis (and dir (ignore-errors
-                        (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
-(defun in-user-configuration-directory (x)
+    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
+(defun* in-user-configuration-directory (x)
   (in-first-directory (user-configuration-directories) x))
-(defun in-system-configuration-directory (x)
+(defun* in-system-configuration-directory (x)
   (in-first-directory (system-configuration-directories) x))
 
-(defun configuration-inheritance-directive-p (x)
+(defun* configuration-inheritance-directive-p (x)
   (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
     (or (member x kw)
         (and (length=n-p x 1) (member (car x) kw)))))
 
-(defun validate-configuration-form (form tag directive-validator
+(defun* validate-configuration-form (form tag directive-validator
                                     &optional (description tag))
   (unless (and (consp form) (eq (car form) tag))
@@ -2557 +2649 @@
   form)
 
-(defun validate-configuration-file (file validator description)
+(defun* validate-configuration-file (file validator description)
   (let ((forms (read-file-forms file)))
     (unless (length=n-p forms 1)
@@ -2563 +2655 @@
     (funcall validator (car forms))))
 
-(defun hidden-file-p (pathname)
+(defun* hidden-file-p (pathname)
   (equal (first-char (pathname-name pathname)) #\.))
 
-(defun validate-configuration-directory (directory tag validator)
+(defun* validate-configuration-directory (directory tag validator)
   (let ((files (sort (ignore-errors
                        (remove-if
@@ -2604 +2696 @@
   *user-cache*)
 
-(defun output-translations ()
+(defun* output-translations ()
   (car *output-translations*))
 
-(defun (setf output-translations) (new-value)
+(defun* (setf output-translations) (new-value)
   (setf *output-translations*
         (list
@@ -2618 +2710 @@
   new-value)
 
-(defun output-translations-initialized-p ()
+(defun* output-translations-initialized-p ()
   (and *output-translations* t))
 
-(defun clear-output-translations ()
+(defun* clear-output-translations ()
   "Undoes any initialization of the output translations.
 You might want to call that before you dump an image that would be resumed
@@ -2628 +2720 @@
   (values))
 
-(defparameter *wild-asd*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type "asd" :version :newest))
-
-
-(declaim (ftype (function (t &optional boolean) (or null pathname))
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
+                          (values (or null pathname) &optional))
                 resolve-location))
 
-(defun resolve-relative-location-component (super x &optional wildenp)
+(defun* resolve-relative-location-component (super x &key directory wilden)
   (let* ((r (etypecase x
               (pathname x)
               (string x)
               (cons
-               (let ((car (resolve-relative-location-component super (car x) nil)))
+               (return-from resolve-relative-location-component
                  (if (null (cdr x))
-                     car
-                     (let ((cdr (resolve-relative-location-component
-                                 (merge-pathnames* car super) (cdr x) wildenp)))
+                     (resolve-relative-location-component
+                      super (car x) :directory directory :wilden wilden)
+                     (let* ((car (resolve-relative-location-component
+                                  super (car x) :directory t :wilden nil))
+                            (cdr (resolve-relative-location-component
+                                  (merge-pathnames* car super) (cdr x)
+                                  :directory directory :wilden wilden)))
                        (merge-pathnames* cdr car)))))
               ((eql :default-directory)
@@ -2653 +2745 @@
               #-(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)))
+         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
+         (s (if (or (pathnamep x) (not wilden)) d (wilden 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)
+(defun* resolve-absolute-location-component (x &key directory wilden)
   (let* ((r
           (etypecase x
             (pathname x)
-            (string (ensure-directory-pathname x))
+            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
             (cons
-             (let ((car (resolve-absolute-location-component (car x) nil)))
+             (return-from resolve-absolute-location-component
                (if (null (cdr x))
-                   car
-                   (let ((cdr (resolve-relative-location-component
-                               car (cdr x) wildenp)))
-                     (merge-pathnames* cdr car)))))
+                   (resolve-absolute-location-component
+                    (car x) :directory directory :wilden wilden)
+                   (let* ((car (resolve-absolute-location-component
+                                (car x) :directory t :wilden nil))
+                          (cdr (resolve-relative-location-component
+                                car (cdr x) :directory directory :wilden wilden)))
+                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
             ((eql :root)
              ;; special magic! we encode such paths as relative pathnames,
              ;; but it means "relative to the root of the source pathname's host and device".
              (return-from resolve-absolute-location-component
-               (make-pathname :directory '(:relative))))
+               (let ((p (make-pathname :directory '(:relative))))
+                 (if wilden (wilden p) p))))
             ((eql :home) (user-homedir))
-            ((eql :user-cache) (resolve-location *user-cache* nil))
-            ((eql :system-cache) (resolve-location *system-cache* nil))
+            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
+            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
             ((eql :default-directory) (default-directory))))
-         (s (if (and wildenp (not (pathnamep x)))
+         (s (if (and wilden (not (pathnamep x)))
                 (wilden r)
                 r)))
@@ -2689 +2783 @@
     s))
 
-(defun resolve-location (x &optional wildenp)
+(defun* resolve-location (x &key directory wilden)
   (if (atom x)
-      (resolve-absolute-location-component x wildenp)
-      (loop :with path = (resolve-absolute-location-component (car x) nil)
+      (resolve-absolute-location-component x :directory directory :wilden wilden)
+      (loop :with path = (resolve-absolute-location-component
+                          (car x) :directory (and (or directory (cdr x)) t)
+                          :wilden (and wilden (null (cdr x))))
         :for (component . morep) :on (cdr x)
+        :for dir = (and (or morep directory) t)
+        :for wild = (and wilden (not morep))
         :do (setf path (resolve-relative-location-component
-                        path component (and wildenp (not morep))))
+                        path component :directory dir :wilden wild))
         :finally (return path))))
 
-(defun location-designator-p (x)
+(defun* location-designator-p (x)
   (flet ((componentp (c) (typep c '(or string pathname keyword))))
     (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
 
-(defun location-function-p (x)
+(defun* location-function-p (x)
   (and
    (consp x)
@@ -2712 +2810 @@
             (length=n-p (second x) 2)))))
 
-(defun validate-output-translations-directive (directive)
+(defun* validate-output-translations-directive (directive)
   (unless
       (or (member directive '(:inherit-configuration
                               :ignore-inherited-configuration
-                              :enable-user-cache :disable-cache))
+                              :enable-user-cache :disable-cache nil))
           (and (consp directive)
                (or (and (length=n-p directive 2)
@@ -2729 +2827 @@
   directive)
 
-(defun validate-output-translations-form (form)
+(defun* validate-output-translations-form (form)
   (validate-configuration-form
    form
@@ -2736 +2834 @@
    "output translations"))
 
-(defun validate-output-translations-file (file)
+(defun* validate-output-translations-file (file)
   (validate-configuration-file
    file 'validate-output-translations-form "output translations"))
 
-(defun validate-output-translations-directory (directory)
+(defun* validate-output-translations-directory (directory)
   (validate-configuration-directory
    directory :output-translations 'validate-output-translations-directive))
 
-(defun parse-output-translations-string (string)
+(defun* parse-output-translations-string (string)
   (cond
     ((or (null string) (equal string ""))
@@ -2789 +2887 @@
     system-output-translations-directory-pathname))
 
-(defun wrapping-output-translations ()
+(defun* wrapping-output-translations ()
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl (,(getenv "SBCL_HOME") ())
+    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
-    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
+    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
@@ -2801 +2899 @@
     #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-    ;; If we want to enable the user cache by default, here would be the place:
+    ;; We enable the user cache by default, and here is the place we do:
     :enable-user-cache))
 
@@ -2807 +2905 @@
 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
 
-(defun user-output-translations-pathname ()
+(defun* user-output-translations-pathname ()
   (in-user-configuration-directory *output-translations-file* ))
-(defun system-output-translations-pathname ()
+(defun* system-output-translations-pathname ()
   (in-system-configuration-directory *output-translations-file*))
-(defun user-output-translations-directory-pathname ()
+(defun* user-output-translations-directory-pathname ()
   (in-user-configuration-directory *output-translations-directory*))
-(defun system-output-translations-directory-pathname ()
+(defun* system-output-translations-directory-pathname ()
   (in-system-configuration-directory *output-translations-directory*))
-(defun environment-output-translations ()
+(defun* environment-output-translations ()
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
 
-(defgeneric process-output-translations (spec &key inherit collect))
+(defgeneric* process-output-translations (spec &key inherit collect))
 (declaim (ftype (function (t &key (:collect (or symbol function))) t)
                 inherit-output-translations))
@@ -2848 +2946 @@
     (process-output-translations-directive directive :inherit inherit :collect collect)))
 
-(defun inherit-output-translations (inherit &key collect)
+(defun* inherit-output-translations (inherit &key collect)
   (when inherit
     (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
 
-(defun process-output-translations-directive (directive &key inherit collect)
+(defun* process-output-translations-directive (directive &key inherit collect)
   (if (atom directive)
       (ecase directive
@@ -2861 +2959 @@
         ((:inherit-configuration)
          (inherit-output-translations inherit :collect collect))
-        ((:ignore-inherited-configuration)
+        ((:ignore-inherited-configuration nil)
          nil))
       (let ((src (first directive))
@@ -2870 +2968 @@
             (when src
               (let ((trusrc (or (eql src t)
-                                (let ((loc (resolve-location src t)))
+                                (let ((loc (resolve-location src :directory t :wilden t)))
                                   (if (absolute-pathname-p loc) (truenamize loc) loc)))))
                 (cond
@@ -2883 +2981 @@
                   (t
                    (let* ((trudst (make-pathname
-                                   :defaults (if dst (resolve-location dst t) trusrc)))
+                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
                           (wilddst (make-pathname
                                     :name :wild :type :wild :version :wild
@@ -2890 +2988 @@
                      (funcall collect (list trusrc trudst)))))))))))
 
-(defun compute-output-translations (&optional parameter)
+(defun* compute-output-translations (&optional parameter)
   "read the configuration, return it"
   (remove-duplicates
@@ -2898 +2996 @@
    :test 'equal :from-end t))
 
-(defun initialize-output-translations (&optional parameter)
+(defun* initialize-output-translations (&optional parameter)
   "read the configuration, initialize the internal configuration variable,
 return the configuration"
   (setf (output-translations) (compute-output-translations parameter)))
 
-(defun disable-output-translations ()
+(defun* disable-output-translations ()
   "Initialize output translations in a way that maps every file to itself,
 effectively disabling the output translation facility."
@@ -2913 +3011 @@
 ;; the latter, initialize.  ASDF will call this function at the start
 ;; of (asdf:find-system).
-(defun ensure-output-translations ()
+(defun* ensure-output-translations ()
   (if (output-translations-initialized-p)
       (output-translations)
       (initialize-output-translations)))
 
-(defun apply-output-translations (path)
+(defun* translate-pathname* (path absolute-source destination &optional root source)
+  (declare (ignore source))
+  (cond
+    ((functionp destination)
+     (funcall destination path absolute-source))
+    ((eq destination t)
+     path)
+    ((not (pathnamep destination))
+     (error "invalid destination"))
+    ((not (absolute-pathname-p destination))
+     (translate-pathname path absolute-source (merge-pathnames* destination root)))
+    (root
+     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
+    (t
+     (translate-pathname path absolute-source destination))))
+
+(defun* apply-output-translations (path)
   (etypecase path
     (logical-pathname
@@ -2935 +3049 @@
                                 (t source))
        :when (or (eq source t) (pathname-match-p p absolute-source))
-       :return
-       (cond
-         ((functionp destination)
-          (funcall destination p absolute-source))
-         ((eq destination t)
-          p)
-         ((not (pathnamep destination))
-          (error "invalid destination"))
-         ((not (absolute-pathname-p destination))
-          (translate-pathname p absolute-source (merge-pathnames* destination root)))
-         (root
-          (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
-         (t
-          (translate-pathname p absolute-source destination)))
+       :return (translate-pathname* p absolute-source destination root source)
        :finally (return p)))))
 
@@ -2961 +3062 @@
    t))
 
-(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
   (or output-file
       (apply-output-translations
@@ -2968 +3069 @@
               keys))))
 
-(defun tmpize-pathname (x)
+(defun* tmpize-pathname (x)
   (make-pathname
    :name (format nil "ASDF-TMP-~A" (pathname-name x))
    :defaults x))
 
-(defun delete-file-if-exists (x)
+(defun* delete-file-if-exists (x)
   (when (and x (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))
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
          (tmp-file (tmpize-pathname output-file))
          (status :error))
@@ -3002 +3103 @@
 
 #+abcl
-(defun translate-jar-pathname (source wildcard)
+(defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
   (let* ((p (pathname (first (pathname-device source))))
@@ -3018 +3119 @@
 ;;;; Compatibility mode for ASDF-Binary-Locations
 
-(defun enable-asdf-binary-locations-compatibility
+(defun* enable-asdf-binary-locations-compatibility
     (&key
      (centralize-lisp-binaries nil)
@@ -3026 +3127 @@
                            (user-homedir)))
      (include-per-user-information nil)
-     (map-all-source-files nil)
+     (map-all-source-files (or #+(or ecl clisp) t nil))
      (source-to-target-mappings nil))
+  #+(or ecl clisp)
+  (when (null map-all-source-files)
+    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
   (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
          (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
@@ -3054 +3158 @@
 ;;;; http://www.wotsit.org/list.asp?fc=13
 
+#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+(progn
 (defparameter *link-initial-dword* 76)
 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
 
-(defun read-null-terminated-string (s)
+(defun* read-null-terminated-string (s)
   (with-output-to-string (out)
     (loop :for code = (read-byte s)
@@ -3063 +3169 @@
       :do (write-char (code-char code) out))))
 
-(defun read-little-endian (s &optional (bytes 4))
+(defun* read-little-endian (s &optional (bytes 4))
   (loop
     :for i :from 0 :below bytes
     :sum (ash (read-byte s) (* 8 i))))
 
-(defun parse-file-location-info (s)
+(defun* parse-file-location-info (s)
   (let ((start (file-position s))
         (total-length (read-little-endian s))
@@ -3092 +3198 @@
           (read-null-terminated-string s))))))
 
-(defun parse-windows-shortcut (pathname)
+(defun* parse-windows-shortcut (pathname)
   (with-open-file (s pathname :element-type '(unsigned-byte 8))
     (handler-case
@@ -3120 +3226 @@
                     (map 'string #'code-char buffer)))))))
       (end-of-file ()
-        nil))))
+        nil)))))
 
 ;;;; -----------------------------------------------------------------
@@ -3128 +3234 @@
 ;; Using ack 1.2 exclusions
 (defvar *default-source-registry-exclusions*
-  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+  '(".bzr" ".cdv"
+    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
-    "_sgbak" "autom4te.cache" "cover_db" "_build"))
+    "_sgbak" "autom4te.cache" "cover_db" "_build"
+    "debian")) ;; debian often build stuff under the debian directory... BAD.
 
 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
@@ -3138 +3246 @@
 said element itself being a list of directory pathnames where to look for .asd files")
 
-(defun source-registry ()
+(defun* source-registry ()
   (car *source-registry*))
 
-(defun (setf source-registry) (new-value)
+(defun* (setf source-registry) (new-value)
   (setf *source-registry* (list new-value))
   new-value)
 
-(defun source-registry-initialized-p ()
+(defun* source-registry-initialized-p ()
   (and *source-registry* t))
 
-(defun clear-source-registry ()
+(defun* clear-source-registry ()
   "Undoes any initialization of the source registry.
 You might want to call that before you dump an image that would be resumed
@@ -3155 +3263 @@
   (values))
 
-(defun validate-source-registry-directive (directive)
+(defparameter *wild-asd*
+  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+
+(defun directory-has-asd-files-p (directory)
+  (and (ignore-errors
+         (directory (merge-pathnames* *wild-asd* directory)
+                    #+sbcl #+sbcl :resolve-symlinks nil
+                    #+ccl #+ccl :follow-links nil
+                    #+clisp #+clisp :circle t))
+       t))
+
+(defun subdirectories (directory)
+  (let* ((directory (ensure-directory-pathname directory))
+         #-cormanlisp
+         (wild (merge-pathnames*
+                #-(or abcl allegro lispworks scl)
+                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+                #+(or abcl allegro lispworks 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 lispworks scl)
+         (dirs (remove-if-not #+abcl #'extensions:probe-directory
+                              #+allegro #'excl:probe-directory
+                              #+lispworks #'lw:file-directory-p
+                              #-(or abcl allegro lispworks) #'directory-pathname-p
+                              dirs)))
+    dirs))
+
+(defun collect-sub*directories (directory collectp recursep collector)
+  (when (funcall collectp directory)
+    (funcall collector directory))
+  (dolist (subdir (subdirectories directory))
+    (when (funcall recursep subdir)
+      (collect-sub*directories subdir collectp recursep collector))))
+
+(defun collect-sub*directories-with-asd
+    (directory &key
+     (exclude *default-source-registry-exclusions*)
+     collect)
+  (collect-sub*directories
+   directory
+   #'directory-has-asd-files-p
+   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+   collect))
+
+(defun* validate-source-registry-directive (directive)
   (unless
       (or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3162 +3325 @@
               ((:include :directory :tree)
                (and (length=n-p rest 1)
-                    (typep (car rest) '(or pathname string null))))
+                    (location-designator-p (first rest))))
               ((:exclude :also-exclude)
                (every #'stringp rest))
@@ -3169 +3332 @@
   directive)
 
-(defun validate-source-registry-form (form)
+(defun* validate-source-registry-form (form)
   (validate-configuration-form
    form :source-registry 'validate-source-registry-directive "a source registry"))
 
-(defun validate-source-registry-file (file)
+(defun* validate-source-registry-file (file)
   (validate-configuration-file
    file 'validate-source-registry-form "a source registry"))
 
-(defun validate-source-registry-directory (directory)
+(defun* validate-source-registry-directory (directory)
   (validate-configuration-directory
    directory :source-registry 'validate-source-registry-directive))
 
-(defun parse-source-registry-string (string)
+(defun* parse-source-registry-string (string)
   (cond
     ((or (null string) (equal string ""))
@@ -3215 +3378 @@
            (return `(:source-registry ,@(nreverse directives))))))))))
 
-(defun register-asd-directory (directory &key recurse exclude collect)
+(defun* register-asd-directory (directory &key recurse exclude collect)
   (if (not recurse)
       (funcall collect directory)
-      (let* ((files
-              (handler-case
-                  (directory (merge-pathnames* *wild-asd* directory)
-                             #+sbcl #+sbcl :resolve-symlinks nil
-                             #+clisp #+clisp :circle t)
-                (error (c)
-                  (warn "Error while scanning system definitions under directory ~S:~%~A"
-                        directory c)
-                  nil)))
-             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
-                                      :test #'equal :from-end t)))
-        (loop
-          :for dir :in dirs
-          :unless (loop :for x :in exclude
-                    :thereis (find x (pathname-directory dir) :test #'equal))
-          :do (funcall collect dir)))))
+      (collect-sub*directories-with-asd
+       directory :exclude exclude :collect collect)))
 
 (defparameter *default-source-registries*
@@ -3246 +3395 @@
 (defparameter *source-registry-directory* #p"source-registry.conf.d/")
 
-(defun wrapping-source-registry ()
+(defun* wrapping-source-registry ()
   `(:source-registry
     #+sbcl (:tree ,(getenv "SBCL_HOME"))
     :inherit-configuration
     #+cmu (:tree #p"modules:")))
-(defun default-source-registry ()
+(defun* default-source-registry ()
   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     `(:source-registry
@@ -3277 +3426 @@
            :collect `(:tree ,(try dir "common-lisp/source/"))))
       :inherit-configuration)))
-(defun user-source-registry ()
+(defun* user-source-registry ()
   (in-user-configuration-directory *source-registry-file*))
-(defun system-source-registry ()
+(defun* system-source-registry ()
   (in-system-configuration-directory *source-registry-file*))
-(defun user-source-registry-directory ()
+(defun* user-source-registry-directory ()
   (in-user-configuration-directory *source-registry-directory*))
-(defun system-source-registry-directory ()
+(defun* system-source-registry-directory ()
   (in-system-configuration-directory *source-registry-directory*))
-(defun environment-source-registry ()
+(defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
 
-(defgeneric process-source-registry (spec &key inherit register))
+(defgeneric* process-source-registry (spec &key inherit register))
 (declaim (ftype (function (t &key (:register (or symbol function))) t)
                 inherit-source-registry))
@@ -3317 +3466 @@
       (process-source-registry-directive directive :inherit inherit :register register))))
 
-(defun inherit-source-registry (inherit &key register)
+(defun* inherit-source-registry (inherit &key register)
   (when inherit
     (process-source-registry (first inherit) :register register :inherit (rest inherit))))
 
-(defun process-source-registry-directive (directive &key inherit register)
+(defun* process-source-registry-directive (directive &key inherit register)
   (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     (ecase kw
       ((:include)
        (destructuring-bind (pathname) rest
-         (process-source-registry (pathname pathname) :inherit nil :register register)))
+         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
       ((:directory)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname)))))
+           (funcall register (resolve-location pathname :directory t)))))
       ((:tree)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
+           (funcall register (resolve-location pathname :directory t)
+                    :recurse t :exclude *source-registry-exclusions*))))
       ((:exclude)
        (setf *source-registry-exclusions* rest))
@@ -3347 +3497 @@
   nil)
 
-(defun flatten-source-registry (&optional parameter)
+(defun* flatten-source-registry (&optional parameter)
   (remove-duplicates
    (while-collecting (collect)
@@ -3360 +3510 @@
 ;; Will read the configuration and initialize all internal variables,
 ;; and return the new configuration.
-(defun compute-source-registry (&optional parameter)
+(defun* compute-source-registry (&optional parameter)
   (while-collecting (collect)
     (dolist (entry (flatten-source-registry parameter))
@@ -3368 +3518 @@
          :recurse recurse :exclude exclude :collect #'collect)))))
 
-(defun initialize-source-registry (&optional parameter)
+(defun* initialize-source-registry (&optional parameter)
   (setf (source-registry) (compute-source-registry parameter)))
 
@@ -3379 +3529 @@
 ;; you may override the configuration explicitly by calling
 ;; initialize-source-registry directly with your parameter.
-(defun ensure-source-registry (&optional parameter)
+(defun* ensure-source-registry (&optional parameter)
   (if (source-registry-initialized-p)
       (source-registry)
       (initialize-source-registry parameter)))
 
-(defun sysdef-source-registry-search (system)
+(defun* sysdef-source-registry-search (system)
   (ensure-source-registry)
   (loop :with name = (coerce-name system)
@@ -3391 +3541 @@
     :when file :return file))
 
+(defun* clear-configuration ()
+  (clear-source-registry)
+  (clear-output-translations))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
 ;;;;
-#+(or abcl clozure cmu ecl sbcl)
-(progn
-  (defun module-provide-asdf (name)
-    (handler-bind
-        ((style-warning #'muffle-warning)
-         (missing-component (constantly nil))
-         (error (lambda (e)
-                  (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
-                          name e))))
-      (let* ((*verbose-out* (make-broadcast-stream))
-             (system (find-system (string-downcase name) nil)))
-        (when system
-          (load-system system)
-          t))))
-  (pushnew 'module-provide-asdf
-           #+abcl sys::*module-provider-functions*
-           #+clozure ccl:*module-provider-functions*
-           #+cmu ext:*module-provider-functions*
-           #+ecl si:*module-provider-functions*
-           #+sbcl sb-ext:*module-provider-functions*))
+(defun* module-provide-asdf (name)
+  (handler-bind
+      ((style-warning #'muffle-warning)
+       (missing-component (constantly nil))
+       (error (lambda (e)
+                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
+                        name e))))
+    (let* ((*verbose-out* (make-broadcast-stream))
+           (system (find-system (string-downcase name) nil)))
+      (when system
+        (load-system system)
+        t))))
+
+#+(or abcl clisp clozure cmu ecl sbcl)
+(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
+  (when x
+    (eval `(pushnew 'module-provide-asdf
+            #+abcl sys::*module-provider-functions*
+            #+clisp ,x
+            #+clozure ccl:*module-provider-functions*
+            #+cmu ext:*module-provider-functions*
+            #+ecl si:*module-provider-functions*
+            #+sbcl sb-ext:*module-provider-functions*))))
+
 
 ;;;; -------------------------------------------------------------------------