Changeset 14920


Ignore:
Timestamp:
12/03/16 06:56:12 (5 years ago)
Author:
Mark Evenson
Message:

Update to asdf-3.1.7.40

Fixes version identifier for development releases of ABCL, so that
SYS:RUN-PROGRAM is invoked where previously SYS::RUN-SHELL-COMMAND was
being invoked from UIOP.

<> rdfs:seeAlso <https://gitlab.common-lisp.net/asdf/asdf/commit/c5a0c97d7020d9a1ed17710ace586fef4ad1ae12>.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r14913 r14920  
    6666@titlepage
    6767@title ASDF: Another System Definition Facility
    68 @subtitle Manual for Version 3.1.7.35
     68@subtitle Manual for Version 3.1.7.40
    6969@c The following two commands start the copyright page.
    7070@page
     
    8383@top ASDF: Another System Definition Facility
    8484@ifnottex
    85 Manual for Version 3.1.7.10
     85Manual for Version 3.1.7.37
    8686@end ifnottex
    8787
     
    21252125@code{oos} is a synonym for @code{operate} (it stands for operate-on-system).
    21262126
    2127 @var{operation} is a symbol that is passed,
    2128 along with the supplied @var{initargs},
    2129 to @code{make-operation} (which will call @code{make-instance})
     2127@var{operation} is an operation designator:
     2128it can be an operation object itself, or, typically,
     2129a symbol that is passed to @code{make-operation} (which will call @code{make-instance}),
    21302130to create the operation object.
    2131 @var{component} is a component designator,
    2132 usually a string or symbol that designates a system,
    2133 sometimes a list of strings or symbols that designate a subcomponent of a system.
    2134 
    2135 The @var{initargs} are passed to the @code{make-instance} call
    2136 when creating the operation object.
    2137 @c We probably want to deprecate that, because
    2138 @c (1) there is a mix of flags for operate, for the operation-class, for the plan-class, etc.
    2139 @c (2) flags to operations have never been well-supported, anyway.
    2140 @c The future solution probably involves having an explicit :operation-options keyword or some such
    2141 @c (if operation options are not wholly eliminated), a separate :plan-options, etc.
     2131@var{component} is a component designator:
     2132it can be a component object itself, or, typically,
     2133a string or symbol (to be @code{string-downcase}d) that names a system,
     2134more rarely a list of strings or symbols that designate a subcomponent of a system.
     2135
     2136The ability to pass @var{initargs} to @code{make-operation} is now deprecated, and will be removed.
     2137For more details, @pxref{make-operation}.
    21422138Note that dependencies may cause the operation
    21432139to invoke other operations on the system or its components:
    2144 the new operations will be created
    2145 with the same @var{initargs} as the original one.
     2140the new operations may or may not be created
     2141with the same @var{initargs} as the original one (for the moment).
    21462142
    21472143If @var{force} is @code{:all}, then all systems
     
    21772173@end deffn
    21782174
     2175@defun @code{make-operation} @var{operation-class} @Arest{} @var{initargs}
     2176@anchor{make-operation}
     2177
     2178The @var{initargs} are passed to @code{make-instance} call
     2179when creating the operation object.
     2180
     2181@strong{Note:}@var{initargs} for @code{operation}s are now deprecated,
     2182and will be removed from ASDF in the near future.
     2183
     2184@strong{Note:} @code{operation} instances must @strong{never} be created
     2185using @code{make-instance} directly: only through
     2186@code{make-operation}. Attempts to directly make @code{operation}
     2187instances will cause a run-time error.
     2188@end defun
    21792189
    21802190
     
    56125622having been replaced by code now built into ASDF 3.
    56135623Moreover, the name of the bundle operations has changed since ASDF 3.1.3.
    5614 
    5615 And yet, the feature is not enabled to be used by @code{load-system} by default on ECL as originally intended,
    5616 because of a bug in ECL itself found during testing.
    5617 
    5618 
    5619 Some of the bundle operations were renamed after ASDF 3.1.3, and the old
    5620 names have been removed.  Old bundle operations, and their modern
    5621 equivalents are:
     5624Starting with ASDF 3.2.0, @code{load-system}
     5625will once again use @code{load-bundle-op} instead of @code{load-op} on ECL,
     5626as originally intended by @code{asdf-ecl} authors, but disabled for a long time
     5627due to bugs in both ECL and ASDF.
     5628
     5629Note that some of the bundle operations were renamed after ASDF 3.1.3,
     5630and the old names have been removed.
     5631Old bundle operations, and their modern equivalents are:
    56225632
    56235633@itemize
     
    62296239@item Francois-Rene Rideau and Robert Goldman:
    62306240  ``Evolving ASDF: More Cooperation, Less Coordination'', 2010.
    6231   This article describes the main issues solved by ASDF 2.
     6241  This article describes the main issues solved by ASDF 2,
     6242  and exposes its design principles.
    62326243  @url{https://common-lisp.net/project/asdf/doc/ilc2010draft.pdf}
    62336244  @url{https://gitlab.common-lisp.org/asdf/ilc2010}
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14913 r14920  
    11;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.7.35: Another System Definition Facility.
     2;;; This is ASDF 3.1.7.40: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    14671467A symbol otherwise designates a class by name."
    14681468    (let* ((normalized
    1469              (typecase class
     1469            (typecase class
    14701470              (keyword (or (find-symbol* class package nil)
    14711471                           (find-symbol* class *package* nil)))
     
    14731473              (t class)))
    14741474           (found
    1475              (etypecase normalized
    1476                ((or standard-class built-in-class) normalized)
    1477                ((or null keyword) nil)
    1478                (symbol (find-class normalized nil nil)))))
     1475            (etypecase normalized
     1476              ((or standard-class built-in-class) normalized)
     1477              ((or null keyword) nil)
     1478              (symbol (find-class normalized nil nil))))
     1479           (super-class
     1480            (etypecase super
     1481              ((or standard-class built-in-class) super)
     1482              ((or null keyword) nil)
     1483              (symbol (find-class super nil nil)))))
     1484      #+allegro (when found (mop:finalize-inheritance found))
    14791485      (or (and found
    1480                (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
     1486               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
    14811487               found)
    14821488          (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
     
    28852891    "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
    28862892probes the filesystem for a file or directory with given pathname.
    2887 If it exists, return its truename is ENSURE-PATHNAME is true,
     2893If it exists, return its truename if TRUENAME is true,
    28882894or the original (parsed) pathname if it is false (the default)."
    28892895    (values
     
    54605466        (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
    54615467;;;; -------------------------------------------------------------------------
    5462 ;;;; run-program initially from xcvb-driver.
    5463 
    5464 (uiop/package:define-package :uiop/run-program
    5465   (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
     5468;;;; launch-program - semi-portably spawn asynchronous subprocesses
     5469
     5470(uiop/package:define-package :uiop/launch-program
    54665471  (:use :uiop/common-lisp :uiop/package :uiop/utility
    54675472   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
     
    54705475   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
    54715476   #:escape-windows-token #:escape-windows-command
     5477   #:escape-shell-token #:escape-shell-command
    54725478   #:escape-token #:escape-command
    54735479
    5474    ;;; run-program
    5475    #:slurp-input-stream #:vomit-output-stream
    5476    #:close-streams #:launch-program #:process-alive-p #:run-program
    5477    #:terminate-process #:wait-process
    5478    #:process-info-error-output #:process-info-input #:process-info-output
    5479    #:process-info-pid
    5480    #:subprocess-error
    5481    #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
    5482    ))
    5483 (in-package :uiop/run-program)
     5480   ;;; launch-program
     5481   #:launch-program
     5482   #:close-streams #:process-alive-p #:terminate-process #:wait-process
     5483   #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
     5484(in-package :uiop/launch-program)
    54845485
    54855486;;;; ----- Escaping strings for the shell -----
    5486 
    54875487(with-upgradability ()
    54885488  (defun requires-escaping-p (token &key good-chars bad-chars)
     
    56035603
    56045604
    5605 ;;;; Slurping a stream, typically the output of another program
    5606 (with-upgradability ()
    5607   (defun call-stream-processor (fun processor stream)
    5608     "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
    5609 a PROCESSOR specification which is either an atom or a list specifying
    5610 a processor an keyword arguments, call the specified processor with
    5611 the given STREAM as input"
    5612     (if (consp processor)
    5613         (apply fun (first processor) stream (rest processor))
    5614         (funcall fun processor stream)))
    5615 
    5616   (defgeneric slurp-input-stream (processor input-stream &key)
    5617     (:documentation
    5618      "SLURP-INPUT-STREAM is a generic function with two positional arguments
    5619 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
    5620 the contents of the INPUT-STREAM and processes them according to a method
    5621 specified by PROCESSOR.
    5622 
    5623 Built-in methods include the following:
    5624 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
    5625 * if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
    5626   INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    5627     \(APPLY x <stream> y\)
    5628 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
    5629   per copy-stream-to-stream, with appropriate keyword arguments.
    5630 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
    5631   are returned as a string, as per SLURP-STREAM-STRING.
    5632 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
    5633 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
    5634 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
    5635 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
    5636 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
    5637 
    5638 Programmers are encouraged to define their own methods for this generic function."))
    5639 
    5640   #-genera
    5641   (defmethod slurp-input-stream ((function function) input-stream &key)
    5642     (funcall function input-stream))
    5643 
    5644   (defmethod slurp-input-stream ((list cons) input-stream &key)
    5645     (apply (first list) input-stream (rest list)))
    5646 
    5647   #-genera
    5648   (defmethod slurp-input-stream ((output-stream stream) input-stream
    5649                                  &key linewise prefix (element-type 'character) buffer-size)
    5650     (copy-stream-to-stream
    5651      input-stream output-stream
    5652      :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    5653 
    5654   (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    5655     (slurp-stream-string stream :stripped stripped))
    5656 
    5657   (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    5658     (slurp-stream-string stream :stripped stripped))
    5659 
    5660   (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
    5661     (slurp-stream-lines stream :count count))
    5662 
    5663   (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
    5664     (slurp-stream-line stream :at at))
    5665 
    5666   (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
    5667     (slurp-stream-forms stream :count count))
    5668 
    5669   (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
    5670     (slurp-stream-form stream :at at))
    5671 
    5672   (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    5673     (apply 'slurp-input-stream *standard-output* stream keys))
    5674 
    5675   (defmethod slurp-input-stream ((x null) (stream t) &key)
    5676     nil)
    5677 
    5678   (defmethod slurp-input-stream ((pathname pathname) input
    5679                                  &key
    5680                                    (element-type *default-stream-element-type*)
    5681                                    (external-format *utf-8-external-format*)
    5682                                    (if-exists :rename-and-delete)
    5683                                    (if-does-not-exist :create)
    5684                                    buffer-size
    5685                                    linewise)
    5686     (with-output-file (output pathname
    5687                               :element-type element-type
    5688                               :external-format external-format
    5689                               :if-exists if-exists
    5690                               :if-does-not-exist if-does-not-exist)
    5691       (copy-stream-to-stream
    5692        input output
    5693        :element-type element-type :buffer-size buffer-size :linewise linewise)))
    5694 
    5695   (defmethod slurp-input-stream (x stream
    5696                                  &key linewise prefix (element-type 'character) buffer-size)
    5697     (declare (ignorable stream linewise prefix element-type buffer-size))
    5698     (cond
    5699       #+genera
    5700       ((functionp x) (funcall x stream))
    5701       #+genera
    5702       ((output-stream-p x)
    5703        (copy-stream-to-stream
    5704         stream x
    5705         :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    5706       (t
    5707        (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
    5708 
    5709 
    5710 (with-upgradability ()
    5711   (defgeneric vomit-output-stream (processor output-stream &key)
    5712     (:documentation
    5713      "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
    5714 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
    5715 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
    5716 
    5717 Built-in methods include the following:
    5718 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
    5719 * if PROCESSOR is a list, its first element should be a function.
    5720   It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
    5721   That is (x . y) will be treated as \(APPLY x <stream> y\)
    5722 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
    5723   per copy-stream-to-stream, with appropriate keyword arguments.
    5724 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
    5725 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
    5726 
    5727 Programmers are encouraged to define their own methods for this generic function."))
    5728 
    5729   #-genera
    5730   (defmethod vomit-output-stream ((function function) output-stream &key)
    5731     (funcall function output-stream))
    5732 
    5733   (defmethod vomit-output-stream ((list cons) output-stream &key)
    5734     (apply (first list) output-stream (rest list)))
    5735 
    5736   #-genera
    5737   (defmethod vomit-output-stream ((input-stream stream) output-stream
    5738                                  &key linewise prefix (element-type 'character) buffer-size)
    5739     (copy-stream-to-stream
    5740      input-stream output-stream
    5741      :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    5742 
    5743   (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
    5744     (princ x stream)
    5745     (when fresh-line (fresh-line stream))
    5746     (when terpri (terpri stream))
    5747     (values))
    5748 
    5749   (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    5750     (apply 'vomit-output-stream *standard-input* stream keys))
    5751 
    5752   (defmethod vomit-output-stream ((x null) (stream t) &key)
    5753     (values))
    5754 
    5755   (defmethod vomit-output-stream ((pathname pathname) input
    5756                                  &key
    5757                                    (element-type *default-stream-element-type*)
    5758                                    (external-format *utf-8-external-format*)
    5759                                    (if-exists :rename-and-delete)
    5760                                    (if-does-not-exist :create)
    5761                                    buffer-size
    5762                                    linewise)
    5763     (with-output-file (output pathname
    5764                               :element-type element-type
    5765                               :external-format external-format
    5766                               :if-exists if-exists
    5767                               :if-does-not-exist if-does-not-exist)
    5768       (copy-stream-to-stream
    5769        input output
    5770        :element-type element-type :buffer-size buffer-size :linewise linewise)))
    5771 
    5772   (defmethod vomit-output-stream (x stream
    5773                                  &key linewise prefix (element-type 'character) buffer-size)
    5774     (declare (ignorable stream linewise prefix element-type buffer-size))
    5775     (cond
    5776       #+genera
    5777       ((functionp x) (funcall x stream))
    5778       #+genera
    5779       ((input-stream-p x)
    5780        (copy-stream-to-stream
    5781         x stream
    5782         :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    5783       (t
    5784        (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
    5785 
    5786 
    5787 ;;;; ----- Running an external program -----
    5788 ;;; Simple variant of run-program with no input, and capturing output
    5789 ;;; On some implementations, may output to a temporary file...
    5790 (with-upgradability ()
    5791   (define-condition subprocess-error (error)
    5792     ((code :initform nil :initarg :code :reader subprocess-error-code)
    5793      (command :initform nil :initarg :command :reader subprocess-error-command)
    5794      (process :initform nil :initarg :process :reader subprocess-error-process))
    5795     (:report (lambda (condition stream)
    5796                (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
    5797                        (subprocess-error-process condition)
    5798                        (subprocess-error-command condition)
    5799                        (subprocess-error-code condition)))))
    5800 
     5605(with-upgradability ()
    58015606  ;;; Internal helpers for run-program
    58025607  (defun %normalize-command (command)
     
    58085613      #+os-windows
    58095614      (string
    5810        ;; NB: We do NOT add cmd /c here. You might want to.
    5811        #+(or allegro clisp) command
     5615       ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
     5616       ;; when the command contains spaces or special characters:
     5617       ;; IIUC, the system will use space as a separator, but the argv-decoding libraries won't,
     5618       ;; and you're supposed to use an extra argument to CreateProcess to bridge the gap,
     5619       ;; but neither allegro nor clisp provide access to that argument.
     5620       #+(or allegro clisp) (strcat "cmd /c " command)
    58125621       ;; On ClozureCL for Windows, we assume you are using
    58135622       ;; r15398 or later in 1.9 or later,
    58145623       ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    5815        #+clozure (cons "cmd" (strcat "/c " command))
    5816        #+sbcl (cons "cmd" (strcat "/c " command))
     5624       ;; On SBCL, we assume the patch from https://bugs.launchpad.net/sbcl/+bug/1503496
     5625       #+(or clozure sbcl) (cons "cmd" (strcat "/c " command))
    58175626       ;; NB: On other Windows implementations, this is utterly bogus
    58185627       ;; except in the most trivial cases where no quoting is needed.
    58195628       ;; Use at your own risk.
    5820        #-(or allegro clisp clozure sbcl) (list "cmd" "/c" command))
     5629       #-(or allegro clisp clozure sbcl)
     5630       (parameter-error "~S doesn't support string commands on Windows on this lisp: ~S" '%normalize-command command))
    58215631      #+os-windows
    58225632      (list
    58235633       #+allegro (escape-windows-command command)
    58245634       #-allegro command)))
    5825 
    5826   (defun %active-io-specifier-p (specifier)
    5827     "Determines whether a run-program I/O specifier requires Lisp-side processing
    5828 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
    5829 or whether it's already taken care of by the implementation's underlying run-program."
    5830     (not (typep specifier '(or null string pathname (member :interactive :output)
    5831                             #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
    5832                             #+lispworks file-stream))))
    58335635
    58345636  (defun %normalize-io-specifier (specifier &optional role)
     
    59105712                                :if-does-not-exist if-does-not-exist)
    59115713           (declare (ignorable dummy)))))))
     5714
     5715  (defun process-info-error-output (process-info)
     5716    (slot-value process-info 'error-output-stream))
     5717  (defun process-info-input (process-info)
     5718    (or (slot-value process-info 'bidir-stream)
     5719        (slot-value process-info 'input-stream)))
     5720  (defun process-info-output (process-info)
     5721    (or (slot-value process-info 'bidir-stream)
     5722        (slot-value process-info 'output-stream)))
     5723
     5724  (defun process-info-pid (process-info)
     5725    (let ((process (slot-value process-info 'process)))
     5726      (declare (ignorable process))
     5727      #+abcl (symbol-call :sys :process-pid process)
     5728      #+allegro process
     5729      #+clozure (ccl:external-process-id process)
     5730      #+ecl (ext:external-process-pid process)
     5731      #+(or cmucl scl) (ext:process-pid process)
     5732      #+lispworks7+ (sys:pipe-pid process)
     5733      #+(and lispworks (not lispworks7+)) process
     5734      #+mkcl (mkcl:process-id process)
     5735      #+sbcl (sb-ext:process-pid process)
     5736      #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
     5737      (not-implemented-error 'process-info-pid)))
     5738
     5739  (defun %process-status (process-info)
     5740    (if-let (exit-code (slot-value process-info 'exit-code))
     5741      (return-from %process-status
     5742        (if-let (signal-code (slot-value process-info 'signal-code))
     5743          (values :signaled signal-code)
     5744          (values :exited exit-code))))
     5745    #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5746    (not-implemented-error '%process-status)
     5747    (if-let (process (slot-value process-info 'process))
     5748      (multiple-value-bind (status code)
     5749          (progn
     5750            #+allegro (multiple-value-bind (exit-code pid signal)
     5751                          (sys:reap-os-subprocess :pid process :wait nil)
     5752                        (assert pid)
     5753                        (cond ((null exit-code) :running)
     5754                              ((null signal) (values :exited exit-code))
     5755                              (t (values :signaled signal))))
     5756            #+clozure (ccl:external-process-status process)
     5757            #+(or cmucl scl) (let ((status (ext:process-status process)))
     5758                               (values status (if (member status '(:exited :signaled))
     5759                                                  (ext:process-exit-code process))))
     5760            #+ecl (ext:external-process-status process)
     5761            #+lispworks
     5762            ;; a signal is only returned on LispWorks 7+
     5763            (multiple-value-bind (exit-code signal)
     5764                (funcall #+lispworks7+ #'sys:pipe-exit-status
     5765                         #-lispworks7+ #'sys:pid-exit-status
     5766                         process :wait nil)
     5767              (cond ((null exit-code) :running)
     5768                    ((null signal) (values :exited exit-code))
     5769                    (t (values :signaled signal))))
     5770            #+mkcl (let ((status (mk-ext:process-status process))
     5771                         (code (mk-ext:process-exit-code process)))
     5772                     (if (stringp code)
     5773                         (values :signaled (%mkcl-signal-to-number code))
     5774                         (values status code)))
     5775            #+sbcl (let ((status (sb-ext:process-status process)))
     5776                     (values status (if (member status '(:exited :signaled))
     5777                                        (sb-ext:process-exit-code process)))))
     5778        (case status
     5779          (:exited (setf (slot-value process-info 'exit-code) code))
     5780          (:signaled (let ((%code (%signal-to-exit-code code)))
     5781                       (setf (slot-value process-info 'exit-code) %code
     5782                             (slot-value process-info 'signal-code) code))))
     5783        (values status code))))
     5784
     5785  (defun process-alive-p (process-info)
     5786    "Check if a process has yet to exit."
     5787    (unless (slot-value process-info 'exit-code)
     5788      #+abcl (sys:process-alive-p (slot-value process-info 'process))
     5789      #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
     5790      #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
     5791      #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
     5792                                         '(:running :sleeping))))
     5793
     5794  (defun wait-process (process-info)
     5795    "Wait for the process to terminate, if it is still running.
     5796Otherwise, return immediately. An exit code (a number) will be
     5797returned, with 0 indicating success, and anything else indicating
     5798failure. If the process exits after receiving a signal, the exit code
     5799will be the sum of 128 and the (positive) numeric signal code. A second
     5800value may be returned in this case: the numeric signal code itself.
     5801Any asynchronously spawned process requires this function to be run
     5802before it is garbage-collected in order to free up resources that
     5803might otherwise be irrevocably lost."
     5804    (if-let (exit-code (slot-value process-info 'exit-code))
     5805      (if-let (signal-code (slot-value process-info 'signal-code))
     5806        (values exit-code signal-code)
     5807        exit-code)
     5808      (let ((process (slot-value process-info 'process)))
     5809        #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5810        (not-implemented-error 'wait-process)
     5811        (when process
     5812          ;; 1- wait
     5813          #+clozure (ccl::external-process-wait process)
     5814          #+(or cmucl scl) (ext:process-wait process)
     5815          #+sbcl (sb-ext:process-wait process)
     5816          ;; 2- extract result
     5817          (multiple-value-bind (exit-code signal-code)
     5818              (progn
     5819                #+abcl (sys:process-wait process)
     5820                #+allegro (multiple-value-bind (exit-code pid signal)
     5821                              (sys:reap-os-subprocess :pid process :wait t)
     5822                            (assert pid)
     5823                            (values exit-code signal))
     5824                #+clozure (multiple-value-bind (status code)
     5825                              (ccl:external-process-status process)
     5826                            (if (eq status :signaled)
     5827                                (values nil code)
     5828                                code))
     5829                #+(or cmucl scl) (let ((status (ext:process-status process))
     5830                                       (code (ext:process-exit-code process)))
     5831                                   (if (eq status :signaled)
     5832                                       (values nil code)
     5833                                       code))
     5834                #+ecl (multiple-value-bind (status code)
     5835                          (ext:external-process-wait process t)
     5836                        (if (eq status :signaled)
     5837                            (values nil code)
     5838                            code))
     5839                #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
     5840                                     #-lispworks7+ #'sys:pid-exit-status
     5841                                     process :wait t)
     5842                #+mkcl (let ((code (mkcl:join-process process)))
     5843                         (if (stringp code)
     5844                             (values nil (%mkcl-signal-to-number code))
     5845                             code))
     5846                #+sbcl (let ((status (sb-ext:process-status process))
     5847                             (code (sb-ext:process-exit-code process)))
     5848                         (if (eq status :signaled)
     5849                             (values nil code)
     5850                             code)))
     5851            (if signal-code
     5852                (let ((%exit-code (%signal-to-exit-code signal-code)))
     5853                  (setf (slot-value process-info 'exit-code) %exit-code
     5854                        (slot-value process-info 'signal-code) signal-code)
     5855                  (values %exit-code signal-code))
     5856                (progn (setf (slot-value process-info 'exit-code) exit-code)
     5857                       exit-code)))))))
     5858
     5859  ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
     5860  ;; do what you expect it to. Sending SIGSTOP to a process spawned
     5861  ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
     5862  ;; to run the command (via `sh -c command`) but not the actual
     5863  ;; command.
     5864  #+os-unix
     5865  (defun %posix-send-signal (process-info signal)
     5866    #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
     5867    #+clozure (ccl:signal-external-process (slot-value process-info 'process)
     5868                                           signal :error-if-exited nil)
     5869    #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
     5870    #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
     5871    #-(or allegro clozure cmucl sbcl scl)
     5872    (if-let (pid (process-info-pid process-info))
     5873      (symbol-call :uiop :run-program
     5874                   (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
     5875
     5876  ;;; this function never gets called on Windows, but the compiler cannot tell
     5877  ;;; that. [2016/09/25:rpg]
     5878  #+os-windows
     5879  (defun %posix-send-signal (process-info signal)
     5880    (declare (ignore process-info signal))
     5881    (values))
     5882
     5883  (defun terminate-process (process-info &key urgent)
     5884    "Cause the process to exit. To that end, the process may or may
     5885not be sent a signal, which it will find harder (or even impossible)
     5886to ignore if URGENT is T. On some platforms, it may also be subject to
     5887race conditions."
     5888    (declare (ignorable urgent))
     5889    #+abcl (sys:process-kill (slot-value process-info 'process))
     5890    ;; On ECL, this will only work on versions later than 2016-09-06,
     5891    ;; but we still want to compile on earlier versions, so we use symbol-call
     5892    #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
     5893    #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
     5894    #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
     5895                                     :force urgent)
     5896    #-(or abcl ecl lispworks7+ mkcl)
     5897    (os-cond
     5898     ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
     5899     ((os-windows-p) (if-let (pid (process-info-pid process-info))
     5900                       (symbol-call :uiop :run-program
     5901                                    (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
     5902                                    :ignore-error-status t)))
     5903     (t (not-implemented-error 'terminate-process))))
     5904
     5905  (defun close-streams (process-info)
     5906    "Close any stream that the process might own. Needs to be run
     5907whenever streams were requested by passing :stream to :input, :output,
     5908or :error-output."
     5909    (dolist (stream
     5910              (cons (slot-value process-info 'error-output-stream)
     5911                    (if-let (bidir-stream (slot-value process-info 'bidir-stream))
     5912                      (list bidir-stream)
     5913                      (list (slot-value process-info 'input-stream)
     5914                            (slot-value process-info 'output-stream)))))
     5915      (when stream (close stream))))
    59125916
    59135917  (defun launch-program (command &rest keys
     
    60976101              ;; lispworks6 returns (pid), lispworks7 returns (io err pid) of which we keep io
    60986102              (prop 'process (first process*)))))
    6099       process-info))
    6100 
    6101   (defun %run-program (command &rest keys &key &allow-other-keys)
    6102     "DEPRECATED. Use LAUNCH-PROGRAM instead."
    6103     (apply 'launch-program command keys))
    6104 
    6105   (defun process-info-error-output (process-info)
    6106     (slot-value process-info 'error-output-stream))
    6107   (defun process-info-input (process-info)
    6108     (or (slot-value process-info 'bidir-stream)
    6109         (slot-value process-info 'input-stream)))
    6110   (defun process-info-output (process-info)
    6111     (or (slot-value process-info 'bidir-stream)
    6112         (slot-value process-info 'output-stream)))
    6113 
    6114   (defun process-info-pid (process-info)
    6115     (let ((process (slot-value process-info 'process)))
    6116       (declare (ignorable process))
    6117       #+abcl (symbol-call :sys :process-pid process)
    6118       #+allegro process
    6119       #+clozure (ccl:external-process-id process)
    6120       #+ecl (ext:external-process-pid process)
    6121       #+(or cmucl scl) (ext:process-pid process)
    6122       #+lispworks7+ (sys:pipe-pid process)
    6123       #+(and lispworks (not lispworks7+)) process
    6124       #+mkcl (mkcl:process-id process)
    6125       #+sbcl (sb-ext:process-pid process)
    6126       #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
    6127       (not-implemented-error 'process-info-pid)))
    6128 
    6129   (defun %process-status (process-info)
    6130     (if-let (exit-code (slot-value process-info 'exit-code))
    6131       (return-from %process-status
    6132         (if-let (signal-code (slot-value process-info 'signal-code))
    6133           (values :signaled signal-code)
    6134           (values :exited exit-code))))
    6135     #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    6136     (not-implemented-error '%process-status)
    6137     (if-let (process (slot-value process-info 'process))
    6138       (multiple-value-bind (status code)
    6139           (progn
    6140             #+allegro (multiple-value-bind (exit-code pid signal)
    6141                           (sys:reap-os-subprocess :pid process :wait nil)
    6142                         (assert pid)
    6143                         (cond ((null exit-code) :running)
    6144                               ((null signal) (values :exited exit-code))
    6145                               (t (values :signaled signal))))
    6146             #+clozure (ccl:external-process-status process)
    6147             #+(or cmucl scl) (let ((status (ext:process-status process)))
    6148                                (values status (if (member status '(:exited :signaled))
    6149                                                   (ext:process-exit-code process))))
    6150             #+ecl (ext:external-process-status process)
    6151             #+lispworks
    6152             ;; a signal is only returned on LispWorks 7+
    6153             (multiple-value-bind (exit-code signal)
    6154                 (funcall #+lispworks7+ #'sys:pipe-exit-status
    6155                          #-lispworks7+ #'sys:pid-exit-status
    6156                          process :wait nil)
    6157               (cond ((null exit-code) :running)
    6158                     ((null signal) (values :exited exit-code))
    6159                     (t (values :signaled signal))))
    6160             #+mkcl (let ((status (mk-ext:process-status process))
    6161                          (code (mk-ext:process-exit-code process)))
    6162                      (if (stringp code)
    6163                          (values :signaled (%mkcl-signal-to-number code))
    6164                          (values status code)))
    6165             #+sbcl (let ((status (sb-ext:process-status process)))
    6166                      (values status (if (member status '(:exited :signaled))
    6167                                         (sb-ext:process-exit-code process)))))
    6168         (case status
    6169           (:exited (setf (slot-value process-info 'exit-code) code))
    6170           (:signaled (let ((%code (%signal-to-exit-code code)))
    6171                        (setf (slot-value process-info 'exit-code) %code
    6172                              (slot-value process-info 'signal-code) code))))
    6173         (values status code))))
    6174 
    6175   (defun process-alive-p (process-info)
    6176     "Check if a process has yet to exit."
    6177     (unless (slot-value process-info 'exit-code)
    6178       #+abcl (sys:process-alive-p (slot-value process-info 'process))
    6179       #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
    6180       #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
    6181       #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
    6182                                          '(:running :sleeping))))
    6183 
    6184   (defun wait-process (process-info)
    6185     "Wait for the process to terminate, if it is still running.
    6186 Otherwise, return immediately. An exit code (a number) will be
    6187 returned, with 0 indicating success, and anything else indicating
    6188 failure. If the process exits after receiving a signal, the exit code
    6189 will be the sum of 128 and the (positive) numeric signal code. A second
    6190 value may be returned in this case: the numeric signal code itself.
    6191 Any asynchronously spawned process requires this function to be run
    6192 before it is garbage-collected in order to free up resources that
    6193 might otherwise be irrevocably lost."
    6194     (if-let (exit-code (slot-value process-info 'exit-code))
    6195       (if-let (signal-code (slot-value process-info 'signal-code))
    6196         (values exit-code signal-code)
    6197         exit-code)
    6198       (let ((process (slot-value process-info 'process)))
    6199         #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    6200         (not-implemented-error 'wait-process)
    6201         (when process
    6202           ;; 1- wait
    6203           #+clozure (ccl::external-process-wait process)
    6204           #+(or cmucl scl) (ext:process-wait process)
    6205           #+sbcl (sb-ext:process-wait process)
    6206           ;; 2- extract result
    6207           (multiple-value-bind (exit-code signal-code)
    6208               (progn
    6209                 #+abcl (sys:process-wait process)
    6210                 #+allegro (multiple-value-bind (exit-code pid signal)
    6211                               (sys:reap-os-subprocess :pid process :wait t)
    6212                             (assert pid)
    6213                             (values exit-code signal))
    6214                 #+clozure (multiple-value-bind (status code)
    6215                               (ccl:external-process-status process)
    6216                             (if (eq status :signaled)
    6217                                 (values nil code)
    6218                                 code))
    6219                 #+(or cmucl scl) (let ((status (ext:process-status process))
    6220                                        (code (ext:process-exit-code process)))
    6221                                    (if (eq status :signaled)
    6222                                        (values nil code)
    6223                                        code))
    6224                 #+ecl (multiple-value-bind (status code)
    6225                           (ext:external-process-wait process t)
    6226                         (if (eq status :signaled)
    6227                             (values nil code)
    6228                             code))
    6229                 #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
    6230                                      #-lispworks7+ #'sys:pid-exit-status
    6231                                      process :wait t)
    6232                 #+mkcl (let ((code (mkcl:join-process process)))
    6233                          (if (stringp code)
    6234                              (values nil (%mkcl-signal-to-number code))
    6235                              code))
    6236                 #+sbcl (let ((status (sb-ext:process-status process))
    6237                              (code (sb-ext:process-exit-code process)))
    6238                          (if (eq status :signaled)
    6239                              (values nil code)
    6240                              code)))
    6241             (if signal-code
    6242                 (let ((%exit-code (%signal-to-exit-code signal-code)))
    6243                   (setf (slot-value process-info 'exit-code) %exit-code
    6244                         (slot-value process-info 'signal-code) signal-code)
    6245                   (values %exit-code signal-code))
    6246                 (progn (setf (slot-value process-info 'exit-code) exit-code)
    6247                        exit-code)))))))
     6103      process-info)))
     6104
     6105;;;; -------------------------------------------------------------------------
     6106;;;; run-program initially from xcvb-driver.
     6107
     6108(uiop/package:define-package :uiop/run-program
     6109  (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
     6110  (:use :uiop/common-lisp :uiop/package :uiop/utility
     6111   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
     6112  (:export
     6113   #:run-program
     6114   #:slurp-input-stream #:vomit-output-stream
     6115   #:subprocess-error
     6116   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)
     6117  (:import-from :uiop/launch-program
     6118   #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep
     6119   #:input-stream #:output-stream #:error-output-stream))
     6120(in-package :uiop/run-program)
     6121
     6122;;;; Slurping a stream, typically the output of another program
     6123(with-upgradability ()
     6124  (defun call-stream-processor (fun processor stream)
     6125    "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
     6126a PROCESSOR specification which is either an atom or a list specifying
     6127a processor an keyword arguments, call the specified processor with
     6128the given STREAM as input"
     6129    (if (consp processor)
     6130        (apply fun (first processor) stream (rest processor))
     6131        (funcall fun processor stream)))
     6132
     6133  (defgeneric slurp-input-stream (processor input-stream &key)
     6134    (:documentation
     6135     "SLURP-INPUT-STREAM is a generic function with two positional arguments
     6136PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
     6137the contents of the INPUT-STREAM and processes them according to a method
     6138specified by PROCESSOR.
     6139
     6140Built-in methods include the following:
     6141* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
     6142* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
     6143  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
     6144    \(APPLY x <stream> y\)
     6145* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
     6146  per copy-stream-to-stream, with appropriate keyword arguments.
     6147* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
     6148  are returned as a string, as per SLURP-STREAM-STRING.
     6149* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
     6150* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
     6151* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
     6152* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
     6153* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
     6154
     6155Programmers are encouraged to define their own methods for this generic function."))
     6156
     6157  #-genera
     6158  (defmethod slurp-input-stream ((function function) input-stream &key)
     6159    (funcall function input-stream))
     6160
     6161  (defmethod slurp-input-stream ((list cons) input-stream &key)
     6162    (apply (first list) input-stream (rest list)))
     6163
     6164  #-genera
     6165  (defmethod slurp-input-stream ((output-stream stream) input-stream
     6166                                 &key linewise prefix (element-type 'character) buffer-size)
     6167    (copy-stream-to-stream
     6168     input-stream output-stream
     6169     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     6170
     6171  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
     6172    (slurp-stream-string stream :stripped stripped))
     6173
     6174  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
     6175    (slurp-stream-string stream :stripped stripped))
     6176
     6177  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
     6178    (slurp-stream-lines stream :count count))
     6179
     6180  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
     6181    (slurp-stream-line stream :at at))
     6182
     6183  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
     6184    (slurp-stream-forms stream :count count))
     6185
     6186  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
     6187    (slurp-stream-form stream :at at))
     6188
     6189  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
     6190    (apply 'slurp-input-stream *standard-output* stream keys))
     6191
     6192  (defmethod slurp-input-stream ((x null) (stream t) &key)
     6193    nil)
     6194
     6195  (defmethod slurp-input-stream ((pathname pathname) input
     6196                                 &key
     6197                                   (element-type *default-stream-element-type*)
     6198                                   (external-format *utf-8-external-format*)
     6199                                   (if-exists :rename-and-delete)
     6200                                   (if-does-not-exist :create)
     6201                                   buffer-size
     6202                                   linewise)
     6203    (with-output-file (output pathname
     6204                              :element-type element-type
     6205                              :external-format external-format
     6206                              :if-exists if-exists
     6207                              :if-does-not-exist if-does-not-exist)
     6208      (copy-stream-to-stream
     6209       input output
     6210       :element-type element-type :buffer-size buffer-size :linewise linewise)))
     6211
     6212  (defmethod slurp-input-stream (x stream
     6213                                 &key linewise prefix (element-type 'character) buffer-size)
     6214    (declare (ignorable stream linewise prefix element-type buffer-size))
     6215    (cond
     6216      #+genera
     6217      ((functionp x) (funcall x stream))
     6218      #+genera
     6219      ((output-stream-p x)
     6220       (copy-stream-to-stream
     6221        stream x
     6222        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     6223      (t
     6224       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
     6225
     6226;;;; Vomiting a stream, typically into the input of another program.
     6227(with-upgradability ()
     6228  (defgeneric vomit-output-stream (processor output-stream &key)
     6229    (:documentation
     6230     "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
     6231PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
     6232some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
     6233
     6234Built-in methods include the following:
     6235* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
     6236* if PROCESSOR is a list, its first element should be a function.
     6237  It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
     6238  That is (x . y) will be treated as \(APPLY x <stream> y\)
     6239* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
     6240  per copy-stream-to-stream, with appropriate keyword arguments.
     6241* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
     6242* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
     6243
     6244Programmers are encouraged to define their own methods for this generic function."))
     6245
     6246  #-genera
     6247  (defmethod vomit-output-stream ((function function) output-stream &key)
     6248    (funcall function output-stream))
     6249
     6250  (defmethod vomit-output-stream ((list cons) output-stream &key)
     6251    (apply (first list) output-stream (rest list)))
     6252
     6253  #-genera
     6254  (defmethod vomit-output-stream ((input-stream stream) output-stream
     6255                                 &key linewise prefix (element-type 'character) buffer-size)
     6256    (copy-stream-to-stream
     6257     input-stream output-stream
     6258     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     6259
     6260  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
     6261    (princ x stream)
     6262    (when fresh-line (fresh-line stream))
     6263    (when terpri (terpri stream))
     6264    (values))
     6265
     6266  (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
     6267    (apply 'vomit-output-stream *standard-input* stream keys))
     6268
     6269  (defmethod vomit-output-stream ((x null) (stream t) &key)
     6270    (values))
     6271
     6272  (defmethod vomit-output-stream ((pathname pathname) input
     6273                                 &key
     6274                                   (element-type *default-stream-element-type*)
     6275                                   (external-format *utf-8-external-format*)
     6276                                   (if-exists :rename-and-delete)
     6277                                   (if-does-not-exist :create)
     6278                                   buffer-size
     6279                                   linewise)
     6280    (with-output-file (output pathname
     6281                              :element-type element-type
     6282                              :external-format external-format
     6283                              :if-exists if-exists
     6284                              :if-does-not-exist if-does-not-exist)
     6285      (copy-stream-to-stream
     6286       input output
     6287       :element-type element-type :buffer-size buffer-size :linewise linewise)))
     6288
     6289  (defmethod vomit-output-stream (x stream
     6290                                 &key linewise prefix (element-type 'character) buffer-size)
     6291    (declare (ignorable stream linewise prefix element-type buffer-size))
     6292    (cond
     6293      #+genera
     6294      ((functionp x) (funcall x stream))
     6295      #+genera
     6296      ((input-stream-p x)
     6297       (copy-stream-to-stream
     6298        x stream
     6299        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     6300      (t
     6301       (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
     6302
     6303
     6304;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
     6305(with-upgradability ()
     6306  (define-condition subprocess-error (error)
     6307    ((code :initform nil :initarg :code :reader subprocess-error-code)
     6308     (command :initform nil :initarg :command :reader subprocess-error-command)
     6309     (process :initform nil :initarg :process :reader subprocess-error-process))
     6310    (:report (lambda (condition stream)
     6311               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
     6312                       (subprocess-error-process condition)
     6313                       (subprocess-error-command condition)
     6314                       (subprocess-error-code condition)))))
    62486315
    62496316  (defun %check-result (exit-code &key command process ignore-error-status)
     
    62546321    exit-code)
    62556322
    6256   (defun close-streams (process-info)
    6257     "Close any stream that the process might own. Needs to be run
    6258 whenever streams were requested by passing :stream to :input, :output,
    6259 or :error-output."
    6260     (dolist (stream
    6261               (cons (slot-value process-info 'error-output-stream)
    6262                     (if-let (bidir-stream (slot-value process-info 'bidir-stream))
    6263                       (list bidir-stream)
    6264                       (list (slot-value process-info 'input-stream)
    6265                             (slot-value process-info 'output-stream)))))
    6266       (when stream (close stream))))
     6323  (defun %active-io-specifier-p (specifier)
     6324    "Determines whether a run-program I/O specifier requires Lisp-side processing
     6325via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
     6326or whether it's already taken care of by the implementation's underlying run-program."
     6327    (not (typep specifier '(or null string pathname (member :interactive :output)
     6328                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
     6329                            #+lispworks file-stream))))
     6330
     6331  (defun %run-program (command &rest keys &key &allow-other-keys)
     6332    "DEPRECATED. Use LAUNCH-PROGRAM instead."
     6333    (apply 'launch-program command keys))
    62676334
    62686335  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
    6269                                 &key element-type external-format &allow-other-keys)
     6336                                &key
     6337                                  (element-type #-clozure *default-stream-element-type* #+clozure 'character)
     6338                                  (external-format *utf-8-external-format*) &allow-other-keys)
    62706339    ;; handle redirection for run-program and system
    62716340    ;; SPEC is the specification for the subprocess's input or output or error-output
     
    64586527
    64596528  (defun %system (command &rest keys &key directory
    6460                                        input if-input-does-not-exist
    6461                                        output if-output-exists
    6462                                        error-output if-error-output-exists
     6529                                       input (if-input-does-not-exist :error)
     6530                                       output (if-output-exists :supersede)
     6531                                       error-output (if-error-output-exists :supersede)
    64636532                                       &allow-other-keys)
    64646533    "A portable abstraction of a low-level call to libc's system()."
     
    64666535                        if-output-exists error-output if-error-output-exists))
    64676536    #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    6468     (let (#+(or abcl ecl mkcl) (version (parse-version (lisp-implementation-version))))
     6537    (let (#+(or abcl ecl mkcl)
     6538            (version (parse-version
     6539                      #-abcl
     6540                      (lisp-implementation-version)
     6541                      #+abcl
     6542                      (second (split-string (implementation-identifier) :separator '(#\-))))))
    64696543      (nest
    64706544       #+abcl (unless (lexicographic< '< version '(1 4 0)))
     
    65286602                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
    65296603                         (external-format *utf-8-external-format*)
    6530                       &allow-other-keys)
     6604                       &allow-other-keys)
    65316605    "Run program specified by COMMAND,
    65326606either a list of strings specifying a program and list of arguments,
     
    659666702- either 0 if the subprocess exited with success status,
    65976671or an indication of failure via the EXIT-CODE of the process"
    6598     (declare (ignorable ignore-error-status))
     6672    (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
     6673                        if-error-output-exists element-type external-format ignore-error-status))
    65996674    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    66006675    (not-implemented-error 'run-program)
    6601     ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
    6602     ;; But don't override user's specified preference. [2015/06/29:rpg]
    6603     (when (stringp command)
    6604       (unless force-shell-suppliedp
    6605         #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16
    6606         (setf force-shell t)))
    66076676    (apply (if (or force-shell
    6608                    #+(or clasp clisp) t
     6677                   ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
     6678                   ;; But don't override user's specified preference. [2015/06/29:rpg]
     6679                   (and (stringp command)
     6680                        (or (not force-shell-suppliedp)
     6681                            #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t))))
     6682                   #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t
    66096683                   ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
    66106684                   #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
    66116685                                   (lexicographic<= '< ver '(16 0 0)))
    6612                    #+(and lispworks os-unix) (%interactivep input output error-output)
    6613                    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
     6686                   #+(and lispworks os-unix) (%interactivep input output error-output))
    66146687               '%use-system '%use-launch-program)
    6615            command
    6616            :input input
    6617            :output output
    6618            :error-output error-output
    6619            :if-input-does-not-exist if-input-does-not-exist
    6620            :if-output-exists if-output-exists
    6621            :if-error-output-exists if-error-output-exists
    6622            :element-type element-type :external-format external-format
    6623            keys))
    6624 
    6625   ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
    6626   ;; do what you expect it to. Sending SIGSTOP to a process spawned
    6627   ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
    6628   ;; to run the command (via `sh -c command`) but not the actual
    6629   ;; command.
    6630   #+os-unix
    6631   (defun %posix-send-signal (process-info signal)
    6632     #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
    6633     #+clozure (ccl:signal-external-process (slot-value process-info 'process)
    6634                                            signal :error-if-exited nil)
    6635     #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
    6636     #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
    6637     #-(or allegro clozure cmucl sbcl scl)
    6638     (if-let (pid (process-info-pid process-info))
    6639       (run-program (format nil "kill -~a ~a" signal pid)
    6640                    :ignore-error-status t)))
    6641 
    6642   ;;; this function never gets called on Windows, but the compiler cannot tell
    6643   ;;; that. [2016/09/25:rpg]
    6644   #+os-windows
    6645   (defun %posix-send-signal (process-info signal)
    6646     (declare (ignore process-info signal))
    6647     (values))
    6648 
    6649   (defun terminate-process (process-info &key urgent)
    6650     "Cause the process to exit. To that end, the process may or may
    6651 not be sent a signal, which it will find harder (or even impossible)
    6652 to ignore if URGENT is T. On some platforms, it may also be subject to
    6653 race conditions."
    6654     (declare (ignorable urgent))
    6655     #+abcl (sys:process-kill (slot-value process-info 'process))
    6656     ;; On ECL, this will only work on versions later than 2016-09-06,
    6657     ;; but we still want to compile on earlier versions, so we use symbol-call
    6658     #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
    6659     #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
    6660     #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
    6661                                      :force urgent)
    6662     #-(or abcl ecl lispworks7+ mkcl)
    6663     (os-cond
    6664      ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
    6665      ((os-windows-p) (if-let (pid (process-info-pid process-info))
    6666                        (run-program (format nil "taskkill ~:[~;/f ~]/pid ~a"
    6667                                             urgent pid)
    6668                                     :ignore-error-status t)))
    6669      (t (not-implemented-error 'terminate-process)))))
     6688           command keys)))
    66706689
    66716690;;;; ---------------------------------------------------------------------------
     
    71487167   :uiop/package :uiop/utility
    71497168   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
    7150    :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
     7169   :uiop/launch-program :uiop/run-program
     7170   :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
    71517171
    71527172;; Provide both lowercase and uppercase, to satisfy more people.
     
    72467266         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    72477267         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    7248          (asdf-version "3.1.7.35")
     7268         (asdf-version "3.1.7.40")
    72497269         (existing-version (asdf-version)))
    72507270    (setf *asdf-version* asdf-version)
     
    86258645  (:export
    86268646   #:operation
    8627    #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
    86288647   #:*operations* #:make-operation #:find-operation
    86298648   #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
     
    86318650
    86328651;;; Operation Classes
    8633 
    8634 (when-upgrading (:when (find-class 'operation nil))
     8652(when-upgrading (:version "2.27" :when (find-class 'operation nil))
    86358653  ;; override any obsolete shared-initialize method when upgrading from ASDF2.
    86368654  (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
     
    86398657(with-upgradability ()
    86408658  (defclass operation ()
    8641     ((original-initargs ;; for backward-compat -- used by GBBopen, and swank (via operation-forced)
    8642       :initform nil :initarg :original-initargs :accessor operation-original-initargs))
     8659    ()
    86438660    (:documentation "The base class for all ASDF operations.
    86448661
    8645 ASDF does NOT, never did and never will distinguish between multiple operations of the same class.
    8646 Therefore, all slots of all operations must have (:allocation class) and no initargs.
    8647 
    8648 Any exceptions currently maintained for backward-compatibility are deprecated,
    8649 and support for them may be discontinued at any moment.
     8662ASDF does NOT and never did distinguish between multiple operations of the same class.
     8663Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions.
    86508664"))
    8651 
    8652   ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not already bound.
    8653   ;; This is a deprecated feature temporarily maintained for backward compatibility.
    8654   ;; It will be removed at some point in the future.
    8655   (defmethod initialize-instance :after ((o operation) &rest initargs
    8656                                          &key force force-not system verbose &allow-other-keys)
    8657     (declare (ignore force force-not system verbose))
    8658     (unless (slot-boundp o 'original-initargs)
    8659       (setf (operation-original-initargs o) initargs)))
    86608665
    86618666  (defvar *in-make-operation* nil)
     
    86678672
    86688673  (defmethod print-object ((o operation) stream)
    8669     (print-unreadable-object (o stream :type t :identity nil)
    8670       (ignore-errors
    8671        (format stream "~{~S~^ ~}" (operation-original-initargs o))))))
     8674    (print-unreadable-object (o stream :type t :identity nil)))
     8675
     8676  ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking.
     8677  (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys)
     8678    (unless (null initargs)
     8679      (parameter-error "~S does not accept initargs" 'operation))))
     8680
    86728681
    86738682;;; make-operation, find-operation
     
    86788687
    86798688  ;; A memoizing way of creating instances of operation.
    8680   (defun make-operation (operation-class &rest initargs)
     8689  (defun make-operation (operation-class)
    86818690    "This function creates and memoizes an instance of OPERATION-CLASS.
    86828691All operation instances MUST be created through this function.
    86838692
    8684 Use of INITARGS is for backward compatibility and may be discontinued at any time."
     8693Use of INITARGS is not supported at this time."
    86858694    (let ((class (coerce-class operation-class
    86868695                               :package :asdf/interface :super 'operation :error 'sysdef-error))
    86878696          (*in-make-operation* t))
    8688       (ensure-gethash (cons class initargs) *operations*
    8689                       (list* 'make-instance class initargs))))
    8690 
    8691   ;; We preserve the operation-original-initargs of the context,
    8692   ;; but only as an unsupported feature.
    8693   ;; This is all done purely for the temporary sake of backwards compatibility.
     8697      (ensure-gethash class *operations* `(make-instance ,class))))
     8698
     8699  ;; This function is mostly for backward and forward compatibility:
     8700  ;; operations used to preserve the operation-original-initargs of the context,
     8701  ;; and may in the future preserve some operation-canonical-initargs.
     8702  ;; Still, the treatment of NIL as a disabling context is useful in some cases.
    86948703  (defgeneric find-operation (context spec)
    86958704    (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
    86968705  (defmethod find-operation ((context t) (spec operation))
    86978706    spec)
    8698   (defmethod find-operation (context (spec symbol))
     8707  (defmethod find-operation ((context t) (spec symbol))
    86998708    (when spec ;; NIL designates itself, i.e. absence of operation
    8700       (apply 'make-operation spec (operation-original-initargs context))))
    8701   (defmethod find-operation (context (spec string))
    8702     (apply 'make-operation spec (operation-original-initargs context)))
    8703   (defmethod operation-original-initargs ((context symbol))
    8704     (declare (ignorable context))
    8705     nil))
     8709      (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
     8710  (defmethod find-operation ((context t) (spec string))
     8711    (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
    87068712
    87078713;;;; -------------------------------------------------------------------------
     
    87518757    (cdr action)))
    87528758
    8753 ;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
     8759;;;; Reified representation for storage or debugging. Note: an action is identified by its class.
    87548760(with-upgradability ()
    87558761  (defun action-path (action)
     
    87748780  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
    87758781  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
    8776   ;; If OPERATION-INITARGS is true, then for backward compatibility the function has
    8777   ;; a &rest argument that is passed into the operation's initargs if and when it is created.
    87788782  (defmacro define-convenience-action-methods
    8779       (function formals &key if-no-operation if-no-component operation-initargs)
     8783      (function formals &key if-no-operation if-no-component)
    87808784    (let* ((rest (gensym "REST"))
    87818785           (found (gensym "FOUND"))
     
    88028806             (if ,operation
    88038807                 ,(next-method
    8804                    (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
    8805                        `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
    8806                        `(make-operation ,operation))
     8808                   `(make-operation ,operation)
    88078809                   `(or (find-component () ,component) ,if-no-component))
    88088810                 ,if-no-operation))
     
    88248826  (defmethod action-description (operation component)
    88258827    (format nil (compatfmt "~@<~A on ~A~@:>")
    8826             (type-of operation) component))
     8828            operation component))
    88278829
    88288830  (defun format-action (stream action &optional colon-p at-sign-p)
     
    91069108
    91079109  (defmethod component-operation-time ((o operation) (c component))
    9108     (gethash (type-of o) (component-operation-times c)))
     9110    (gethash o (component-operation-times c)))
    91099111
    91109112  (defmethod (setf component-operation-time) (stamp (o operation) (c component))
    9111     (setf (gethash (type-of o) (component-operation-times c)) stamp))
     9113    (setf (gethash o (component-operation-times c)) stamp))
    91129114
    91139115  (defmethod mark-operation-done ((o operation) (c component))
     
    91639165(uiop/package:define-package :asdf/lisp-action
    91649166  (:recycle :asdf/lisp-action :asdf)
    9165   (:intern #:proclamations #:flags)
    91669167  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
    91679168   :asdf/component :asdf/system :asdf/find-component :asdf/find-system
     
    91709171   #:try-recompiling
    91719172   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
    9172    #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
     9173   #:basic-load-op #:basic-compile-op
    91739174   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
    91749175   #:call-with-around-compile-hook
    91759176   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
    9176    #:lisp-compilation-output-files #:flags))
     9177   #:lisp-compilation-output-files))
    91779178(in-package :asdf/lisp-action)
    91789179
     
    91959196  (defclass basic-load-op (operation) ()
    91969197    (:documentation "Base class for operations that apply the load-time effects of a file"))
    9197   (defclass basic-compile-op (operation)
    9198     ;; NB: These slots are deprecated. They are for backward compatibility only,
    9199     ;; and will be removed at some point in the future.
    9200     ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    9201      (flags :initarg :flags :accessor compile-op-flags :initform nil))
     9198  (defclass basic-compile-op (operation) ()
    92029199    (:documentation "Base class for operations that apply the compile-time effects of a file")))
    92039200
     
    92859282                           #+clisp (list :lib-file lib-file)
    92869283                           #+(or clasp ecl mkcl) (list :object-file object-file)
    9287                            flags (compile-op-flags o))))))
     9284                           flags)))))
    92889285        (check-lisp-compile-results output warnings-p failure-p
    92899286                                    "~/asdf-action::format-action/" (list (cons o c))))))
     
    94279424   #:planned-action-status #:plan-action-status #:action-already-done-p
    94289425   #:circular-dependency #:circular-dependency-actions
    9429    #:node-for #:needed-in-image-p
     9426   #:needed-in-image-p
    94309427   #:action-index #:action-planned-p #:action-valid-p
    94319428   #:plan-record-dependency
     
    94989495    t) ; default method for non planned-action-status objects
    94999496
    9500   ;; TODO: either confirm there are no operation-original-initargs, eliminate NODE-FOR,
    9501   ;; and use (CONS O C); or keep the operation initargs, and here use MAKE-OPERATION.
    9502   ;; However, see also component-operation-time and mark-operation-done
    9503   (defun node-for (o c)
    9504     "Given operation O and component C, return an object to use as key in action-indexed tables."
    9505     (cons (type-of o) c))
    9506 
    95079497  (defun action-already-done-p (plan operation component)
    95089498    "According to this plan, is this action already done and up to date?"
     
    95149504
    95159505  (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
    9516     (let ((to (type-of o))
    9517           (times (component-operation-times c)))
     9506    (let ((times (component-operation-times c)))
    95189507      (if (action-done-p new-status)
    9519           (remhash to times)
    9520           (setf (gethash to times) (action-stamp new-status))))
     9508          (remhash o times)
     9509          (setf (gethash o times) (action-stamp new-status))))
    95219510    new-status))
    95229511
     
    97309719
    97319720  (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component))
    9732     (setf (gethash (node-for o c) (plan-visited-actions p)) new-status))
     9721    (setf (gethash (cons o c) (plan-visited-actions p)) new-status))
    97339722
    97349723  (defmethod plan-action-status ((p plan-traversal) (o operation) (c component))
    97359724    (or (and (action-forced-not-p p o c) (plan-action-status nil o c))
    9736         (values (gethash (node-for o c) (plan-visited-actions p)))))
     9725        (values (gethash (cons o c) (plan-visited-actions p)))))
    97379726
    97389727  (defmethod action-valid-p ((p plan-traversal) (o operation) (s system))
     
    1001110000
    1001210001  (define-convenience-action-methods operate (operation component &key)
    10013     ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
    10014     ;; but swank.asd relies on :force (!).
    10015     :operation-initargs t ;; backward-compatibility with ASDF1. Deprecated.
    1001610002    :if-no-component (error 'missing-component :requires component))
    1001710003
     
    1003210018           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
    1003310019            (etypecase operation
    10034               (operation (let ((name (type-of operation))
    10035                                (initargs (operation-original-initargs operation)))
    10036                            #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
     10020              (operation (let ((name (type-of operation)))
     10021                           #'(lambda () (make-operation name))))
    1003710022              ((or symbol string) (constantly operation))))
    1003810023           (component-path (typecase component ;; to remake the component after ASDF upgrade
     
    1004510030         (when (upgrade-asdf)
    1004610031           ;; If we were upgraded, restart OPERATE the hardest of ways, for
    10047            ;; its function may have been redefined, its symbol uninterned, its package deleted.
     10032           ;; its function may have been redefined.
    1004810033           (return-from operate
    1004910034             (apply 'operate (funcall operation-remaker) component-path keys)))))
     
    1025110236      (let ((times (component-operation-times component)))
    1025210237        (dolist (o '(load-op compile-op prepare-op))
    10253           (setf (gethash o times) 0))))))
     10238          (setf (gethash (make-operation o) times) 0))))))
    1025410239
    1025510240;;;; -------------------------------------------------------------------------
     
    1026710252   #:class-for-type #:*default-component-class*
    1026810253   #:determine-system-directory #:parse-component-form
    10269    #:non-toplevel-system #:non-system-system
     10254   #:non-toplevel-system #:non-system-system #:bad-system-name
    1027010255   #:sysdef-error-component #:check-component-input))
    1027110256(in-package :asdf/parse-defsystem)
     
    1032710312               (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
    1032810313                       (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
     10314
     10315  (define-condition bad-system-name (warning)
     10316    ((name :initarg :name :reader component-name)
     10317     (source-file :initarg :source-file :reader system-source-file))
     10318    (:report (lambda (c s)
     10319               (let* ((file (system-source-file c))
     10320                      (name (component-name c))
     10321                      (asd (pathname-name file)))
     10322                 (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~
     10323Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>")
     10324                       file name asd (strcat asd "/") (strcat asd "/test"))))))
    1032910325
    1033010326  (defun sysdef-error-component (msg type name value)
     
    1053110527    ;; that is registered to a different location to find-system,
    1053210528    ;; we also need to remember it in the asdf-cache.
    10533     (with-asdf-cache ()
    10534       (let* ((name (coerce-name name))
    10535              (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
    10536              ;; NB: handle defsystem-depends-on BEFORE to create the system object,
    10537              ;; so that in case it fails, there is no incomplete object polluting the build.
    10538              (checked-defsystem-depends-on
    10539                (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
    10540                       (deps (loop :for spec :in dep-forms
    10541                                   :when (resolve-dependency-spec nil spec)
    10542                                     :collect :it)))
    10543                  (load-systems* deps)
    10544                  dep-forms))
    10545              (registered (system-registered-p name))
    10546              (registered! (if registered
    10547                               (rplaca registered (get-file-stamp source-file))
    10548                               (register-system
    10549                                (make-instance 'system :name name :source-file source-file))))
    10550              (system (reset-system (cdr registered!)
    10551                                    :name name :source-file source-file))
    10552              (component-options
    10553               (append
    10554                (remove-plist-keys '(:defsystem-depends-on :class) options)
    10555                ;; cache defsystem-depends-on in canonical form
    10556                (when checked-defsystem-depends-on
    10557                  `(:defsystem-depends-on ,checked-defsystem-depends-on)))))
    10558         ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
    10559         (set-asdf-cache-entry `(find-system ,name) (list system))
    10560         ;; We change-class AFTER we loaded the defsystem-depends-on
    10561         ;; since the class might be defined as part of those.
    10562         (let ((class (class-for-type nil class)))
    10563           (unless (subtypep class 'system)
    10564             (error 'non-system-system :name name :class-name (class-name class)))
    10565           (unless (eq (type-of system) class)
    10566             (change-class system class)))
    10567         (parse-component-form
    10568          nil (list*
    10569               :module name
    10570               :pathname (determine-system-directory pathname)
    10571               component-options)))))
     10529    (nest
     10530     (with-asdf-cache ())
     10531     (let* ((name (coerce-name name))
     10532            (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
     10533            (asd-name (and source-file
     10534                           (equalp "asd" (pathname-type source-file))
     10535                           (pathname-name source-file)))
     10536            (primary-name (primary-system-name name)))
     10537       (when (and asd-name (not (equal asd-name primary-name)))
     10538         (warn (make-condition 'bad-system-name :source-file source-file :name name))))
     10539     (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
     10540            ;; so that in case it fails, there is no incomplete object polluting the build.
     10541            (checked-defsystem-depends-on
     10542             (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
     10543                    (deps (loop :for spec :in dep-forms
     10544                            :when (resolve-dependency-spec nil spec)
     10545                            :collect :it)))
     10546               (load-systems* deps)
     10547               dep-forms))
     10548            (registered (system-registered-p name))
     10549            (registered! (if registered
     10550                             (rplaca registered (get-file-stamp source-file))
     10551                             (register-system
     10552                              (make-instance 'system :name name :source-file source-file))))
     10553            (system (reset-system (cdr registered!)
     10554                                  :name name :source-file source-file))
     10555            (component-options
     10556             (append
     10557              (remove-plist-keys '(:defsystem-depends-on :class) options)
     10558              ;; cache defsystem-depends-on in canonical form
     10559              (when checked-defsystem-depends-on
     10560                `(:defsystem-depends-on ,checked-defsystem-depends-on))))
     10561            (directory (determine-system-directory pathname)))
     10562       ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
     10563       (set-asdf-cache-entry `(find-system ,name) (list system)))
     10564     ;; We change-class AFTER we loaded the defsystem-depends-on
     10565     ;; since the class might be defined as part of those.
     10566     (let ((class (class-for-type nil class)))
     10567       (unless (subtypep class 'system)
     10568         (error 'non-system-system :name name :class-name (class-name class)))
     10569       (unless (eq (type-of system) class)
     10570         (change-class system class)))
     10571     (parse-component-form nil (list* :module name :pathname directory component-options))))
    1057210572
    1057310573  (defmacro defsystem (name &body options)
     
    1059210592   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
    1059310593   #:user-system-p #:user-system #:trivial-system-p
    10594    #:make-build
    10595    #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
     10594   #:prologue-code #:epilogue-code #:static-library))
    1059610595(in-package :asdf/bundle)
    1059710596
     
    1060110600    ;; and only supported in a temporary fashion for backward compatibility.
    1060210601    ;; Supported replacement: Define slots on program-system instead.
    10603     ((build-args :initarg :args :initform nil :accessor extra-build-args)
    10604      (name-suffix :initarg :name-suffix :initform nil)
    10605      (bundle-type :initform :no-output-file :reader bundle-type)
    10606      #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))
     10602    ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
    1060710603    (:documentation "base class for operations that bundle outputs from multiple components"))
    1060810604
     
    1061410610itself."))
    1061510611
    10616   (defclass monolithic-bundle-op (monolithic-op bundle-op)
     10612  (defclass monolithic-bundle-op (bundle-op monolithic-op)
    1061710613    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
    1061810614    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
     
    1063510631                       :initform nil :accessor extra-build-args)))
    1063610632
    10637   (defmethod prologue-code ((x t)) nil)
    10638   (defmethod epilogue-code ((x t)) nil)
    10639   (defmethod no-uiop ((x t)) nil)
    10640   (defmethod prefix-lisp-object-files ((x t)) nil)
    10641   (defmethod postfix-lisp-object-files ((x t)) nil)
    10642   (defmethod extra-object-files ((x t)) nil)
    10643   (defmethod extra-build-args ((x t)) nil)
     10633  (defmethod prologue-code ((x system)) nil)
     10634  (defmethod epilogue-code ((x system)) nil)
     10635  (defmethod no-uiop ((x system)) nil)
     10636  (defmethod prefix-lisp-object-files ((x system)) nil)
     10637  (defmethod postfix-lisp-object-files ((x system)) nil)
     10638  (defmethod extra-object-files ((x system)) nil)
     10639  (defmethod extra-build-args ((x system)) nil)
    1064410640
    1064510641  (defclass link-op (bundle-op) ()
     
    1074410740
    1074510741
    10746   (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
     10742  (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
    1074710743    ((selfward-operation
    1074810744      ;; TODO: implement link-op on all implementations, and make that
     
    1075310749
    1075410750  (defclass monolithic-compile-bundle-op
    10755       (monolithic-bundle-op basic-compile-bundle-op
     10751      (basic-compile-bundle-op monolithic-bundle-op
    1075610752       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
    1075710753    ((gather-operation
     
    1076310759    (:documentation "Create a single fasl for the system and its dependencies."))
    1076410760
    10765   (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
     10761  (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
    1076610762    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
    1076710763    (:documentation "Load a single fasl for the system and its dependencies."))
    1076810764
    10769   (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)
     10765  (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)
    1077010766    ((gather-type :initform :static-library :allocation :class))
    1077110767    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
    1077210768for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
    1077310769
    10774   (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
     10770  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
    1077510771    ((gather-type :initform :static-library :allocation :class))
    1077610772    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
     
    1077910775  (defclass image-op (monolithic-bundle-op selfward-operation
    1078010776                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
    10781     ((bundle-type :initform :image)
     10777    ((bundle-type :initform :image :allocation :class)
    1078210778     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
    1078310779     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
     
    1078510781
    1078610782  (defclass program-op (image-op)
    10787     ((bundle-type :initform :program))
     10783    ((bundle-type :initform :program :allocation :class))
    1078810784    (:documentation "create an executable file from the system and its dependencies"))
    1078910785
     
    1082110817                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
    1082210818        (let ((name (or (component-build-pathname c)
    10823                         (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
     10819                        (let ((suffix
     10820                               (unless (typep o 'program-op)
     10821                                 ;; "." is no good separator for Logical Pathnames, so we use "--"
     10822                                 (if (operation-monolithic-p o)
     10823                                     "--all-systems"
     10824                                     ;; These use a different type .fasb or .a instead of .fasl
     10825                                     #-(or clasp ecl mkcl) "--system"))))
     10826                          (format nil "~A~@[~A~]" (component-name c) suffix))))
    1082410827              (type (bundle-pathname-type bundle-type)))
    1082510828          (values (list (subpathname (component-pathname c) name :type type))
     
    1086310866;;; The different targets are defined by specialization.
    1086410867;;;
    10865 (with-upgradability ()
    10866   (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
    10867                                          &key (name-suffix nil name-suffix-p)
    10868                                          &allow-other-keys)
    10869     (declare (ignore initargs name-suffix))
    10870     ;; TODO: make that class slots or methods, not instance slots
    10871     (unless name-suffix-p
    10872       (setf (slot-value instance 'name-suffix)
    10873             (unless (typep instance 'program-op)
    10874               ;; "." is no good separator for Logical Pathnames, so we use "--"
    10875               (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
    10876     (when (typep instance 'monolithic-bundle-op)
    10877       (destructuring-bind (&key lisp-files prologue-code epilogue-code
    10878                            &allow-other-keys)
    10879           (operation-original-initargs instance)
    10880         (setf (prologue-code instance) prologue-code
    10881               (epilogue-code instance) epilogue-code)
    10882         #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
    10883         #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
    10884     (setf (extra-build-args instance)
    10885           (remove-plist-keys
    10886            '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
    10887              :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
    10888            (operation-original-initargs instance))))
    10889 
     10868(when-upgrading (:version "3.1.9")
     10869  ;; Cancel any previously defined method
     10870  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
     10871    (declare (ignore initargs))))
     10872
     10873(with-upgradability ()
    1089010874  (defgeneric trivial-system-p (component))
    1089110875
     
    1093710921       'image-op)
    1093810922      ((:program)
    10939        'program-op)))
    10940 
    10941   ;; DEPRECATED. This is originally from asdf-ecl.lisp.
    10942   ;; It must die, and so must any use of initargs in operation,
    10943   ;; unless keys to the asdf-cache are substantially modified to accommodate for them.
    10944   ;; Coordinate with the ECL maintainers to get them to stop using it.
    10945   ;; SUPPORTED REPLACEMENT: Use program-op and program-system
    10946   (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
    10947                              (move-here nil move-here-p)
    10948                              &allow-other-keys)
    10949     (let* ((operation-name (select-bundle-operation type monolithic))
    10950            (move-here-path (if (and move-here
    10951                                     (typep move-here '(or pathname string)))
    10952                                (ensure-pathname move-here :namestring :lisp :ensure-directory t)
    10953                                (system-relative-pathname system "asdf-output/")))
    10954            (operation (apply 'operate operation-name
    10955                              system
    10956                              (remove-plist-keys '(:monolithic :type :move-here) args)))
    10957            (system (find-system system))
    10958            (files (and system (output-files operation system))))
    10959       (if (or move-here (and (null move-here-p)
    10960                              (member operation-name '(:program :image))))
    10961           (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
    10962                 :for f :in files
    10963                 :for new-f = (make-pathname :name (pathname-name f)
    10964                                             :type (pathname-type f)
    10965                                             :defaults dest-path)
    10966                 :do (handler-case (rename-file-overwriting-target f new-f)
    10967                       (file-error (c)
    10968                         (declare (ignore c))
    10969                         (copy-file f new-f)
    10970                         (delete-file-if-exists f)))
    10971                 :collect new-f)
    10972           files)))
    10973 
    10974   ;; DEPRECATED. Apparently, some users of ECL, MKCL and ABCL may still be using it;
    10975   ;; but at the very least, this function should be renamed, and/or
    10976   ;; some way of specifying the output directory should be provided.
    10977   ;; As is, it is not such a useful interface.
    10978   (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    10979     (declare (ignore force verbose version))
    10980     (apply 'operate 'deliver-asd-op system args)))
     10923       'program-op))))
    1098110924
    1098210925;;;
     
    1111311056          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
    1111411057                 (implementation-type) non-fasl-files))
    11115         (when (or (prologue-code o) (epilogue-code o)
    11116                   (prologue-code c) (epilogue-code c))
     11058        (when (or (prologue-code c) (epilogue-code c))
    1111711059          (error "prologue-code and epilogue-code are not supported on ~A"
    1111811060                 (implementation-type)))
     
    1119011132                       (when programp (postfix-lisp-object-files c)))
    1119111133               :kind kind
    11192                :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
    11193                :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
    11194                :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
    11195                :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
     11134               :prologue-code (when programp (prologue-code c))
     11135               :epilogue-code (when programp (epilogue-code c))
     11136               :build-args (when programp (extra-build-args c))
     11137               :extra-object-files (when programp (extra-object-files c))
    1119611138               :no-uiop (no-uiop c)
    1119711139               (when programp `(:entry-point ,(component-entry-point c))))))))
     
    1231312255Deprecated function, for backward-compatibility only.
    1231412256Please use UIOP:RUN-PROGRAM instead."
     12257    #-(and ecl os-windows)
    1231512258    (let ((command (apply 'format nil control-string args)))
    1231612259      (asdf-message "; $ ~A~%" command)
     
    1232112264        (typecase exit-code
    1232212265          ((integer 0 255) exit-code)
    12323           (t 255))))))
     12266          (t 255))))
     12267    #+(and ecl os-windows)
     12268    (not-implemented-error "run-shell-command" "for ECL on Windows.")
     12269    ))
    1232412270
    1232512271
     
    1240612352   #:component-load-dependencies #:run-shell-command ; deprecated, do not use
    1240712353   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
    12408    #:program-system #:make-build
     12354   #:program-system
    1240912355   #:basic-compile-bundle-op #:prepare-bundle-op
    1241012356   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
     
    1249512441   #:missing-dependency-of-version
    1249612442   #:circular-dependency        ; errors
    12497    #:duplicate-names #:non-toplevel-system #:non-system-system
     12443   #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name
    1249812444   #:package-inferred-system-missing-package-error
    1249912445   #:operation-definition-warning #:operation-definition-error
Note: See TracChangeset for help on using the changeset viewer.