Changeset 14252

Timestamp:

Sep 11, 2010, 8:14:46 AM (14 years ago)

Author:

R. Matthew Emerson

Message:

Update ASDF to 2.008.

File:

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

trunk/source/tools/asdf.lisp

@@ -49 +49 @@
 
 (cl:in-package :cl)
-(defpackage :asdf-bootstrap (:use :cl))
-(in-package :asdf-bootstrap)
-
-;; Implementation-dependent tweaks
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  ;;; 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
@@ -59 +61 @@
         (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 +70 @@
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
+  (defvar *asdf-version* nil)
+  (defvar *upgraded-p* nil)
   (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)))
+          (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128
+         (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*
@@ -123 +121 @@
                (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 +144 @@
                :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)
@@ -161 +177 @@
                    :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
                    :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))
+          (let ((u (find-package :asdf-utilities)))
+            (when u
+              (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s))))
           (pkgdcl
            :asdf
-           :use (:common-lisp :asdf-utilities)
+           :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*)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
@@ -208 +199 @@
            (#: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 +207 @@
             #:version-satisfies
 
-            #:input-files #:output-files #:perform ; operation methods
+            #:input-files #:output-files #:output-file #:perform ; operation methods
             #:operation-done-p #:explain
 
@@ -255 +246 @@
             #:operation-on-warnings
             #:operation-on-failure
+            #:component-visited-p
             ;;#:*component-parent-pathname*
             #:*system-definition-search-functions*
@@ -284 +276 @@
             #:remove-entry-from-registry
 
+            #:clear-configuration
             #:initialize-output-translations
             #:disable-output-translations
@@ -292 +285 @@
             #:compile-file-pathname*
             #:enable-asdf-binary-locations-compatibility
-
             #:*default-source-registries*
             #:initialize-source-registry
@@ -298 +290 @@
             #: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
+            #: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
@@ -343 +351 @@
   "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 +381 @@
 ;;;; -------------------------------------------------------------------------
 ;;;; 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 +399 @@
 (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 +421 @@
 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 +431 @@
 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 +451 @@
 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 +459 @@
 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 +485 @@
     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 +520 @@
   `(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 +526 @@
     (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 +535 @@
          (defaults (pathname defaults))
          (directory (pathname-directory specified))
-         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
+         #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
@@ -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 &optional force-directory)
   "Splits the path string S, returning three values:
 A flag that is either :absolute or :relative, indicating
@@ -633 +656 @@
          (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 +662 @@
     :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?
 
@@ -679 +694 @@
          t)))
 
-(defun ensure-directory-pathname (pathspec)
+(defun* ensure-directory-pathname (pathspec)
   "Converts the non-wild pathname designator PATHSPEC to directory form."
   (cond
@@ -697 +712 @@
                    :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 +724 @@
       ((not (consp l)) (return nil)))))
 
-(defun ends-with (s suffix)
+(defun* ends-with (s suffix)
   (check-type s string)
   (check-type suffix string)
@@ -716 +731 @@
          (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 +740 @@
 #-(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 +767 @@
                  :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) `(,it p))
+               '(ignore-errors (truename p)))))))
+
+(defun* truenamize (p)
   "Resolve as much of a pathname as possible"
   (block nil
@@ -758 +785 @@
            (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 +801 @@
           (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 +811 @@
             (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 +825 @@
                  :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))
@@ -838 +865 @@
                 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 +885 @@
 
 (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)
@@ -896 +926 @@
                 :accessor component-in-order-to)
    ;; 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)
    ;; XXX crap name, but it's an official API name!
@@ -916 +948 @@
                :initform nil)))
 
-(defun component-find-path (component)
+(defun* component-find-path (component)
   (reverse
    (loop :for c = component :then (component-parent c)
@@ -932 +964 @@
           (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 +971 @@
 
 (defmethod print-object ((c missing-component) s)
-   (format s "~@<component ~S not found~
+  (format s "~@<component ~S not found~
              ~@[ in ~A~]~@:>"
           (missing-requires c)
@@ -948 +980 @@
   (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)))))
+          (missing-requires c)
+          (missing-version c)
+          (when (missing-parent c)
+            (component-name (missing-parent c)))))
 
 (defmethod component-system ((component component))
@@ -960 +992 @@
 (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 +1022 @@
     :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 +1039 @@
              (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)))
@@ -1058 +1091 @@
 ;;;; Finding systems
 
-(defun make-defined-systems-table ()
+(defun* make-defined-systems-table ()
   (make-hash-table :test 'equal))
 
@@ -1068 +1101 @@
 of which is a system object.")
 
-(defun coerce-name (name)
+(defun* coerce-name (name)
   (typecase name
     (component (component-name name))
@@ -1075 +1108 @@
     (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 +1122 @@
   (setf (gethash (coerce-name name) *defined-systems*) nil))
 
-(defun map-systems (fn)
+(defun* map-systems (fn)
   "Apply FN to each defined system.
 
@@ -1107 +1140 @@
   '(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 +1164 @@
 ")
 
-(defun probe-asd (name defaults)
+(defun* probe-asd (name defaults)
   (block nil
     (when (directory-pathname-p defaults)
@@ -1152 +1185 @@
               (return (pathname target)))))))))
 
-(defun sysdef-central-registry-search (system)
+(defun* sysdef-central-registry-search (system)
   (let ((name (coerce-name system))
         (to-remove nil)
@@ -1194 +1227 @@
                           (subseq *central-registry* (1+ position))))))))))
 
-(defun make-temporary-package ()
+(defun* make-temporary-package ()
   (flet ((try (counter)
            (ignore-errors
@@ -1203 +1236 @@
          (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 +1247 @@
   (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 +1276 @@
             (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)
+(defun* sysdef-find-asdf (system)
   (let ((name (coerce-name system)))
     (when (equal name "asdf")
@@ -1318 +1355 @@
   (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 +1362 @@
   ;; 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
@@ -1370 +1407 @@
    ;; (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 +1427 @@
   (values))
 
-(defun node-for (o c)
+(defun* node-for (o c)
   (cons (class-name (class-of o)) c))
 
@@ -1399 +1436 @@
 
 
-(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 +1581 @@
 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 +1599 @@
     (do-traverse op dep-c collect)))
 
-(defun do-one-dep (operation c collect required-op required-c required-v)
+(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.
@@ -1572 +1609 @@
         :report (lambda (s)
                   (format s "~@<Retry loading component ~S.~@:>"
-                          required-c))
+                          (component-find-path required-c)))
         :test
         (lambda (c)
@@ -1587 +1624 @@
                            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 +1663 @@
            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 +1750 @@
                  (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 +1780 @@
   (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))
@@ -1754 +1794 @@
 
 (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 +1811 @@
           :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)))
@@ -1793 +1842 @@
   #-: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 +1887 @@
   nil)
 
+(defmethod operation-description ((operation compile-op) component)
+  (declare (ignorable operation))
+  (format nil "compiling component ~S" (component-find-path component)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1912 +1966 @@
         (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 +2008 @@
              (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 +2062 @@
                 :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 ~
+                  (format s "~@<Continue, treating ~A as ~
                                    having been successful.~@:>"
-                          op component))
+                          (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 +2105 @@
         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
@@ -2050 +2112 @@
   (apply #'operate 'load-op system args))
 
-(defun compile-system (system &rest args &key force verbose version
+(defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
@@ -2057 +2119 @@
   (apply #'operate 'compile-op system args))
 
-(defun test-system (system &rest args &key force verbose version
+(defun* test-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
@@ -2067 +2129 @@
 ;;;; Defsystem
 
-(defun load-pathname ()
+(defun* load-pathname ()
   (let ((pn (or *load-pathname* *compile-file-pathname*)))
     (if *resolve-symlinks*
@@ -2073 +2135 @@
         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 +2144 @@
          (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))))
 
@@ -2113 +2175 @@
                ',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 +2188 @@
       (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 +2203 @@
         (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 +2216 @@
 (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 +2237 @@
                             type name in-order-to)))
 
-(defun %remove-component-inline-methods (component)
+(defun* %remove-component-inline-methods (component)
   (dolist (name +asdf-methods+)
     (map ()
@@ -2187 +2249 @@
   (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 +2263 @@
            (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 +2348 @@
 ;;;; 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 +2420 @@
   (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 +2428 @@
                  :defaults (system-source-file system-designator)))
 
-(defun relativize-directory (directory)
+(defun* relativize-directory (directory)
   (cond
     ((stringp directory)
@@ -2375 +2437 @@
      directory)))
 
-(defun relativize-pathname-directory (pathspec)
+(defun* relativize-pathname-directory (pathspec)
   (let ((p (pathname pathspec)))
     (make-pathname
@@ -2381 +2443 @@
      :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)
@@ -2412 +2474 @@
 
 
-(defun lisp-version-string ()
+(defun* lisp-version-string ()
   (let ((s (lisp-implementation-version)))
     (declare (ignorable s))
@@ -2447 +2509 @@
           ecl gcl lispworks mcl sbcl scl) s))
 
-(defun first-feature (features)
+(defun* first-feature (features)
   (labels
       ((fp (thing)
@@ -2463 +2525 @@
       :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)
@@ -2496 +2558 @@
   #-(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 +2580 @@
            ,(try (getenv "APPDATA") "common-lisp/config/"))
        ,(try (user-homedir) ".config/common-lisp/")))))
-(defun system-configuration-directories ()
+(defun* system-configuration-directories ()
   (remove-if
    #'null
@@ -2528 +2590 @@
         ,(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 +2618 @@
   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 +2624 @@
     (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 +2665 @@
   *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 +2679 @@
   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
@@ -2632 +2693 @@
                  :name :wild :type "asd" :version :newest))
 
-
-(declaim (ftype (function (t &optional boolean) (or null pathname))
+(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
                 resolve-location))
 
-(defun resolve-relative-location-component (super x &optional wildenp)
+(defun* resolve-relative-location-component (super x &optional wildenp)
   (let* ((r (etypecase x
               (pathname x)
@@ -2661 +2721 @@
     (merge-pathnames* s super)))
 
-(defun resolve-absolute-location-component (x wildenp)
+(defun* resolve-absolute-location-component (x wildenp)
   (let* ((r
           (etypecase x
@@ -2689 +2749 @@
     s))
 
-(defun resolve-location (x &optional wildenp)
+(defun* resolve-location (x &optional wildenp)
   (if (atom x)
       (resolve-absolute-location-component x wildenp)
@@ -2698 +2758 @@
         :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 +2772 @@
             (length=n-p (second x) 2)))))
 
-(defun validate-output-translations-directive (directive)
+(defun* validate-output-translations-directive (directive)
   (unless
       (or (member directive '(:inherit-configuration
@@ -2729 +2789 @@
   directive)
 
-(defun validate-output-translations-form (form)
+(defun* validate-output-translations-form (form)
   (validate-configuration-form
    form
@@ -2736 +2796 @@
    "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 +2849 @@
     system-output-translations-directory-pathname))
 
-(defun wrapping-output-translations ()
+(defun* wrapping-output-translations ()
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
@@ -2807 +2867 @@
 (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 +2908 @@
     (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
@@ -2890 +2950 @@
                      (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 +2958 @@
    :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 +2973 @@
 ;; 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 +3011 @@
                                 (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 +3024 @@
    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 +3031 @@
               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)
+(defun* compile-file* (input-file &rest keys &key &allow-other-keys)
   (let* ((output-file (apply 'compile-file-pathname* input-file keys))
          (tmp-file (tmpize-pathname output-file))
@@ -3002 +3065 @@
 
 #+abcl
-(defun translate-jar-pathname (source wildcard)
+(defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
   (let* ((p (pathname (first (pathname-device source))))
@@ -3018 +3081 @@
 ;;;; Compatibility mode for ASDF-Binary-Locations
 
-(defun enable-asdf-binary-locations-compatibility
+(defun* enable-asdf-binary-locations-compatibility
     (&key
      (centralize-lisp-binaries nil)
@@ -3057 +3120 @@
 (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 +3126 @@
       :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 +3155 @@
           (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
@@ -3130 +3193 @@
   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     ".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 +3202 @@
 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 +3219 @@
   (values))
 
-(defun validate-source-registry-directive (directive)
+(defun* validate-source-registry-directive (directive)
   (unless
       (or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3169 +3233 @@
   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 +3279 @@
            (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)
@@ -3246 +3310 @@
 (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 +3341 @@
            :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 +3381 @@
       (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
@@ -3347 +3411 @@
   nil)
 
-(defun flatten-source-registry (&optional parameter)
+(defun* flatten-source-registry (&optional parameter)
   (remove-duplicates
    (while-collecting (collect)
@@ -3360 +3424 @@
 ;; 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 +3432 @@
          :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 +3443 @@
 ;; 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 +3455 @@
     :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*))))
+
 
 ;;;; -------------------------------------------------------------------------