From a90ddc62f982d407f12466287b9c56cca7d5b7fc Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Wed, 3 Jul 2013 19:40:26 -0700
Subject: [PATCH] Update  to asdf 3.0.2.

---
 src/contrib/asdf/asdf.lisp | 259 ++++++++++++++++++++++++-------------
 1 file changed, 167 insertions(+), 92 deletions(-)

diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp
index 88949ea67..e90fae758 100644
--- a/src/contrib/asdf/asdf.lisp
+++ b/src/contrib/asdf/asdf.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 3.0.1: Another System Definition Facility.
+;;; This is ASDF 3.0.2: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -70,8 +70,8 @@
            (existing-major-minor (subseq existing-version 0 second-dot))
            (existing-version-number (and existing-version (read-from-string existing-major-minor)))
            (away (format nil "~A-~A" :asdf existing-version)))
-      (when (and existing-version (< existing-version-number
-                                     (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)))
+      (when (and existing-version
+                 (< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))
         (rename-package :asdf away)
         (when *load-verbose*
           (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
@@ -1514,20 +1514,23 @@ or a string describing the format-control of a simple-condition."
 
   (defun os-windows-p ()
     (or #+abcl (featurep :windows)
-        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
+        #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
 
   (defun os-genera-p ()
     (or #+genera t))
 
+  (defun os-oldmac-p ()
+    (or #+mcl t))
+
   (defun detect-os ()
-    (flet ((yes (yes) (pushnew yes *features*))
-           (no (no) (setf *features* (remove no *features*))))
-      (cond
-        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
-        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
-        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
-        (t (error "Congratulations for trying XCVB on an operating system~%~
-that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+    (loop* :with o
+           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
+                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
+           :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
+           :else :do (setf *features* (remove feature *features*))
+           :finally
+           (return (or o (error "Congratulations for trying ASDF on an operating system~%~
+that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
 
   (detect-os))
 
@@ -1911,6 +1914,7 @@ then returning the non-empty string value of the variable"
     "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
    tries hard to make a pathname that will actually behave as documented,
    despite the peculiarities of each implementation"
+    ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
     (declare (ignorable host device directory name type version defaults))
     (apply 'make-pathname
            (append
@@ -1986,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
     ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
     ;; strings and lists of strings or :unspecific
     ;; But CMUCL decides to die on NIL.
+    ;; MCL has issues with make-pathname, nil and defaulting
+    (declare (ignorable defaults))
     #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
                        :host (or #+cmu lisp::*unix-host*)
                        #+scl ,@'(:scheme nil :scheme-specific-part nil
                                  :username nil :password nil :parameters nil :query nil :fragment nil)
                        ;; the default shouldn't matter, but we really want something physical
-                       :defaults defaults))
+                       #-mcl ,@'(:defaults defaults)))
 
   (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
 
@@ -2259,7 +2265,7 @@ to throw an error if the pathname is absolute"
                  (make-pathname*
                   :directory (unless file-only (cons relative path))
                   :name name :type type
-                  :defaults (or defaults *nil-pathname*))
+                  :defaults (or #-mcl defaults *nil-pathname*))
                  (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
 
   (defun unix-namestring (pathname)
@@ -3143,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
 and implementation-defined external-format's")
 
   (defun encoding-external-format (encoding)
-    (funcall *encoding-external-format-hook* encoding)))
+    (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
 
 
 ;;; Safe syntax
@@ -3613,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms."
     #+gcl (lisp:quit code)
     #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
     #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
-    #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+    #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
     #+mkcl (mk-ext:quit :exit-code code)
     #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
                    (quit (find-symbol* :quit :sb-ext nil)))
@@ -3627,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms."
     "Die in error with some error message"
     (with-safe-io-syntax ()
       (ignore-errors
-       (fresh-line *stderr*)
-       (apply #'format *stderr* format arguments)
-       (format! *stderr* "~&")))
+       (format! *stderr* "~&~?~&" format arguments)))
     (quit code))
 
   (defun raw-print-backtrace (&key (stream *debug-io*) count)
@@ -3651,7 +3655,8 @@ This is designed to abstract away the implementation specific quit forms."
     (system::print-backtrace :out stream :limit count)
     #+(or clozure mcl)
     (let ((*debug-io* stream))
-      (ccl:print-call-history :count count :start-frame-number 1)
+      #+clozure (ccl:print-call-history :count count :start-frame-number 1)
+      #+mcl (ccl:print-call-history :detailed-p nil)
       (finish-output stream))
     #+(or cmu scl)
     (let ((debug:*debug-print-level* *print-level*)
@@ -3742,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms."
     #+(or cmu scl) extensions:*command-line-strings*
     #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
     #+gcl si:*command-args*
-    #+genera nil
+    #+(or genera mcl) nil
     #+lispworks sys:*line-arguments-list*
     #+sbcl sb-ext:*posix-argv*
     #+xcl system:*argv*
-    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
+    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
     (error "raw-command-line-arguments not implemented yet"))
 
   (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
@@ -4139,10 +4144,22 @@ return the exit status code of the process that was called.
 if it was NIL, the output is discarded;
 if it was :INTERACTIVE, the output and the input are inherited from the current process.
 
-Otherwise, the output will be processed by SLURP-INPUT-STREAM,
-using OUTPUT as the first argument, and return whatever it returns,
-e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
-Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+Otherwise, OUTPUT should be a value that is a suitable first argument to
+SLURP-INPUT-STREAM.  In this case, RUN-PROGRAM will create a temporary stream
+for the program output.  The program output, in that stream, will be processed
+by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
+RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns.  E.g., using
+:OUTPUT :STRING will have it return the entire output stream as a string.  Use
+ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+
+    ;; TODO: The current version does not honor :OUTPUT NIL on Allegro.  Setting
+    ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
+    ;; what :OUTPUT :INTERACTIVE is advertised to do here.  To get the behavior
+    ;; specified for :OUTPUT NIL, one would have to grab up the process output
+    ;; into a stream and then throw it on the floor.  The consequences of
+    ;; getting this wrong seemed so much worse than having excess output that it
+    ;; is not currently implemented.
+
     ;; TODO: specially recognize :output pathname ?
     (declare (ignorable ignore-error-status element-type external-format))
     #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
@@ -4184,7 +4201,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
                          (excl:run-shell-command
                           #+os-unix (coerce (cons (first command) command) 'vector)
                           #+os-windows command
-                          :input interactive :output (or (and pipe :stream) interactive) :wait wait
+                          :input nil
+                          :output (and pipe :stream) :wait wait
                           #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
                          #+clisp
                          (flet ((run (f &rest args)
@@ -4276,8 +4294,12 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
                #+(or abcl xcl) (ext:run-shell-command command)
                #+allegro
                (excl:run-shell-command
-                command :input interactive :output interactive :wait t
-                        #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
+                command
+                :input nil
+                :output nil
+                :error-output :output ; write STDERR to output, too
+                :wait t
+                #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
                #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
                (process-result (run-program command :pipe nil :interactive interactive) nil)
                #+ecl (ext:system command)
@@ -4626,7 +4648,7 @@ using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently
 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
     #+allegro
     (list :functions-defined excl::.functions-defined.
-	  :functions-called excl::.functions-called.)
+          :functions-called excl::.functions-called.)
     #+clozure
     (mapcar 'reify-deferred-warning
             (if-let (dw ccl::*outstanding-deferred-warnings*)
@@ -4668,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF."
     (declare (ignorable reified-deferred-warnings))
     #+allegro
     (destructuring-bind (&key functions-defined functions-called)
-			reified-deferred-warnings
+        reified-deferred-warnings
       (setf excl::.functions-defined.
             (append functions-defined excl::.functions-defined.)
             excl::.functions-called.
@@ -4883,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY."
 
   (defun* (compile-file*) (input-file &rest keys
                                       &key compile-check output-file warnings-file
-                                      #+clisp lib-file #+(or ecl mkcl) object-file
+                                      #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
                                       &allow-other-keys)
     "This function provides a portable wrapper around COMPILE-FILE.
 It ensures that the OUTPUT-FILE value is only returned and
@@ -4924,12 +4946,23 @@ it will filter them appropriately."
              (or object-file
                  (compile-file-pathname output-file :fasl-p nil)))
            (tmp-file (tmpize-pathname output-file))
+           #+sbcl
+           (cfasl-file (etypecase emit-cfasl
+                         (null nil)
+                         ((eql t) (make-pathname :type "cfasl" :defaults output-file))
+                         (string (parse-namestring emit-cfasl))
+                         (pathname emit-cfasl)))
+           #+sbcl
+           (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
            #+clisp
            (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
       (multiple-value-bind (output-truename warnings-p failure-p)
           (with-saved-deferred-warnings (warnings-file)
             (with-muffled-compiler-conditions ()
-              (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
+              (or #-(or ecl mkcl)
+                  (apply 'compile-file input-file :output-file tmp-file
+                         #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
+                         #-sbcl keywords)
                   #+ecl (apply 'compile-file input-file :output-file
                                (if object-file
                                    (list* object-file :system-p t keywords)
@@ -4954,11 +4987,14 @@ it will filter them appropriately."
            (delete-file-if-exists output-file)
            (when output-truename
              #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
+             #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
              (rename-file-overwriting-target output-truename output-file)
              (setf output-truename (truename output-file)))
            #+clisp (delete-file-if-exists tmp-lib))
           (t ;; error or failed check
            (delete-file-if-exists output-truename)
+           #+clisp (delete-file-if-exists tmp-lib)
+           #+sbcl (delete-file-if-exists tmp-cfasl)
            (setf output-truename nil)))
         (values output-truename warnings-p failure-p))))
 
@@ -5421,7 +5457,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "3.0.1")
+         (asdf-version "3.0.2")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
@@ -5439,7 +5475,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
              #:find-component ;; find-component
              #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
              #:component-depends-on #:operation-done-p #:component-depends-on
-             #:traverse ;; plan
+             #:traverse ;; backward-interface
              #:operate  ;; operate
              #:parse-component-form ;; defsystem
              #:apply-output-translations ;; output-translations
@@ -6618,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
 ;;;; Convenience methods
 (with-upgradability ()
   (defmacro define-convenience-action-methods
-      (function (operation component &optional keyp)
-       &key if-no-operation if-no-component operation-initargs)
+      (function formals &key if-no-operation if-no-component operation-initargs)
     (let* ((rest (gensym "REST"))
            (found (gensym "FOUND"))
+           (keyp (equal (last formals) '(&key)))
+           (formals-no-key (if keyp (butlast formals) formals))
+           (len (length formals-no-key))
+           (operation 'operation)
+           (component 'component)
+           (opix (position operation formals))
+           (coix (position component formals))
+           (prefix (subseq formals 0 opix))
+           (suffix (subseq formals (1+ coix) len))
            (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
+      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
       (flet ((next-method (o c)
                (if keyp
-                   `(apply ',function ,o ,c ,rest)
-                   `(,function ,o ,c))))
+                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
+                   `(,function ,@prefix ,o ,c ,@suffix))))
         `(progn
-           (defmethod ,function ((,operation symbol) ,component ,@more-args)
+           (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
              (if ,operation
                  ,(next-method
                    (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
@@ -6636,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
                        `(make-operation ,operation))
                    `(or (find-component () ,component) ,if-no-component))
                  ,if-no-operation))
-           (defmethod ,function ((,operation operation) ,component ,@more-args)
+           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
              (if (typep ,component 'component)
                  (error "No defined method for ~S on ~/asdf-action:format-action/"
                         ',function (cons ,operation ,component))
-                 (let ((,found (find-component () ,component)))
-                   (if ,found
-                       ,(next-method operation found)
-                       ,if-no-component)))))))))
+                 (if-let (,found (find-component () ,component))
+                    ,(next-method operation found)
+                    ,if-no-component))))))))
 
 
 ;;;; self-description
@@ -6922,15 +6966,14 @@ in some previous image, or T if it needs to be done.")
   (defclass basic-load-op (operation) ())
   (defclass basic-compile-op (operation)
     ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
-     (flags :initarg :flags :accessor compile-op-flags
-            :initform nil))))
+     (flags :initarg :flags :accessor compile-op-flags :initform nil))))
 
 ;;; Our default operations: loading into the current lisp image
 (with-upgradability ()
   (defclass prepare-op (upward-operation sideway-operation)
     ((sideway-operation :initform 'load-op)))
   (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
-    ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p,
+    ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
     ;; so we need to directly depend on prepare-op for its side-effects in the current image.
     ((selfward-operation :initform '(prepare-op compile-op))))
   (defclass compile-op (basic-compile-op downward-operation selfward-operation)
@@ -7161,7 +7204,7 @@ in some previous image, or T if it needs to be done.")
    #:visit-dependencies #:compute-action-stamp #:traverse-action
    #:circular-dependency #:circular-dependency-actions
    #:call-while-visiting-action #:while-visiting-action
-   #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+   #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
    #:planned-p #:index #:forced #:forced-not #:total-action-count
    #:planned-action-count #:planned-output-action-count #:visited-actions
    #:visiting-action-set #:visiting-action-list #:plan-actions-r
@@ -7347,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
            (in-files (input-files o c))
            ;; Three kinds of actions:
            (out-op (and out-files t)) ; those that create files on the filesystem
-                                        ;(image-op (and in-files (null out-files))) ; those that load stuff into the image
-                                        ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing
+           ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
+           ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
            ;; When was the thing last actually done? (Now, or ask.)
            (op-time (or just-done (component-operation-time o c)))
            ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
@@ -7467,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN"))
                                  :stamp stamp
                                  :done-p (and done-p (not add-to-plan-p))
                                  :planned-p add-to-plan-p
-                                 :index (if status (action-index status) (incf (plan-total-action-count plan)))))
+                                 :index (if status
+                                            (action-index status)
+                                            (incf (plan-total-action-count plan)))))
                           (when add-to-plan-p
                             (incf (plan-planned-action-count plan))
                             (unless aniip
@@ -7483,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
     ((actions-r :initform nil :accessor plan-actions-r)))
 
   (defgeneric plan-actions (plan))
+  (defmethod plan-actions ((plan list))
+    plan)
   (defmethod plan-actions ((plan sequential-plan))
     (reverse (plan-actions-r plan)))
 
@@ -7499,45 +7546,46 @@ the action of OPERATION on COMPONENT in the PLAN"))
 
 ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
 (with-upgradability ()
-  (defgeneric* (traverse) (operation component &key &allow-other-keys)
+  (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
     (:documentation
-     "Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-  (define-convenience-action-methods traverse (operation component &key))
+     "Generate and return a plan for performing OPERATION on COMPONENT."))
+  (define-convenience-action-methods make-plan (plan-class operation component &key))
 
   (defgeneric perform-plan (plan &key))
   (defgeneric plan-operates-on-p (plan component))
 
   (defvar *default-plan-class* 'sequential-plan)
 
-  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+  (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
     (let ((plan (apply 'make-instance
                        (or plan-class *default-plan-class*)
-                       :system (component-system c) (remove-plist-key :plan-class keys))))
+                       :system (component-system c) keys)))
       (traverse-action plan o c t)
-      (plan-actions plan)))
+      plan))
 
-  (defmethod perform-plan :around (plan &key)
-    (declare (ignorable plan))
+  (defmethod perform-plan :around ((plan t) &key)
     (let ((*package* *package*)
           (*readtable* *readtable*))
       (with-compilation-unit () ;; backward-compatibility.
         (call-next-method))))   ;; Going forward, see deferred-warning support in lisp-build.
 
+  (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
+    (apply 'perform-plan (plan-actions plan) keys))
+
   (defmethod perform-plan ((steps list) &key force &allow-other-keys)
     (loop* :for (o . c) :in steps
            :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
            :do (perform-with-restarts o c)))
 
+  (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
+    (plan-operates-on-p (plan-actions plan) component-path))
+
   (defmethod plan-operates-on-p ((plan list) (component-path list))
     (find component-path (mapcar 'cdr plan)
           :test 'equal :key 'component-find-path)))
 
 
-;;;; Incidental traversals 
+;;;; Incidental traversals
 (with-upgradability ()
   (defclass filtered-sequential-plan (sequential-plan)
     ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
@@ -7561,11 +7609,10 @@ processed in order by OPERATE."))
 
   (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
     (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
-      (loop* :for (o . c) :in actions :do
-             (traverse-action plan o c t))
-      (plan-actions plan)))
+      (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
+      plan))
 
-  (define-convenience-action-methods traverse-sub-actions (o c &key))
+  (define-convenience-action-methods traverse-sub-actions (operation component &key))
   (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
     (apply 'traverse-actions (direct-dependencies operation component)
            :system (component-system component) keys))
@@ -7573,14 +7620,14 @@ processed in order by OPERATE."))
   (defmethod plan-actions ((plan filtered-sequential-plan))
     (with-slots (keep-operation keep-component) plan
       (loop* :for (o . c) :in (call-next-method)
-             :when (and (typep o keep-operation)
-                        (typep c keep-component))
+             :when (and (typep o keep-operation) (typep c keep-component))
              :collect (cons o c))))
 
   (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
     (remove-duplicates
-     (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system
-                         (remove-plist-key :goal-operation keys)))
+     (mapcar 'cdr (plan-actions
+                   (apply 'traverse-sub-actions goal-operation system
+                          (remove-plist-key :goal-operation keys))))
      :from-end t)))
 
 ;;;; -------------------------------------------------------------------------
@@ -7671,8 +7718,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
       (error 'missing-component-of-version :requires component :version version)))
 
   (defmethod operate ((operation operation) (component component)
-                      &rest keys &key &allow-other-keys)
-    (let ((plan (apply 'traverse operation component keys)))
+                      &rest keys &key plan-class &allow-other-keys)
+    (let ((plan (apply 'make-plan plan-class operation component keys)))
       (apply 'perform-plan plan keys)
       (values operation plan)))
 
@@ -7797,7 +7844,7 @@ for how to load or compile stuff")
 
 
 ;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility 
+;;; Internal hacks for backward-compatibility
 
 (asdf/package:define-package :asdf/backward-internals
   (:recycle :asdf/backward-internals :asdf)
@@ -8181,14 +8228,16 @@ for how to load or compile stuff")
   ;; we'd have to have the monolithic-op not inherit from the main op,
   ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
 
-  (defclass lib-op (bundle-compile-op)
+  (defclass no-ld-flags-op (operation) ())
+
+  (defclass lib-op (bundle-compile-op no-ld-flags-op)
     ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
     (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
      #-(or ecl mkcl) "just compile the system"))
 
-  (defclass dll-op (bundle-op basic-compile-op)
+  (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op)
     ((bundle-type :initform :dll))
-    (:documentation "Link together all the dynamic library used by this system into a single one."))
+    (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
 
   (defclass binary-op (basic-compile-op selfward-operation)
     ((selfward-operation :initform '(fasl-op lib-op)))
@@ -8211,15 +8260,14 @@ for how to load or compile stuff")
   (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
     (:documentation "Create a single fasl for the system and its dependencies."))
 
-  (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op)
+  (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op  no-ld-flags-op)
     ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
     (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
      #-(or ecl mkcl) "Compile a system and its dependencies."))
 
-  (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
-    ((bundle-type :initform :dll)
-     (selfward-operation :initform 'dll-op)
-     (sideway-operation :initform 'dll-op)))
+  (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op)
+    ((bundle-type :initform :dll))
+    (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
 
   (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
             #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
@@ -8233,7 +8281,7 @@ for how to load or compile stuff")
       ((or null string) bundle-type)
       ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
       #+ecl
-      ((member :binary :dll :lib :static-library :program :object :program)
+      ((member :binary :dll :lib :shared-library :static-library :program :object :program)
        (compile-file-type :type bundle-type))
       ((eql :binary) "image")
       ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
@@ -8305,7 +8353,7 @@ for how to load or compile stuff")
           (remove-plist-keys '(:type :monolithic :name-suffix)
                              (operation-original-initargs instance))))
 
-  (defmethod bundle-op-build-args :around ((o lib-op))
+  (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
     (declare (ignorable o))
     (let ((args (call-next-method)))
       (remf args :ld-flags)
@@ -9032,11 +9080,11 @@ effectively disabling the output translation facility."
   (:recycle :asdf/backward-interface :asdf)
   (:use :uiop/common-lisp :uiop :asdf/upgrade
    :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
-   :asdf/lisp-action :asdf/operate :asdf/output-translations)
+   :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
   (:export
    #:*asdf-verbose*
    #:operation-error #:compile-error #:compile-failed #:compile-warned
-   #:error-component #:error-operation
+   #:error-component #:error-operation #:traverse
    #:component-load-dependencies
    #:enable-asdf-binary-locations-compatibility
    #:operation-forced
@@ -9089,7 +9137,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
 for a mostly compatible replacement that we're supporting,
 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
 if that's whay you mean." ;;)
-    (system-source-file x)))
+    (system-source-file x))
+
+  (defgeneric* (traverse) (operation component &key &allow-other-keys)
+    (:documentation
+     "Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+  (define-convenience-action-methods traverse (operation component &key))
+
+  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+    (plan-actions (apply 'make-plan plan-class o c keys))))
 
 
 ;;;; ASDF-Binary-Locations compatibility
@@ -9160,7 +9220,15 @@ Deprecated function, for backward-compatibility only.
 Please use UIOP:RUN-PROGRAM instead."
     (let ((command (apply 'format nil control-string args)))
       (asdf-message "; $ ~A~%" command)
-      (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
+      (handler-case
+          (progn
+            (run-program command :force-shell t :ignore-error-status nil :output *verbose-out*)
+            0)
+        (subprocess-error (c)
+          (let ((code (subprocess-error-code c)))
+            (typecase code
+              (integer code)
+              (t 255))))))))
 
 (with-upgradability ()
   (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
@@ -9470,7 +9538,7 @@ system names to pathnames of .asd files")
   (defvar *source-registry-parameter* nil)
 
   (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
-    ;; Record the parameter used to configure the registry 
+    ;; Record the parameter used to configure the registry
     (setf *source-registry-parameter* parameter)
     ;; Clear the previous registry database:
     (setf *source-registry* (make-hash-table :test 'equal))
@@ -9516,7 +9584,7 @@ system names to pathnames of .asd files")
   ;; TODO: automatically generate interface with reexport?
   (:export
    #:defsystem #:find-system #:locate-system #:coerce-name
-   #:oos #:operate #:traverse #:perform-plan #:sequential-plan
+   #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
    #:system-definition-pathname #:with-system-definitions
    #:search-for-system-definition #:find-component #:component-find-path
    #:compile-system #:load-system #:load-systems
@@ -9572,6 +9640,7 @@ system names to pathnames of .asd files")
    #:module-components ; backward-compatibility
    #:operation-on-warnings #:operation-on-failure ; backward-compatibility
    #:component-property ; backward-compatibility
+   #:traverse ; backward-compatibility
 
    #:system-description
    #:system-long-description
@@ -9706,6 +9775,12 @@ system names to pathnames of .asd files")
                           (and (first l) (register-pre-built-system (coerce-name name)))
                           (values-list l))))))))
 
+#+cmu
+(with-upgradability ()
+  (defun herald-asdf (stream)
+    (format stream "    ASDF ~A" (asdf-version)))
+  (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
+
 
 ;;;; Done!
 (with-upgradability ()
-- 
GitLab