Index: /trunk/source/tools/asdf.lisp
===================================================================
--- /trunk/source/tools/asdf.lisp	(revision 14686)
+++ /trunk/source/tools/asdf.lisp	(revision 14687)
@@ -1,4 +1,4 @@
-;;; -*- mode: common-lisp; package: asdf; -*-
-;;; This is ASDF: Another System Definition Facility.
+;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.013: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -11,7 +11,7 @@
 ;;; location above for a more recent version (and for documentation
 ;;; and test files, if your copy came without them) before reporting
-;;; bugs.  There are usually two "supported" revisions - the git HEAD
-;;; is the latest development version, whereas the revision tagged
-;;; RELEASE may be slightly older but is considered `stable'
+;;; bugs.  There are usually two "supported" revisions - the git master
+;;; branch is the latest development version, whereas the git release
+;;; branch may be slightly older but is considered `stable'
 
 ;;; -- LICENSE START
@@ -48,5 +48,5 @@
 #+xcvb (module ())
 
-(cl:in-package :cl-user)
+(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
 
 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
@@ -56,5 +56,5 @@
   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
   (unless (find-package :asdf)
-    (make-package :asdf :use '(:cl)))
+    (make-package :asdf :use '(:common-lisp)))
   ;;; Implementation-dependent tweaks
   ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
@@ -63,5 +63,7 @@
         (remove "asdf" excl::*autoload-package-name-alist*
                 :test 'equalp :key 'car))
-  #+ecl (require :cmp))
+  #+(and ecl (not ecl-bytecmp)) (require :cmp)
+  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
+  #+(or unix cygwin) (pushnew :asdf-unix *features*))
 
 (in-package :asdf)
@@ -77,9 +79,10 @@
          ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
          ;; can help you do these changes in synch (look at the source for documentation).
+         ;; Relying on its automation, the version is now redundantly present on top of this file.
          ;; "2.345" would be an official release
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.012")
+         (asdf-version "2.013")
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
@@ -88,12 +91,19 @@
       (when existing-asdf
         (format *trace-output*
-         "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
+         "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
          existing-version asdf-version))
       (labels
-          ((unlink-package (package)
+          ((present-symbol-p (symbol package)
+             (member (nth-value 1 (find-symbol symbol package)) '(:internal :external)))
+           (present-symbols (package)
+             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
+             (let (l)
+               (do-symbols (s package)
+                 (when (present-symbol-p s package) (push s l)))
+               (reverse l)))
+           (unlink-package (package)
              (let ((u (find-package package)))
                (when u
-                 (ensure-unintern u
-                   (loop :for s :being :each :present-symbol :in u :collect s))
+                 (ensure-unintern u (present-symbols u))
                  (loop :for p :in (package-used-by-list u) :do
                    (unuse-package u p))
@@ -149,5 +159,5 @@
                    (bothly-exported-symbols nil)
                    (newly-exported-symbols nil))
-               (loop :for sym :being :each :external-symbol :in package :do
+               (do-external-symbols (sym package)
                  (if (member sym export :test 'string-equal)
                      (push sym bothly-exported-symbols)
@@ -187,5 +197,6 @@
             #:perform-with-restarts #:component-relative-pathname
             #:system-source-file #:operate #:find-component #:find-system
-            #:apply-output-translations #:translate-pathname* #:resolve-location)
+            #:apply-output-translations #:translate-pathname* #:resolve-location
+            #:compile-file*)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
@@ -279,4 +290,5 @@
 
             #:clear-configuration
+            #:*output-translations-parameter*
             #:initialize-output-translations
             #:disable-output-translations
@@ -288,4 +300,5 @@
             #:enable-asdf-binary-locations-compatibility
             #:*default-source-registries*
+            #:*source-registry-parameter*
             #:initialize-source-registry
             #:compute-source-registry
@@ -309,4 +322,5 @@
             ;; #:find-symbol*
             #:merge-pathnames*
+            #:coerce-pathname
             #:pathname-directory-pathname
             #:read-file-forms
@@ -320,4 +334,5 @@
             #:truenamize
             #:while-collecting)))
+	#+genera (import 'scl:boolean :asdf)
         (setf *asdf-version* asdf-version
               *upgraded-p* (if existing-version
@@ -331,5 +346,5 @@
   "Exported interface to the version of ASDF currently installed. A string.
 You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
   *asdf-version*)
 
@@ -406,4 +421,39 @@
     (make-pathname :name nil :type nil :version nil :defaults pathname)))
 
+(defun* normalize-pathname-directory-component (directory)
+  (cond
+    #-(or sbcl cmu)
+    ((stringp directory) `(:absolute ,directory) directory)
+    #+gcl
+    ((and (consp directory) (stringp (first directory)))
+     `(:absolute ,@directory))
+    ((or (null directory)
+         (and (consp directory) (member (first directory) '(:absolute :relative))))
+     directory)
+    (t
+     (error "Unrecognized pathname directory component ~S" directory))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+  (let ((directory (normalize-pathname-directory-component specified)))
+    (ecase (first directory)
+      ((nil) defaults)
+      (:absolute specified)
+      (:relative
+       (let ((defdir (normalize-pathname-directory-component defaults))
+             (reldir (cdr directory)))
+         (cond
+           ((null defdir)
+            directory)
+           ((not (eq :back (first reldir)))
+            (append defdir reldir))
+           (t
+            (loop :with defabs = (first defdir)
+              :with defrev = (reverse (rest defdir))
+              :while (and (eq :back (car reldir))
+                          (or (and (eq :absolute defabs) (null defrev))
+                              (stringp (car defrev))))
+              :do (pop reldir) (pop defrev)
+              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
@@ -414,17 +464,5 @@
   (let* ((specified (pathname specified))
          (defaults (pathname defaults))
-         (directory (pathname-directory specified))
-         (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))))
+         (directory (normalize-pathname-directory-component (pathname-directory specified)))
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
@@ -436,9 +474,4 @@
       (multiple-value-bind (host device directory unspecific-handler)
           (ecase (first directory)
-            ((nil)
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (pathname-directory defaults)
-                     (unspecific-handler defaults)))
             ((:absolute)
              (values (pathname-host specified)
@@ -446,10 +479,8 @@
                      directory
                      (unspecific-handler specified)))
-            ((:relative)
+            ((nil :relative)
              (values (pathname-host defaults)
                      (pathname-device defaults)
-                     (if (pathname-directory defaults)
-                         (append (pathname-directory defaults) (cdr directory))
-                         directory)
+                     (merge-pathname-directory-components directory (pathname-directory defaults))
                      (unspecific-handler defaults))))
         (make-pathname :host host :device device :directory directory
@@ -458,4 +489,13 @@
                        :version (funcall unspecific-handler version))))))
 
+(defun* pathname-parent-directory-pathname (pathname)
+  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+  (when pathname
+    (make-pathname :name nil :type nil :version nil
+                   :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
+                   :defaults pathname)))
+
+
 (define-modify-macro appendf (&rest args)
   append "Append onto list") ;; only to be used on short lists.
@@ -470,7 +510,13 @@
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
 
+(defun* errfmt (out format-string &rest format-args)
+  (declare (dynamic-extent format-args))
+  (apply #'format out
+         #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string
+         format-args))
+
 (defun* asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
-  (apply #'format *verbose-out* format-string format-args))
+  (apply #'errfmt *verbose-out* format-string format-args))
 
 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
@@ -499,5 +545,5 @@
          ;; See CLHS make-pathname and 19.2.2.2.3.
          ;; We only use it on implementations that support it.
-         (or #+(or ccl gcl lispworks sbcl) :unspecific)))
+         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
@@ -536,5 +582,6 @@
                 (values :relative nil))
           (values :relative components))
-      (setf components (remove "" components :test #'equal))
+      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
+      (setf components (substitute :back ".." components :test #'equal))
       (cond
         ((equal last-comp "")
@@ -556,14 +603,25 @@
     :append (list k v)))
 
+#+mcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
+
 (defun* getenv (x)
-  (#+(or abcl clisp) ext:getenv
-   #+allegro sys: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))
+  (declare (ignorable x))
+  #+(or abcl clisp) (ext:getenv x)
+  #+allegro (sys:getenv x)
+  #+clozure (ccl:getenv x)
+  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+  #+ecl (si:getenv x)
+  #+gcl (system:getenv x)
+  #+genera nil
+  #+lispworks (lispworks:environment-variable x)
+  #+mcl (ccl:with-cstrs ((name x))
+          (let ((value (_getenv name)))
+            (unless (ccl:%null-ptr-p value)
+              (ccl:%get-cstring value))))
+  #+sbcl (sb-ext:posix-getenv x)
+  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
+  (error "getenv not available on your implementation"))
 
 (defun* directory-pathname-p (pathname)
@@ -603,4 +661,9 @@
                    :defaults pathspec))))
 
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+  (defun ensure-directories-exist (path)
+    (fs:create-directories-recursively (pathname path))))
+
 (defun* absolute-pathname-p (pathspec)
   (and (typep pathspec '(or pathname string))
@@ -630,5 +693,5 @@
      :collect form)))
 
-#-(and (or win32 windows mswindows mingw32) (not cygwin))
+#+asdf-unix
 (progn
   #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
@@ -670,11 +733,11 @@
    (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)))))))
+                     #+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
-    (when (typep p 'logical-pathname) (return p))
+    (when (typep p '(or null logical-pathname)) (return p))
     (let* ((p (merge-pathnames* p))
            (directory (pathname-directory p)))
@@ -708,5 +771,7 @@
 (defun* resolve-symlinks (path)
   #-allegro (truenamize path)
-  #+allegro (excl:pathname-resolve-symbolic-links path))
+  #+allegro (if (typep path 'logical-pathname)
+                path
+                (excl:pathname-resolve-symbolic-links path)))
 
 (defun* default-directory ()
@@ -728,15 +793,18 @@
   (merge-pathnames* *wild-path* path))
 
+(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
+    (last-char (namestring foo))))
+
 (defun* directorize-pathname-host-device (pathname)
   (let* ((root (pathname-root pathname))
          (wild-root (wilden root))
          (absolute-pathname (merge-pathnames* pathname root))
-         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
-         (separator (last-char (namestring foo)))
+         (separator (directory-separator-for-host root))
          (root-namestring (namestring root))
          (root-string
           (substitute-if #\/
-                         (lambda (x) (or (eql x #\:)
-                                         (eql x separator)))
+                         #'(lambda (x) (or (eql x #\:)
+                                           (eql x separator)))
                          root-namestring)))
     (multiple-value-bind (relative path filename)
@@ -857,11 +925,4 @@
 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
 (when *upgraded-p*
-   #+ecl
-   (when (find-class 'compile-op nil)
-     (defmethod update-instance-for-redefined-class :after
-         ((c compile-op) added deleted plist &key)
-       (declare (ignore added deleted))
-       (let ((system-p (getf plist 'system-p)))
-         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
    (when (find-class 'module nil)
      (eval
@@ -870,5 +931,5 @@
          (declare (ignorable deleted plist))
          (when (or *asdf-verbose* *load-verbose*)
-           (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
+           (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version)))
          (when (member 'components-by-name added)
            (compute-module-components-by-name m))
@@ -898,5 +959,8 @@
                 error-component error-operation
                 module-components module-components-by-name
-                circular-dependency-components)
+                circular-dependency-components
+                condition-arguments condition-form
+                condition-format condition-location
+                coerce-name)
          (ftype (function (t t) t) (setf module-components-by-name)))
 
@@ -906,5 +970,5 @@
    (format-arguments :initarg :format-arguments :reader format-arguments))
   (:report (lambda (c s)
-             (apply #'format s (format-control c) (format-arguments c)))))
+               (apply #'errfmt s (format-control c) (format-arguments c)))))
 
 (define-condition load-system-definition-error (system-definition-error)
@@ -913,17 +977,17 @@
    (condition :initarg :condition :reader error-condition))
   (:report (lambda (c s)
-             (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
-                     (error-name c) (error-pathname c) (error-condition c)))))
+	     (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A"
+		     (error-name c) (error-pathname c) (error-condition c)))))
 
 (define-condition circular-dependency (system-definition-error)
   ((components :initarg :components :reader circular-dependency-components))
   (:report (lambda (c s)
-             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
+	     (errfmt s "Circular dependency: ~S" (circular-dependency-components c)))))
 
 (define-condition duplicate-names (system-definition-error)
   ((name :initarg :name :reader duplicate-names-name))
   (:report (lambda (c s)
-             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
-                     (duplicate-names-name c)))))
+	     (errfmt s "Error while defining system: multiple components are given same name ~A"
+		     (duplicate-names-name c)))))
 
 (define-condition missing-component (system-definition-error)
@@ -945,6 +1009,6 @@
    (operation :reader error-operation :initarg :operation))
   (:report (lambda (c s)
-             (format s "~@<erred while invoking ~A on ~A~@:>"
-                     (error-operation c) (error-component c)))))
+               (errfmt s "erred while invoking ~A on ~A"
+                       (error-operation c) (error-component c)))))
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
@@ -957,12 +1021,12 @@
    (arguments :reader condition-arguments :initarg :arguments :initform nil))
   (:report (lambda (c s)
-             (format s "~@<~? (will be skipped)~@:>"
-                     (condition-format c)
-                     (list* (condition-form c) (condition-location c)
-                            (condition-arguments c))))))
+               (errfmt s "~? (will be skipped)"
+                       (condition-format c)
+                       (list* (condition-form c) (condition-location c)
+                              (condition-arguments c))))))
 (define-condition invalid-source-registry (invalid-configuration warning)
-  ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
+  ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))
 (define-condition invalid-output-translation (invalid-configuration warning)
-  ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
+  ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))
 
 (defclass component ()
@@ -970,7 +1034,10 @@
          "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
+   (description :accessor component-description :initarg :description)
+   (long-description :accessor component-long-description :initarg :long-description)
+   ;; This one below is used by POIU - http://www.cliki.net/poiu
+   ;; a parallelizing extension of ASDF that compiles in multiple parallel
+   ;; slave processes (forked on demand) and loads in the master process.
+   ;; Maybe in the future ASDF may use it internally instead of in-order-to.
    (load-dependencies :accessor component-load-dependencies :initform nil)
    ;; In the ASDF object model, dependencies exist between *actions*
@@ -991,4 +1058,5 @@
    ;; 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!
+   ;; See our ASDF 2 paper for more complete explanations.
    (in-order-to :initform nil :initarg :in-order-to
                 :accessor component-in-order-to)
@@ -1018,5 +1086,5 @@
 (defmethod print-object ((c component) stream)
   (print-unreadable-object (c stream :type t :identity nil)
-    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+    (format stream "~{~S~^ ~}" (component-find-path c))))
 
 
@@ -1024,5 +1092,5 @@
 
 (defmethod print-object ((c missing-dependency) s)
-  (format s "~@<~A, required by ~A~@:>"
+  (format s "~A, required by ~A"
           (call-next-method c nil) (missing-required-by c)))
 
@@ -1034,5 +1102,5 @@
 
 (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)
@@ -1040,5 +1108,5 @@
 
 (defmethod print-object ((c missing-component-of-version) s)
-  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
+  (format s "component ~S does not match version ~A~@[ in ~A~]"
           (missing-requires c)
           (missing-version c)
@@ -1117,7 +1185,8 @@
 
 (defclass system (module)
-  ((description :accessor system-description :initarg :description)
-   (long-description
-    :accessor system-long-description :initarg :long-description)
+  (;; description and long-description are now available for all component's,
+   ;; but now also inherited from component, but we add the legacy accessor
+   (description :accessor system-description :initarg :description)
+   (long-description :accessor system-long-description :initarg :long-description)
    (author :accessor system-author :initarg :author)
    (maintainer :accessor system-maintainer :initarg :maintainer)
@@ -1168,5 +1237,5 @@
     (symbol (string-downcase (symbol-name name)))
     (string name)
-    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+    (t (sysdef-error "invalid component designator ~A" name))))
 
 (defun* system-registered-p (name)
@@ -1186,9 +1255,9 @@
 FN should be a function of one argument. It will be
 called with an object of type asdf:system."
-  (maphash (lambda (_ datum)
-             (declare (ignore _))
-             (destructuring-bind (_ . def) datum
+  (maphash #'(lambda (_ datum)
                (declare (ignore _))
-               (funcall fn def)))
+               (destructuring-bind (_ . def) datum
+                 (declare (ignore _))
+                 (funcall fn def)))
            *defined-systems*))
 
@@ -1202,5 +1271,5 @@
   (let ((system-name (coerce-name system)))
     (or
-     (some (lambda (x) (funcall x system-name))
+     (some #'(lambda (x) (funcall x system-name))
            *system-definition-search-functions*)
      (let ((system-pair (system-registered-p system-name)))
@@ -1231,7 +1300,7 @@
               :name name
               :type "asd")))
-        (when (probe-file file)
+        (when (probe-file* file)
           (return file)))
-      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+      #+(and asdf-windows (not clisp))
       (let ((shortcut
              (make-pathname
@@ -1239,5 +1308,5 @@
               :name (concatenate 'string name ".asd")
               :type "lnk")))
-        (when (probe-file shortcut)
+        (when (probe-file* shortcut)
           (let ((target (parse-windows-shortcut shortcut)))
             (when target
@@ -1261,6 +1330,6 @@
                             (let* ((*print-circle* nil)
                                    (message
-                                    (format nil
-                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
+                                    (errfmt nil
+                                            "While searching for system ~S: ~S evaluated to ~S which is not a directory."
                                             system dir defaults)))
                               (error message))
@@ -1270,6 +1339,6 @@
                           (coerce-entry-to-directory ()
                             :report (lambda (s)
-                                      (format s "Coerce entry to ~a, replace ~a and continue."
-                                              (ensure-directory-pathname defaults) dir))
+				      (errfmt s "Coerce entry to ~a, replace ~a and continue."
+					      (ensure-directory-pathname defaults) dir))
                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
         ;; cleanup
@@ -1303,5 +1372,5 @@
   ;; as if the file were very old.
   ;; (or should we treat the case in a different, special way?)
-  (or (and pathname (probe-file pathname) (file-write-date pathname))
+  (or (and pathname (probe-file* pathname) (file-write-date pathname))
       (progn
         (when (and pathname *asdf-verbose*)
@@ -1318,11 +1387,11 @@
     (unwind-protect
          (handler-bind
-             ((error (lambda (condition)
-                       (error 'load-system-definition-error
-                              :name name :pathname pathname
-                              :condition condition))))
+             ((error #'(lambda (condition)
+                         (error 'load-system-definition-error
+                                :name name :pathname pathname
+                                :condition condition))))
            (let ((*package* package))
              (asdf-message
-              "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
+              "~&; Loading system definition from ~A into ~A~%"
               pathname package)
              (load pathname)))
@@ -1350,5 +1419,5 @@
 
 (defun* register-system (name system)
-  (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
+  (asdf-message "~&; Registering ~A as ~A~%" system name)
   (setf (gethash (coerce-name name) *defined-systems*)
         (cons (get-universal-time) system)))
@@ -1429,4 +1498,18 @@
 
 (defun* merge-component-name-type (name &key type defaults)
+  ;; For backwards compatibility only, for people using internals.
+  ;; Will be removed in a future release, e.g. 2.014.
+  (coerce-pathname name :type type :defaults defaults))
+
+(defun* coerce-pathname (name &key type defaults)
+  "coerce NAME into a PATHNAME.
+When given a string, portably decompose it into a relative pathname:
+#\\/ separates subdirectories. The last #\\/-separated string is as follows:
+if TYPE is NIL, its last #\\. if any separates name and type from from type;
+if TYPE is a string, it is the type, and the whole string is the name;
+if TYPE is :DIRECTORY, the string is a directory component;
+if the string is empty, it's a directory.
+Any directory named .. is read as :BACK.
+Host, device and version components are taken from DEFAULTS."
   ;; The defaults are required notably because they provide the default host
   ;; to the below make-pathname, which may crucially matter to people using
@@ -1437,8 +1520,8 @@
   ;; ASDF:MERGE-PATHNAMES*
   (etypecase name
-    (pathname
+    ((or null pathname)
      name)
     (symbol
-     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
+     (coerce-pathname (string-downcase name) :type type :defaults defaults))
     (string
      (multiple-value-bind (relative path filename)
@@ -1461,5 +1544,5 @@
 
 (defmethod component-relative-pathname ((component component))
-  (merge-component-name-type
+  (coerce-pathname
    (or (slot-value component 'relative-pathname)
        (component-name component))
@@ -1569,6 +1652,6 @@
 (defmethod component-self-dependencies ((o operation) (c component))
   (let ((all-deps (component-depends-on o c)))
-    (remove-if-not (lambda (x)
-                     (member (component-name c) (cdr x) :test #'string=))
+    (remove-if-not #'(lambda (x)
+                       (member (component-name c) (cdr x) :test #'string=))
                    all-deps)))
 
@@ -1577,8 +1660,8 @@
         (self-deps (component-self-dependencies operation c)))
     (if self-deps
-        (mapcan (lambda (dep)
-                  (destructuring-bind (op name) dep
-                    (output-files (make-instance op)
-                                  (find-component parent name))))
+        (mapcan #'(lambda (dep)
+                    (destructuring-bind (op name) dep
+                      (output-files (make-instance op)
+                                    (find-component parent name))))
                 self-deps)
         ;; no previous operations needed?  I guess we work with the
@@ -1634,6 +1717,6 @@
          ;; second). So that's cool.
          (and
-          (every #'probe-file in-files)
-          (every #'probe-file out-files)
+          (every #'probe-file* in-files)
+          (every #'probe-file* out-files)
           (>= (earliest-out) (latest-in))))))))
 
@@ -1682,11 +1765,11 @@
       (retry ()
         :report (lambda (s)
-                  (format s "~@<Retry loading component ~S.~@:>" required-c))
+		  (errfmt s "Retry loading component ~S." required-c))
         :test
         (lambda (c)
-          (or (null c)
-              (and (typep c 'missing-dependency)
-                   (equalp (missing-requires c)
-                           required-c))))))))
+	  (or (null c)
+	      (and (typep c 'missing-dependency)
+		   (equalp (missing-requires c)
+			   required-c))))))))
 
 (defun* do-dep (operation c collect op dep)
@@ -1851,5 +1934,5 @@
 (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)))
 
@@ -1874,5 +1957,5 @@
                :initform *compile-file-failure-behaviour*)
    (flags :initarg :flags :accessor compile-op-flags
-          :initform #-ecl nil #+ecl '(:system-p t))))
+          :initform nil)))
 
 (defun output-file (operation component)
@@ -1883,14 +1966,9 @@
 
 (defmethod perform :before ((operation compile-op) (c source-file))
-  (map nil #'ensure-directories-exist (output-files operation c)))
-
-#+ecl
-(defmethod perform :after ((o compile-op) (c cl-source-file))
-  ;; Note how we use OUTPUT-FILES to find the binary locations
-  ;; This allows the user to override the names.
-  (let* ((files (output-files o c))
-         (object (first files))
-         (fasl (second files)))
-    (c:build-fasl fasl :lisp-files (list object))))
+   (loop :for file :in (asdf:output-files operation c)
+     :for pathname = (if (typep file 'logical-pathname)
+                         (translate-logical-pathname file)
+                         file)
+     :do (ensure-directories-exist pathname)))
 
 (defmethod perform :after ((operation operation) (c component))
@@ -1898,8 +1976,6 @@
         (get-universal-time)))
 
-(declaim (ftype (function ((or pathname string)
-                           &rest t &key (:output-file t) &allow-other-keys)
-                          (values t t t))
-                compile-file*))
+(defvar *compile-op-compile-file-function* 'compile-file*
+  "Function used to compile lisp files.")
 
 ;;; perform is required to check output-files to find out where to put
@@ -1914,10 +1990,10 @@
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply #'compile-file* source-file :output-file output-file
+        (apply *compile-op-compile-file-function* source-file :output-file output-file
                (compile-op-flags operation))
       (when warnings-p
         (case (operation-on-warnings operation)
           (:warn (warn
-                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
+                  "COMPILE-FILE warned while performing ~A on ~A."
                   operation c))
           (:error (error 'compile-warned :component c :operation operation))
@@ -1926,5 +2002,5 @@
         (case (operation-on-failure operation)
           (:warn (warn
-                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+                  "COMPILE-FILE failed while performing ~A on ~A."
                   operation c))
           (:error (error 'compile-failed :component c :operation operation))
@@ -1936,8 +2012,6 @@
   (declare (ignorable operation))
   (let ((p (lispize-pathname (component-pathname c))))
-    #-:broken-fasl-loader
-    (list (compile-file-pathname p #+ecl :type #+ecl :object)
-          #+ecl (compile-file-pathname p :type :fasl))
-    #+:broken-fasl-loader (list p)))
+    #-broken-fasl-loader (list (compile-file-pathname p))
+    #+broken-fasl-loader (list p)))
 
 (defmethod perform ((operation compile-op) (c static-file))
@@ -1965,9 +2039,5 @@
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  (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)))))
+  (map () #'load (input-files o c)))
 
 (defmethod perform-with-restarts (operation component)
@@ -2062,8 +2132,8 @@
   (let ((what-would-load-op-do (cdr (assoc 'load-op
                                            (component-in-order-to c)))))
-    (mapcar (lambda (dep)
-              (if (eq (car dep) 'load-op)
-                  (cons 'load-source-op (cdr dep))
-                  dep))
+    (mapcar #'(lambda (dep)
+                (if (eq (car dep) 'load-op)
+                    (cons 'load-source-op (cdr dep))
+                    dep))
             what-would-load-op-do)))
 
@@ -2128,10 +2198,10 @@
                 :report
                 (lambda (s)
-                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
+		  (errfmt s "Retry ~A." (operation-description op component))))
               (accept ()
                 :report
                 (lambda (s)
-                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
-                          (operation-description op component)))
+		  (errfmt s "Continue, treating ~A as having been successful."
+			  (operation-description op component)))
                 (setf (gethash (type-of op)
                                (component-operation-times component))
@@ -2211,5 +2281,7 @@
   (let* ((file-pathname (load-pathname))
          (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
-    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
+    (or (and pathname-supplied-p
+             (merge-pathnames* (coerce-pathname pathname :type :directory)
+                               directory-pathname))
         directory-pathname
         (default-directory))))
@@ -2254,5 +2326,5 @@
            (or (module-default-component-class parent)
                (find-class *default-component-class*)))
-      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
+      (sysdef-error "don't recognize component type ~A" type)))
 
 (defun* maybe-add-tree (tree op1 op2 c)
@@ -2311,6 +2383,6 @@
          ;; methods will not be for this particular gf
          ;; But this is hardly performance-critical
-         (lambda (m)
-           (remove-method (symbol-function name) m))
+         #'(lambda (m)
+             (remove-method (symbol-function name) m))
          (component-inline-methods component)))
   ;; clear methods, then add the new ones
@@ -2513,5 +2585,5 @@
 (defun* system-relative-pathname (system name &key type)
   (merge-pathnames*
-   (merge-component-name-type name :type type)
+   (coerce-pathname name :type type)
    (system-source-directory system)))
 
@@ -2524,11 +2596,11 @@
 
 (defparameter *implementation-features*
-  '((:acl :allegro)
-    (:lw :lispworks)
-    (:digitool) ; before clozure, so it won't get preempted by ccl
+  '((:abcl :armedbear)
+    (:acl :allegro)
+    (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
     (:ccl :clozure)
     (:corman :cormanlisp)
-    (:abcl :armedbear)
-    :sbcl :cmu :clisp :gcl :ecl :scl))
+    (:lw :lispworks)
+    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
 
 (defparameter *os-features*
@@ -2538,5 +2610,6 @@
     (:macosx :darwin :darwin-target :apple)
     :freebsd :netbsd :openbsd :bsd
-    :unix))
+    :unix
+    :genera))
 
 (defparameter *architecture-features*
@@ -2550,5 +2623,6 @@
     (:sparc32 :sparc)
     (:arm :arm-target)
-    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
+    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
+    :imach))
 
 (defun* lisp-version-string ()
@@ -2568,5 +2642,5 @@
                       (if (member :64bit *features*) "-64bit" ""))
     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-    #+clisp (subseq s 0 (position #\space s))
+    #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
                       ccl::*openmcl-major-version*
@@ -2574,5 +2648,4 @@
                       (logand ccl::fasl-version #xFF))
     #+cmu (substitute #\- #\/ s)
-    #+digitool (subseq s 8)
     #+ecl (format nil "~A~@[-~A~]" s
                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
@@ -2580,10 +2653,13 @@
                       (subseq vcs-id 0 8))))
     #+gcl (subseq s (1+ (position #\space s)))
+    #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
+               (format nil "~D.~D" major minor))
     #+lispworks (format nil "~A~@[~A~]" s
                         (when (member :lispworks-64bit *features*) "-64bit"))
     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
-    #+(or cormanlisp mcl sbcl scl) s
-    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
-          ecl gcl lispworks mcl sbcl scl) s))
+    #+mcl (subseq s 8) ; strip the leading "Version "
+    #+(or cormanlisp sbcl scl) s
+    #-(or allegro armedbear clisp clozure cmu cormanlisp
+          ecl gcl genera lispworks mcl sbcl scl) s))
 
 (defun* first-feature (features)
@@ -2617,13 +2693,13 @@
           (os   (maybe-warn (first-feature *os-features*)
                             "No os feature found in ~a." *os-features*))
-          (arch #+clisp "" #-clisp
-                (maybe-warn (first-feature *architecture-features*)
-                            "No architecture feature found in ~a."
-                            *architecture-features*))
+          (arch (or #-clisp
+                    (maybe-warn (first-feature *architecture-features*)
+                                "No architecture feature found in ~a."
+                                *architecture-features*)))
           (version (maybe-warn (lisp-version-string)
                                "Don't know how to get Lisp implementation version.")))
       (substitute-if
-       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
-       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
+       #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
+       (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
 
 
@@ -2632,14 +2708,14 @@
 
 (defparameter *inter-directory-separator*
-  #+(or unix cygwin) #\:
-  #-(or unix cygwin) #\;)
+  #+asdf-unix #\:
+  #-asdf-unix #\;)
 
 (defun* user-homedir ()
-  (truename (user-homedir-pathname)))
+  (truenamize (pathname-directory-pathname (user-homedir-pathname))))
 
 (defun* try-directory-subpath (x sub &key type)
   (let* ((p (and x (ensure-directory-pathname x)))
          (tp (and p (probe-file* p)))
-         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
+         (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
          (ts (and sp (probe-file* sp))))
     (and ts (values sp ts))))
@@ -2652,5 +2728,5 @@
            :for dir :in (split-string dirs :separator ":")
            :collect (try dir "common-lisp/"))
-       #+(and (or win32 windows mswindows mingw32) (not cygwin))
+       #+asdf-windows
         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
@@ -2661,9 +2737,10 @@
    #'null
    (append
-    #+(and (or win32 windows mswindows mingw32) (not cygwin))
+    #+asdf-windows
     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
       `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
         ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+    #+asdf-unix
     (list #p"/etc/common-lisp/"))))
 (defun* in-first-directory (dirs x)
@@ -2734,5 +2811,5 @@
   (apply 'directory pathname-spec
          (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
-                             #+ccl '(:follow-links nil)
+                             #+clozure '(:follow-links nil)
                              #+clisp '(:circle t :if-does-not-exist :ignore)
                              #+(or cmu scl) '(:follow-links nil :truenamep nil)
@@ -2782,5 +2859,5 @@
     (or
      (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
-     #+(and (or win32 windows mswindows mingw32) (not cygwin))
+     #+asdf-windows
      (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
      '(:home ".cache" "common-lisp" :implementation))))
@@ -2797,10 +2874,10 @@
         (list
          (stable-sort (copy-list new-value) #'>
-                      :key (lambda (x)
-                             (etypecase (car x)
-                               ((eql t) -1)
-                               (pathname
-                                (let ((directory (pathname-directory (car x))))
-                                  (if (listp directory) (length directory) 0))))))))
+                      :key #'(lambda (x)
+                               (etypecase (car x)
+                                 ((eql t) -1)
+                                 (pathname
+                                  (let ((directory (pathname-directory (car x))))
+                                    (if (listp directory) (length directory) 0))))))))
   new-value)
 
@@ -2841,5 +2918,5 @@
               ((eql :implementation) (implementation-identifier))
               ((eql :implementation-type) (string-downcase (implementation-type)))
-              #-(and (or win32 windows mswindows mingw32) (not cygwin))
+              #+asdf-unix
               ((eql :uid) (princ-to-string (get-uid)))))
          (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
@@ -2912,5 +2989,5 @@
                       (member :default-directory :*/ :**/ :*.*.*
                         :implementation :implementation-type
-                        #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
+                        #+asdf-unix :uid)))))
     (or (typep x 'boolean)
         (absolute-component-p x)
@@ -3004,5 +3081,6 @@
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
+    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
+                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; 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
@@ -3015,6 +3093,6 @@
     :enable-user-cache))
 
-(defparameter *output-translations-file* #p"asdf-output-translations.conf")
-(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
+(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
 
 (defun* user-output-translations-pathname ()
@@ -3044,5 +3122,5 @@
      (process-output-translations (validate-output-translations-directory pathname)
                                   :inherit inherit :collect collect))
-    ((probe-file pathname)
+    ((probe-file* pathname)
      (process-output-translations (validate-output-translations-file pathname)
                                   :inherit inherit :collect collect))
@@ -3107,8 +3185,11 @@
    :test 'equal :from-end t))
 
-(defun* initialize-output-translations (&optional parameter)
+(defvar *output-translations-parameter* nil)
+
+(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
   "read the configuration, initialize the internal configuration variable,
 return the configuration"
-  (setf (output-translations) (compute-output-translations parameter)))
+  (setf *output-translations-parameter* parameter
+        (output-translations) (compute-output-translations parameter)))
 
 (defun* disable-output-translations ()
@@ -3186,5 +3267,5 @@
 
 (defun* delete-file-if-exists (x)
-  (when (and x (probe-file x))
+  (when (and x (probe-file* x))
     (delete-file x)))
 
@@ -3279,5 +3360,5 @@
 ;;;; http://www.wotsit.org/list.asp?fc=13
 
-#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+#+(and asdf-windows (not clisp))
 (progn
 (defparameter *link-initial-dword* 76)
@@ -3389,10 +3470,9 @@
 (defun directory-has-asd-files-p (directory)
   (ignore-errors
-    (directory* (merge-pathnames* *wild-asd* directory))
-    t))
+    (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
 
 (defun subdirectories (directory)
   (let* ((directory (ensure-directory-pathname directory))
-         #-cormanlisp
+         #-(or cormanlisp genera)
          (wild (merge-pathnames*
                 #-(or abcl allegro lispworks scl)
@@ -3401,15 +3481,19 @@
                 directory))
          (dirs
-          #-cormanlisp
+          #-(or cormanlisp genera)
           (ignore-errors
-            (directory* wild . #.(or #+ccl '(:directories t :files nil)
-                                     #+digitool '(:directories t))))
-          #+cormanlisp (cl::directory-subdirs directory))
-         #+(or abcl allegro lispworks scl)
+            (directory* wild . #.(or #+clozure '(:directories t :files nil)
+                                     #+mcl '(:directories t))))
+          #+cormanlisp (cl::directory-subdirs directory)
+          #+genera (fs:directory-list directory))
+         #+(or abcl allegro genera 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)))
+                              #+genera #'(lambda (x) (getf (cdr x) :directory))
+                              #-(or abcl allegro genera lispworks) #'directory-pathname-p
+                              dirs))
+         #+genera
+         (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
     dirs))
 
@@ -3506,10 +3590,10 @@
     default-source-registry))
 
-(defparameter *source-registry-file* #p"source-registry.conf")
-(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
+(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
 
 (defun* wrapping-source-registry ()
   `(:source-registry
-    #+sbcl (:tree ,(getenv "SBCL_HOME"))
+    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
     :inherit-configuration
     #+cmu (:tree #p"modules:")))
@@ -3518,7 +3602,7 @@
     `(:source-registry
       #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
-      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
+      (:directory ,(default-directory))
       ,@(let*
-         #+(or unix cygwin)
+         #+asdf-unix
          ((datahome
            (or (getenv "XDG_DATA_HOME")
@@ -3527,5 +3611,5 @@
            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
           (dirs (cons datahome (split-string datadirs :separator ":"))))
-         #+(and (or win32 windows mswindows mingw32) (not cygwin))
+         #+asdf-windows
          ((datahome (getenv "APPDATA"))
           (datadir
@@ -3534,5 +3618,5 @@
                             "Application Data"))
           (dirs (list datahome datadir)))
-         #-(or unix win32 windows mswindows mingw32 cygwin)
+         #-(or asdf-unix asdf-windows)
          ((dirs ()))
          (loop :for dir :in dirs
@@ -3565,5 +3649,5 @@
        (process-source-registry (validate-source-registry-directory pathname)
                                 :inherit inherit :register register)))
-    ((probe-file pathname)
+    ((probe-file* pathname)
      (let ((*here-directory* (pathname-directory-pathname pathname)))
        (process-source-registry (validate-source-registry-file pathname)
@@ -3621,6 +3705,6 @@
           ,parameter
           ,@*default-source-registries*)
-        :register (lambda (directory &key recurse exclude)
-                    (collect (list directory :recurse recurse :exclude exclude)))))
+        :register #'(lambda (directory &key recurse exclude)
+                      (collect (list directory :recurse recurse :exclude exclude)))))
      :test 'equal :from-end t)))
 
@@ -3635,6 +3719,9 @@
          :recurse recurse :exclude exclude :collect #'collect)))))
 
-(defun* initialize-source-registry (&optional parameter)
-  (setf (source-registry) (compute-source-registry parameter)))
+(defvar *source-registry-parameter* nil)
+
+(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
+  (setf *source-registry-parameter* parameter
+        (source-registry) (compute-source-registry parameter)))
 
 ;; Checks an initial variable to see whether the state is initialized
@@ -3669,7 +3756,7 @@
       ((style-warning #'muffle-warning)
        (missing-component (constantly nil))
-       (error (lambda (e)
-                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
-                        name e))))
+       (error #'(lambda (e)
+                  (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"
+                          name e))))
     (let* ((*verbose-out* (make-broadcast-stream))
            (system (find-system (string-downcase name) nil)))
@@ -3695,15 +3782,4 @@
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
 ;;;;
-;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  #+ecl ;; Support upgrade from before ECL went to 1.369
-  (when (fboundp 'compile-op-system-p)
-    (defmethod compile-op-system-p ((op compile-op))
-      (getf :system-p (compile-op-flags op)))
-    (defmethod initialize-instance :after ((op compile-op)
-                                           &rest initargs
-                                           &key system-p &allow-other-keys)
-      (declare (ignorable initargs))
-      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
 
 ;;; If a previous version of ASDF failed to read some configuration, try again.