Changeset 14569

Timestamp:

07/21/13 19:12:33 (10 years ago)

Author:

Mark Evenson

Message:

Update to asdf-3.0.2.

Location:

trunk/abcl

Files:

• examples/java-to-lisp-1/MainAlternative.java (modified) (1 diff)
• src/org/armedbear/lisp/asdf.lisp (modified) (52 diffs)

trunk/abcl/examples/java-to-lisp-1/MainAlternative.java

@@ -40 +40 @@
     // also has a class named Package.
     org.armedbear.lisp.Package defaultPackage = 
-        Packages.findPackage("CL-USER");
+        org.armedbear.lisp.Package.findPackage("CL-USER");
     Symbol sym = 
         defaultPackage.findAccessibleSymbol("LISPFUNCTION");

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

@@ -1 +1 @@
 ;;; -*- 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:
@@ -71 +71 @@
            (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*
@@ -1515 +1515 @@
   (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))
@@ -1912 +1915 @@
    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
@@ -1987 +1991 @@
     ;; 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*)
@@ -1992 +1998 @@
                                  :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))))
@@ -2260 +2266 @@
                   :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))))))
 
@@ -3144 +3150 @@
 
   (defun encoding-external-format (encoding)
-    (funcall *encoding-external-format-hook* encoding)))
+    (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
 
 
@@ -3614 +3620 @@
     #+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))
@@ -3628 +3634 @@
     (with-safe-io-syntax ()
       (ignore-errors
-       (fresh-line *stderr*)
-       (apply #'format *stderr* format arguments)
-       (format! *stderr* "~&")))
+       (format! *stderr* "~&~?~&" format arguments)))
     (quit code))
 
@@ -3652 +3656 @@
     #+(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)
@@ -3743 +3748 @@
     #+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"))
 
@@ -4140 +4145 @@
 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))
@@ -4185 +4202 @@
                           #+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
@@ -4277 +4295 @@
                #+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)
@@ -4627 +4649 @@
     #+allegro
     (list :functions-defined excl::.functions-defined.
-    :functions-called excl::.functions-called.)
+          :functions-called excl::.functions-called.)
     #+clozure
     (mapcar 'reify-deferred-warning
@@ -4669 +4691 @@
     #+allegro
     (destructuring-bind (&key functions-defined functions-called)
-      reified-deferred-warnings
+        reified-deferred-warnings
       (setf excl::.functions-defined.
             (append functions-defined excl::.functions-defined.)
@@ -4884 +4906 @@
   (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.
@@ -4925 +4947 @@
                  (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)))
@@ -4930 +4960 @@
           (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
@@ -4955 +4988 @@
            (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)))
@@ -4960 +4994 @@
           (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))))
@@ -5422 +5458 @@
          ;; "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)
@@ -5440 +5476 @@
              #: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
@@ -6619 +6655 @@
 (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
@@ -6637 +6682 @@
                    `(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))))))))
 
 
@@ -6923 +6967 @@
   (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
@@ -6931 +6974 @@
     ((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))))
@@ -7162 +7205 @@
    #: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
@@ -7348 +7391 @@
            ;; 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)))
@@ -7468 +7511 @@
                                  :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))
@@ -7484 +7529 @@
 
   (defgeneric plan-actions (plan))
+  (defmethod plan-actions ((plan list))
+    plan)
   (defmethod plan-actions ((plan sequential-plan))
     (reverse (plan-actions-r plan)))
@@ -7500 +7547 @@
 ;;;; 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))
@@ -7514 +7557 @@
   (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)))
-
-  (defmethod perform-plan :around (plan &key)
-    (declare (ignorable plan))
+      plan))
+
+  (defmethod perform-plan :around ((plan t) &key)
     (let ((*package* *package*)
           (*readtable* *readtable*))
@@ -7528 +7570 @@
         (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
@@ -7533 +7578 @@
            :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)
@@ -7538 +7586 @@
 
 
-;;;; Incidental traversals 
+;;;; Incidental traversals
 (with-upgradability ()
   (defclass filtered-sequential-plan (sequential-plan)
@@ -7562 +7610 @@
   (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)))
-
-  (define-convenience-action-methods traverse-sub-actions (o c &key))
+      (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
+      plan))
+
+  (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)
@@ -7574 +7621 @@
     (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)))
 
@@ -7672 +7719 @@
 
   (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)))
@@ -7798 +7845 @@
 
 ;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility 
+;;; Internal hacks for backward-compatibility
 
 (asdf/package:define-package :asdf/backward-internals
@@ -8182 +8229 @@
   ;; 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)
@@ -8212 +8261 @@
     (: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)
@@ -8234 +8282 @@
       ((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")
@@ -8306 +8354 @@
                              (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)))
@@ -9033 +9081 @@
   (: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
@@ -9090 +9138 @@
 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))))
 
 
@@ -9161 +9221 @@
     (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 ()
@@ -9471 +9539 @@
 
   (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:
@@ -9517 +9585 @@
   (: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
@@ -9573 +9641 @@
    #:operation-on-warnings #:operation-on-failure ; backward-compatibility
    #:component-property ; backward-compatibility
+   #:traverse ; backward-compatibility
 
    #:system-description
@@ -9707 +9776 @@
                           (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!