Changeset 13717

Timestamp:

01/04/12 21:48:45 (11 years ago)

Author:

Mark Evenson

Message:

Backport r13702: update to asdf-2.019 with ABCL patch.

Location:

branches/1.0.x/abcl

Files:

• doc/asdf/asdf.texinfo (modified) (4 diffs)
• src/org/armedbear/lisp/asdf.lisp (modified) (53 diffs)

branches/1.0.x/abcl/doc/asdf/asdf.texinfo

@@ -896 +896 @@
 system-definition := ( defsystem system-designator @var{system-option}* )
 
-system-option := :defsystem-depends-on system-list
+system-option := :defsystem-depends-on system-list 
+                 | :class class-name (see discussion below)
                  | module-option
                  | option
@@ -959 +960 @@
 the current package @code{my-system-asd} can be specified as
 @code{:my-component-type}, or @code{my-component-type}.
+
+@subsection System class names
+
+A system class name will be looked up in the same way as a Component
+type (see above).  Typically, one will not need to specify a system
+class name, unless using a non-standard system class defined in some
+ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON},
+see below.  For such class names in the ASDF package, we recommend that
+the @code{:class} option be specified using a keyword symbol, such as
+
+@example
+:class :MY-NEW-SYSTEM-SUBCLASS
+@end example
+
+This practice will ensure that package name conflicts are avoided.
+Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into
+the current package @emph{before} it has been exported from the ASDF
+extension loaded by @code{:defsystem-depends-on}, causing a name
+conflict in the current package.
 
 @subsection Defsystem depends on
@@ -2831 +2851 @@
 
 When declaring a component (system, module, file),
-you can specify a keyword argument @code{:around-compile some-symbol}.
-If left unspecified, the value will be inherited from the parent component if any,
-or with a default of @code{nil} if no value is specified in any transitive parent.
-
-The argument must be a either fbound symbol or @code{nil}.
+you can specify a keyword argument @code{:around-compile function}.
+If left unspecified,
+the value will be inherited from the parent component if any,
+or with a default of @code{nil}
+if no value is specified in any transitive parent.
+
+The argument must be a either @code{nil}, a fbound symbol,
+a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)})
+a function object (e.g. using @code{#.#'} but that's discouraged
+because it prevents the introspection done by e.g. asdf-dependency-grovel),
+or a string that when read yields a symbol or a lambda-expression.
 @code{nil} means the normal compile-file function will be called.
-A symbol means the function fbound to it will be called with a single argument,
-a thunk that calls the compile-file function;
-the function you specify must then funcall that thunk
-inside whatever wrapping you want.
+A non-nil value designates a function of one argument
+that will be called with a thunk for calling
+the compile-file function with proper arguments.
+
+Note that by using a string, you may reference
+a function, symbol and/or package
+that will only be created later during the build, but
+isn't yet present at the time the defsystem form is evaluated.
+However, if your entire system is using such a hook, you may have to
+explicitly override the hook with @code{nil} for all the modules and files
+that are compiled before the hook is defined.
 
 Using this hook, you may achieve such effects as:
@@ -3650 +3683 @@
 @end lisp
 
+@comment FIXME: Add a FAQ about how to use a new system class...
+
 
 @node  TODO list, Inspiration, FAQ, Top

branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -1 +1 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.017.22: Another System Definition Facility.
+;;; This is ASDF 2.019: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -57 +57 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;;; Implementation-dependent tweaks
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
@@ -87 +87 @@
   ;; Strip out formatting that is not supported on Genera.
   ;; Has to be inside the eval-when to make Lispworks happy (!)
+  (defun strcat (&rest strings)
+    (apply 'concatenate 'string strings))
   (defmacro compatfmt (format)
     #-(or gcl genera) format
@@ -98 +100 @@
            ("~:>" . ""))) :do
       (loop :for found = (search unsupported format) :while found :do
-        (setf format
-              (concatenate 'simple-string
-                           (subseq format 0 found) replacement
-                           (subseq format (+ found (length unsupported)))))))
+        (setf format (strcat (subseq format 0 found) replacement
+                             (subseq format (+ found (length unsupported)))))))
     format)
   (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
@@ -111 +111 @@
          ;; "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.017.22")
+         (asdf-version "2.019")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
@@ -189 +189 @@
                      (push sym formerly-exported-symbols)))
                (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'string-equal)
+                 (unless (member sym bothly-exported-symbols :test 'equal)
                    (push sym newly-exported-symbols)))
                (loop :for user :in (package-used-by-list package)
@@ -230 +230 @@
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
-            #:split #:make-collector
+            #:split #:make-collector #:do-dep #:do-one-dep
+            #:resolve-relative-location-component #:resolve-absolute-location-component
             #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
            :export
-           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
+           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
             #:system-definition-pathname #:with-system-definitions
-            #:search-for-system-definition #:find-component ; miscellaneous
-            #:compile-system #:load-system #:test-system #:clear-system
-            #:compile-op #:load-op #:load-source-op
-            #:test-op
-            #:operation               ; operations
-            #:feature                 ; sort-of operation
-            #:version                 ; metaphorically sort-of an operation
-            #:version-satisfies
+            #:search-for-system-definition #:find-component #:component-find-path
+            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
+            #:operation #:compile-op #:load-op #:load-source-op #:test-op
+            #:feature #:version #:version-satisfies
             #:upgrade-asdf
             #:implementation-identifier #:implementation-type
-
-            #:input-files #:output-files #:output-file #:perform ; operation methods
+            #:input-files #:output-files #:output-file #:perform
             #:operation-done-p #:explain
 
@@ -338 +334 @@
             #:system-registered-p
             #:asdf-message
+            #:user-output-translations-pathname
+            #:system-output-translations-pathname
+            #:user-output-translations-directory-pathname
+            #:system-output-translations-directory-pathname
+            #:user-source-registry
+            #:system-source-registry
+            #:user-source-registry-directory
+            #:system-source-registry-directory
 
             ;; Utilities
             #:absolute-pathname-p
             ;; #:aif #:it
-            ;; #:appendf
+            ;; #:appendf #:orf
             #:coerce-name
             #:directory-pathname-p
@@ -350 +354 @@
             ;; #:length=n-p
             ;; #:find-symbol*
-            #:merge-pathnames*
-            #:coerce-pathname
+            #:merge-pathnames* #:coerce-pathname #:subpathname
             #:pathname-directory-pathname
             #:read-file-forms
@@ -414 +417 @@
                 condition-format condition-location
                 coerce-name)
+         (ftype (function (&optional t) (values)) initialize-source-registry)
          #-(or cormanlisp gcl-pre2.7)
          (ftype (function (t t) t) (setf module-components-by-name)))
@@ -422 +426 @@
 (progn
   (deftype logical-pathname () nil)
-  (defun* make-broadcast-stream () *error-output*)
-  (defun* file-namestring (p)
+  (defun make-broadcast-stream () *error-output*)
+  (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
@@ -523 +527 @@
               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
 
+(defun* ununspecific (x)
+  (if (eq x :unspecific) nil x))
+
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
@@ -541 +548 @@
          (type (or (pathname-type specified) (pathname-type defaults)))
          (version (or (pathname-version specified) (pathname-version defaults))))
-    (labels ((ununspecific (x)
-               (if (eq x :unspecific) nil x))
-             (unspecific-handler (p)
+    (labels ((unspecific-handler (p)
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
@@ -894 +899 @@
         (port (ext:pathname-port pathname))
         (directory (pathname-directory pathname)))
-    (flet ((not-unspecific (component)
-             (and (not (eq component :unspecific)) component)))
-      (cond ((or (not-unspecific port)
-                 (and (not-unspecific host) (plusp (length host)))
-                 (not-unspecific scheme))
-             (let ((prefix ""))
-               (when (not-unspecific port)
-                 (setf prefix (format nil ":~D" port)))
-               (when (and (not-unspecific host) (plusp (length host)))
-                 (setf prefix (concatenate 'string host prefix)))
-               (setf prefix (concatenate 'string ":" prefix))
-               (when (not-unspecific scheme)
-               (setf prefix (concatenate 'string scheme prefix)))
-               (assert (and directory (eq (first directory) :absolute)))
-               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
-                              :defaults pathname)))
-            (t
-             pathname)))))
+    (if (or (ununspecific port)
+            (and (ununspecific host) (plusp (length host)))
+            (ununspecific scheme))
+        (let ((prefix ""))
+          (when (ununspecific port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (ununspecific host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (ununspecific scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+                         :defaults pathname)))
+    pathname))
 
 ;;;; -------------------------------------------------------------------------
@@ -1174 +1176 @@
                :initform nil)))
 
-;;; I believe that the following could probably be more efficiently done
-;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
-;;; appropriately pass the slots to have their initforms re-applied, but I
-;;; do not know how to write such a method. [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj component) &rest initargs
-                                         &key (version nil version-suppliedp)
-                                              (description nil description-suppliedp)
-                                              (long-description nil
-                                                                long-description-suppliedp)
-                                              (load-dependencies nil
-                                                                 ld-suppliedp)
-                                              in-order-to
-                                              do-first
-                                              inline-methods
-                                              parent
-                                              properties)
-  "We reuse component objects from previously-existing systems, so we need to
-make sure we clear them thoroughly."
-  (declare (ignore initargs load-dependencies
-                   long-description description version))
-  ;; this is a cache and should be cleared
-  (slot-makunbound obj 'absolute-pathname)
-  ;; component operation times are no longer valid when the component changes
-  (clrhash (component-operation-times obj))
-  (unless version-suppliedp (slot-makunbound obj 'version))
-  (unless description-suppliedp
-    (slot-makunbound obj 'description))
-  (unless long-description-suppliedp
-    (slot-makunbound obj 'long-description))
-  ;; replicate the logic of the initforms...
-  (unless ld-suppliedp
-    (setf (component-load-dependencies obj) nil))
-  (setf (component-in-order-to obj) in-order-to
-        (component-do-first obj) do-first
-        (component-inline-methods obj) inline-methods
-        (slot-value obj 'parent) parent
-        (slot-value obj 'properties) properties))
-
-
 (defun* component-find-path (component)
   (reverse
@@ -1285 +1248 @@
     :accessor module-default-component-class)))
 
-;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
-;;; [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
-  "Clear MODULE's slots so it can be reused."
-  (slot-makunbound obj 'components-by-name)
-  ;; this may be a more elegant approach than in the
-  ;; COMPONENT method [2011/09/02:rpg]
-  (loop :for (initarg slot-name default) :in
-        `((:components components nil)
-          (:if-component-dep-fails if-component-dep-fails :fail)
-          (:default-component-class default-component-class
-              ,*default-component-class*))
-        :unless (member initarg initargs)
-        :do (setf (slot-value obj slot-name) default)))
-
 (defun* component-parent-pathname (component)
   ;; No default anymore (in particular, no *default-pathname-defaults*).
@@ -1333 +1281 @@
   new-value)
 
-(defclass system (module)
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components slots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) #|(components) (components-by-names)|#))
+
+(defclass system (module proto-system)
   (;; description and long-description are now available for all component's,
    ;; but now also inherited from component, but we add the legacy accessor
@@ -1345 +1298 @@
                 :writer %set-system-source-file)
    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
-
-;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
-;;; [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
-  "Clear SYSTEM's slots so it can be reused."
-  ;; note that SYSTEM-SOURCE-FILE is very specially handled,
-  ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
-  ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
-  ;; because they are always, effectively, reused, since the system component
-  ;; is made early in DO-DEFSYSTEM, instead of being made later, in
-  ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
-  (loop :for (initarg slot-name) :in
-        `((:author author)
-          (:maintainer maintainer)
-          (:licence licence)
-          (:defsystem-depends-on defsystem-depends-on))
-        :unless (member initarg initargs)
-        :do (slot-makunbound obj slot-name)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1451 +1386 @@
                               network-volume-offset
                               #x14))))
-      (concatenate 'string
-        (read-null-terminated-string s)
-        (progn
-          (file-position s (+ start remaining-offset))
-          (read-null-terminated-string s))))))
+      (strcat (read-null-terminated-string s)
+              (progn
+                (file-position s (+ start remaining-offset))
+                (read-null-terminated-string s))))))
 
 (defun* parse-windows-shortcut (pathname)
@@ -1542 +1476 @@
 ;;; convention that functions in this list are prefixed SYSDEF-
 
-(defparameter *system-definition-search-functions*
-  '(sysdef-central-registry-search
-    sysdef-source-registry-search
-    sysdef-find-asdf))
+(defvar *system-definition-search-functions* '())
+
+(setf *system-definition-search-functions*
+      (append
+       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
+       (remove 'contrib-sysdef-search *system-definition-search-functions*)
+       ;; Tuck our defaults at the end of the list if they were absent.
+       ;; This is imperfect, in case they were removed on purpose,
+       ;; but then it will be the responsibility of whoever does that
+       ;; to upgrade asdf before he does such a thing rather than after.
+       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
+                  '(sysdef-central-registry-search
+                    sysdef-source-registry-search
+                    sysdef-find-asdf))))
 
 (defun* search-for-system-definition (system)
-  (let ((system-name (coerce-name system)))
-    (some #'(lambda (x) (funcall x system-name))
-          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
+  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+        (cons 'find-system-if-being-defined
+              *system-definition-search-functions*)))
 
 (defvar *central-registry* nil
@@ -1600 +1544 @@
                (make-pathname
                 :defaults defaults :version :newest :case :local
-                :name (concatenate 'string name ".asd")
+                :name (strcat name ".asd")
                 :type "lnk")))
           (when (probe-file* shortcut)
@@ -1674 +1618 @@
 
 (defmethod find-system ((name null) &optional (error-p t))
+  (declare (ignorable name))
   (when error-p
     (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
@@ -1693 +1638 @@
         (funcall thunk))))
 
-(defmacro with-system-definitions (() &body body)
+(defmacro with-system-definitions ((&optional) &body body)
   `(call-with-system-definitions #'(lambda () ,@body)))
 
@@ -1709 +1654 @@
                    (*default-pathname-defaults*
                     (pathname-directory-pathname pathname)))
+               ;;; XXX Kludge for ABCL ticket #181 
+               #+abcl
+               (when (ext:pathname-jar-p pathname) 
+                 (setf *default-pathname-defaults* 
+                       (make-pathname :device nil :defaults *default-pathname-defaults*)))
                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                              pathname package)
@@ -1714 +1664 @@
         (delete-package package)))))
 
-(defmethod find-system ((name string) &optional (error-p t))
-  (with-system-definitions ()
-    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
-           (previous (cdr in-memory))
-           (previous (and (typep previous 'system) previous))
-           (previous-time (car in-memory))
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system from.
+Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
+PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
+  (let* ((name (coerce-name name))
+         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+         (previous (cdr in-memory))
+         (previous (and (typep previous 'system) previous))
+         (previous-time (car in-memory))
            (found (search-for-system-definition name))
-           (found-system (and (typep found 'system) found))
-           (pathname (or (and (typep found '(or pathname string)) (pathname found))
-                         (and found-system (system-source-file found-system))
-                         (and previous (system-source-file previous)))))
+         (found-system (and (typep found 'system) found))
+         (pathname (or (and (typep found '(or pathname string)) (pathname found))
+                       (and found-system (system-source-file found-system))
+                       (and previous (system-source-file previous))))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (when foundp
       (setf pathname (resolve-symlinks* pathname))
       (when (and pathname (not (absolute-pathname-p pathname)))
@@ -1734 +1694 @@
         (%set-system-source-file pathname previous)
         (setf previous-time nil))
-      (when (and found-system (not previous))
-        (register-system found-system))
-      (when (and pathname
-                 (or (not previous-time)
-                     ;; don't reload if it's already been loaded,
-                     ;; or its filestamp is in the future which means some clock is skewed
-                     ;; and trying to load might cause an infinite loop.
-                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
-        (load-sysdef name pathname))
-      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
-        (cond
-          (in-memory
-           (when pathname
-             (setf (car in-memory) (safe-file-write-date pathname)))
-           (cdr in-memory))
-          (error-p
-           (error 'missing-component :requires name)))))))
+      (values foundp found-system pathname previous previous-time))))
+
+(defmethod find-system ((name string) &optional (error-p t))
+  (with-system-definitions ()
+    (loop
+      (restart-case
+          (multiple-value-bind (foundp found-system pathname previous previous-time)
+              (locate-system name)
+            (declare (ignore foundp))
+            (when (and found-system (not previous))
+              (register-system found-system))
+            (when (and pathname
+                       (or (not previous-time)
+                           ;; don't reload if it's already been loaded,
+                           ;; or its filestamp is in the future which means some clock is skewed
+                           ;; and trying to load might cause an infinite loop.
+                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+              (load-sysdef name pathname))
+            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (safe-file-write-date pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
+          (initialize-source-registry))))))
 
 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
@@ -1872 +1846 @@
    :defaults (component-parent-pathname component)))
 
+<<<<<<< .working
+=======
+(defun* subpathname (pathname subpath &key type)
+  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
+                                  (pathname-directory-pathname pathname))))
+
+(defun subpathname* (pathname subpath &key type)
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
+
+>>>>>>> .merge-right.r13702
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
@@ -1974 +1959 @@
 
 (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=))
-                   all-deps)))
+  (remove-if-not
+   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
+   (component-depends-on o c)))
 
 (defmethod input-files ((operation operation) (c component))
@@ -2348 +2332 @@
      (around-compile-hook (component-parent c)))))
 
+(defun ensure-function (fun &key (package :asdf))
+  (etypecase fun
+    ((or symbol function) fun)
+    (cons (eval `(function ,fun)))
+    (string (eval `(function ,(with-standard-io-syntax
+                               (let ((*package* (find-package package)))
+                                 (read-from-string fun))))))))
+
 (defmethod call-with-around-compile-hook ((c component) thunk)
   (let ((hook (around-compile-hook c)))
     (if hook
-        (funcall hook thunk)
+        (funcall (ensure-function hook) thunk)
         (funcall thunk))))
 
@@ -2537 +2529 @@
 (defgeneric* perform-plan (plan &key))
 
+;;;; Separating this into a different function makes it more forward-compatible
+(defun* cleanup-upgraded-asdf (old-version)
+  (let ((new-version (asdf:asdf-version)))
+    (unless (equal old-version new-version)
+      (cond
+        ((version-satisfies new-version old-version)
+         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                       old-version new-version))
+        ((version-satisfies old-version new-version)
+         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+               old-version new-version))
+        (t
+         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+                       old-version new-version)))
+      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
+        ;; Invalidate all systems but ASDF itself.
+        (setf *defined-systems* (make-defined-systems-table))
+        (register-system asdf)
+        ;; If we're in the middle of something, restart it.
+        (when *systems-being-defined*
+          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
+            (clrhash *systems-being-defined*)
+            (dolist (s l) (find-system s nil))))
+        t))))
+
 ;;;; Try to upgrade of ASDF. If a different version was used, return T.
 ;;;; We need do that before we operate on anything that depends on ASDF.
@@ -2543 +2560 @@
     (handler-bind (((or style-warning warning) #'muffle-warning))
       (operate 'load-op :asdf :verbose nil))
-    (let ((new-version (asdf:asdf-version)))
-      (block nil
-        (cond
-          ((equal version new-version)
-           (return nil))
-          ((version-satisfies new-version version)
-           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
-                         version new-version))
-          ((version-satisfies version new-version)
-           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
-                 version new-version))
-          (t
-           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
-                         version new-version)))
-        (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
-          ;; invalidate all systems but ASDF itself
-          (setf *defined-systems* (make-defined-systems-table))
-          (register-system asdf)
-          t)))))
+    (cleanup-upgraded-asdf version)))
 
 (defmethod perform-plan ((steps list) &key)
@@ -2625 +2624 @@
   (setf (documentation 'oos 'function)
         (format nil
-                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
                 operate-docstring))
   (setf (documentation 'operate 'function)
@@ -2636 +2635 @@
   (apply 'operate 'load-op system args)
   t)
+
+(defun* load-systems (&rest systems)
+  (map () 'load-system systems))
 
 (defun* compile-system (system &rest args &key force verbose version
@@ -2695 +2697 @@
         (progn
           (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it))
+               (if (find c (cdr it) :test #'equal)
                    nil
                    (setf (cdr it) (cons c (cdr it))))
@@ -2717 +2719 @@
 
 (defun* sysdef-error-component (msg type name value)
-  (sysdef-error (concatenate 'string msg
-                             (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                 type name value))
 
@@ -2795 +2796 @@
               version name parent)))
 
-    (let* ((other-args (remove-keys
-                        '(components pathname default-component-class
-                          perform explain output-files operation-done-p
-                          weakly-depends-on
-                          depends-on serial in-order-to)
-                        rest))
+    (let* ((args (list* :name (coerce-name name)
+                        :pathname pathname
+                        :parent parent
+                        (remove-keys
+                         '(components pathname default-component-class
+                           perform explain output-files operation-done-p
+                           weakly-depends-on depends-on serial in-order-to)
+                         rest)))
            (ret (find-component parent name)))
       (when weakly-depends-on
@@ -2806 +2809 @@
       (when *serial-depends-on*
         (push *serial-depends-on* depends-on))
-      (if ret
-          (apply 'reinitialize-instance ret
-                 :name (coerce-name name)
-                 :pathname pathname
-                 :parent parent
-                 other-args)
-          (setf ret
-                (apply 'make-instance (class-for-type parent type)
-                       :name (coerce-name name)
-                       :pathname pathname
-                       :parent parent
-                       other-args)))
+      (if ret ; preserve identity
+          (apply 'reinitialize-instance ret args)
+          (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
@@ -2849 +2843 @@
       ret)))
 
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
 (defun* do-defsystem (name &rest options
                            &key (pathname nil pathname-arg-p) (class 'system)
@@ -2861 +2859 @@
     (let* ((name (coerce-name name))
            (registered (system-registered-p name))
-           (system (cdr (or registered
-                            (register-system (make-instance 'system :name name)))))
+           (registered! (if registered
+                            (rplaca registered (get-universal-time))
+                            (register-system (make-instance 'system :name name))))
+           (system (reset-system (cdr registered!)
+                                :name name :source-file (load-pathname)))
            (component-options (remove-keys '(:class) options)))
-      (%set-system-source-file (load-pathname) system)
       (setf (gethash name *systems-being-defined*) system)
-      (when registered
-        (setf (car registered) (get-universal-time)))
-      (map () 'load-system defsystem-depends-on)
+      (apply 'load-systems defsystem-depends-on)
       ;; We change-class (when necessary) AFTER we load the defsystem-dep's
       ;; since the class might not be defined as part of those.
@@ -2953 +2951 @@
                  (cond
                    ((os-unix-p) "/bin/sh")
-                   ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE!
+                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
                    (t (error "Unsupported OS")))
                  (if (os-unix-p) (list "-c" command) '())
@@ -2964 +2962 @@
       (list "-c" command)
       :input nil :output *verbose-out*))
+
+    #+cormanlisp
+    (win32:system command)
 
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
@@ -3160 +3161 @@
 (defun* user-configuration-directories ()
   (let ((dirs
-         (flet ((try (x sub) (try-directory-subpath x sub)))
-           `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
-             ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
-                 :for dir :in (split-string dirs :separator ":")
-                 :collect (try dir "common-lisp/"))
-             ,@(when (os-windows-p)
-                 `(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
-                             (getenv "LOCALAPPDATA"))
-                         "common-lisp/config/")
-                    ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-                   ,(try (or #+lispworks (sys:get-folder-path :appdata)
-                             (getenv "APPDATA"))
-                         "common-lisp/config/")))
-             ,(try (user-homedir) ".config/common-lisp/")))))
-    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
+         `(,@(when (os-unix-p)
+               (cons
+                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
+                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+                  :for dir :in (split-string dirs :separator ":")
+                  :collect (subpathname* dir "common-lisp/"))))
+           ,@(when (os-windows-p)
+               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
+                                    (getenv "LOCALAPPDATA"))
+                               "common-lisp/config/")
+                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
+                                    (getenv "APPDATA"))
+                                "common-lisp/config/")))
+           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+                       :from-end t :test 'equal)))
 (defun* system-configuration-directories ()
   (cond
@@ -3180 +3183 @@
     ((os-windows-p)
      (aif
-      (flet ((try (x sub) (try-directory-subpath x sub)))
-        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-        (try (or #+lispworks (sys:get-folder-path :common-appdata)
-                 (getenv "ALLUSERSAPPDATA")
-                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
-             "common-lisp/config/"))
+      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
+                        (getenv "ALLUSERSAPPDATA")
+                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
+                    "common-lisp/config/")
       (list it)))))
 
-(defun* in-first-directory (dirs x)
-  (loop :for dir :in dirs
-    :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)
-  (in-first-directory (system-configuration-directories) x))
+(defun* in-first-directory (dirs x &key (direction :input))
+  (loop :with fun = (ecase direction
+                      ((nil :input :probe) 'probe-file*)
+                      ((:output :io) 'identity))
+    :for dir :in dirs
+    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+  (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+  (in-first-directory (system-configuration-directories) x :direction direction))
 
 (defun* configuration-inheritance-directive-p (x)
@@ -3548 +3554 @@
 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
 
-(defun* user-output-translations-pathname ()
-  (in-user-configuration-directory *output-translations-file*))
-(defun* system-output-translations-pathname ()
-  (in-system-configuration-directory *output-translations-file*))
-(defun* user-output-translations-directory-pathname ()
-  (in-user-configuration-directory *output-translations-directory*))
-(defun* system-output-translations-directory-pathname ()
-  (in-system-configuration-directory *output-translations-directory*))
+(defun* user-output-translations-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-directory* :direction direction))
 (defun* environment-output-translations ()
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
@@ -3678 +3684 @@
 
 (defun* apply-output-translations (path)
+  #+cormanlisp (truenamize path) #-cormanlisp
   (etypecase path
-    #+cormanlisp (t (truenamize path))
     (logical-pathname
      path)
@@ -3720 +3726 @@
 (defun* tmpize-pathname (x)
   (make-pathname
-   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :name (strcat "ASDF-TMP-" (pathname-name x))
    :defaults x))
 
@@ -3853 +3859 @@
         :for p = (or (and (typep f 'logical-pathname) f)
                      (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) error
                        (and u (equal (ignore-errors (truename u)) f) u)))
         :when p :collect p)
@@ -3866 +3873 @@
      directory entries
      #'(lambda (f)
-         (make-pathname :defaults directory :version (pathname-version f)
-                        :name (pathname-name f) :type (pathname-type f))))))
+         (make-pathname :defaults directory
+                        :name (pathname-name f) :type (ununspecific (pathname-type f))
+                        :version (ununspecific (pathname-version f)))))))
 
 (defun* directory-asd-files (directory)
@@ -3876 +3884 @@
          #-(or abcl cormanlisp genera xcl)
          (wild (merge-pathnames*
-                #-(or abcl allegro cmu lispworks scl xcl)
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
                 *wild-directory*
-                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
                 directory))
          (dirs
@@ -3888 +3896 @@
           #+cormanlisp (cl::directory-subdirs directory)
           #+genera (fs:directory-list directory))
-         #+(or abcl allegro cmu genera lispworks scl xcl)
+         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
          (dirs (loop :for x :in dirs
                  :for d = #+(or abcl xcl) (extensions:probe-directory x)
                           #+allegro (excl:probe-directory x)
-                          #+(or cmu scl) (directory-pathname-p x)
+                          #+(or cmu sbcl scl) (directory-pathname-p x)
                           #+genera (getf (cdr x) :directory)
                           #+lispworks (lw:file-directory-p x)
                  :when d :collect #+(or abcl allegro xcl) d
                                   #+genera (ensure-directory-pathname (first x))
-                                  #+(or cmu lispworks scl) x)))
+                                  #+(or cmu lispworks sbcl scl) x)))
     (filter-logical-directory-results
      directory dirs
@@ -4020 +4028 @@
     #+cmu (:tree #p"modules:")))
 (defun* default-source-registry ()
-  (flet ((try (x sub) (try-directory-subpath x sub)))
-    `(:source-registry
-      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
-      (:directory ,(default-directory))
+  `(:source-registry
+    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+    (:directory ,(default-directory))
       ,@(loop :for dir :in
           `(,@(when (os-unix-p)
                 `(,(or (getenv "XDG_DATA_HOME")
-                       (try (user-homedir) ".local/share/"))
+                       (subpathname (user-homedir) ".local/share/"))
                   ,@(split-string (or (getenv "XDG_DATA_DIRS")
                                       "/usr/local/share:/usr/share")
@@ -4038 +4045 @@
                   ,(or #+lispworks (sys:get-folder-path :common-appdata)
                        (getenv "ALLUSERSAPPDATA")
-                       (try (getenv "ALLUSERSPROFILE") "Application Data/")))))
-          :collect `(:directory ,(try dir "common-lisp/systems/"))
-          :collect `(:tree ,(try dir "common-lisp/source/")))
-      :inherit-configuration)))
-(defun* user-source-registry ()
-  (in-user-configuration-directory *source-registry-file*))
-(defun* system-source-registry ()
-  (in-system-configuration-directory *source-registry-file*))
-(defun* user-source-registry-directory ()
-  (in-user-configuration-directory *source-registry-directory*))
-(defun* system-source-registry-directory ()
-  (in-system-configuration-directory *source-registry-directory*))
+                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
+          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+      :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+  (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+  (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+  (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+  (in-system-configuration-directory *source-registry-directory* :direction direction))
 (defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
@@ -4127 +4134 @@
      :test 'equal :from-end t)))
 
-;; Will read the configuration and initialize all internal variables,
-;; and return the new configuration.
+;; Will read the configuration and initialize all internal variables.
 (defun* compute-source-registry (&optional parameter (registry *source-registry*))
   (dolist (entry (flatten-source-registry parameter))