Changeset 14913


Ignore:
Timestamp:
11/21/16 07:46:45 (5 years ago)
Author:
Mark Evenson
Message:

asdf-3.1.7.35

Location:
trunk/abcl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/CHANGES

    r14905 r14913  
    33<http://abcl.org/svn/trunk/>
    44<http://gitlab.common-lisp.net/abcl/abcl/>
    5 <http://github.com/easye/abcl/>
     5<http://github.com/armedbear/abcl/>
    66Unreleased
    77
     
    1515* ABCL-ASDF uses the value of the reported Maven home to look for
    1616  libraries, fixing loading CFFI under FreeBSD 11-RELEASE
     17
     18Updates
     19-------
     20
     21* ASDF 3.1.7.35
     22
    1723
    1824Version 1.4.0
  • trunk/abcl/abcl.rdf

    r14900 r14913  
    153153
    154154abcl:jna dc:version "4.2.2" .
    155 abcl:asdf dc:version "3.1.7.27" .
     155abcl:asdf dc:version "3.1.7.35" .
    156156
    157157abcl:abcl-contrib 
  • trunk/abcl/doc/asdf/asdf.texinfo

    r14883 r14913  
    6666@titlepage
    6767@title ASDF: Another System Definition Facility
    68 @subtitle Manual for Version 3.1.7.27
     68@subtitle Manual for Version 3.1.7.35
    6969@c The following two commands start the copyright page.
    7070@page
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14883 r14913  
    11;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.7.27: Another System Definition Facility.
     2;;; This is ASDF 3.1.7.35: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    877877    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
    878878
    879 #+(and ecl (not clasp))
     879#+ecl
    880880(eval-when (:load-toplevel :compile-toplevel :execute)
    881881  (setf *load-verbose* nil)
     
    10181018   #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
    10191019   #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
    1020    #:undefine-function #:undefine-functions #:defun* #:defgeneric*
     1020   #:defun* #:defgeneric*
    10211021   #:nest #:if-let ;; basic flow control
    10221022   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
     
    10491049;; For a generic function, this invalidates any previous DEFMETHOD.
    10501050(eval-when (:load-toplevel :compile-toplevel :execute)
    1051   (defun undefine-function (function-spec)
    1052     (cond
    1053       ((symbolp function-spec)
    1054        ;; undefining the previous function is the portable way
    1055        ;; of overriding any incompatible previous gf,
    1056        ;; but CLISP needs extra help with getting rid of previous methods.
    1057        #+clisp
    1058        (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
    1059          (when (typep f 'clos:standard-generic-function)
    1060            (loop :for m :in (clos:generic-function-methods f)
    1061                  :do (remove-method f m))))
    1062        (fmakunbound function-spec))
    1063       ((and (consp function-spec) (eq (car function-spec) 'setf)
    1064             (consp (cdr function-spec)) (null (cddr function-spec)))
    1065        (fmakunbound function-spec))
    1066       (t (error "bad function spec ~S" function-spec))))
    1067   (defun undefine-functions (function-spec-list)
    1068     (map () 'undefine-function function-spec-list))
    10691051  (macrolet
    10701052      ((defdef (def* def)
     
    10781060                 ;; We usually try to do it only for the functions that need it,
    10791061                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
    1080                  ,@(when (or supersede #+(or clasp ecl) t)
    1081                      `((undefine-function ',name)))
     1062                 ,@(when supersede
     1063                     `((fmakunbound ',name)))
    10821064                 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
    10831065                     `((declaim (notinline ,name))))
     
    11061088    '(or (ignore-errors
    11071089          (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
    1108       (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
     1090      (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))
    11091091    "form that evaluates to the pathname to your favorite debugging utilities")
    11101092
     
    20942076   #:directory-pathname-p #:ensure-directory-pathname
    20952077   ;; Parsing filenames
    2096    #:component-name-to-pathname-components
    20972078   #:split-name-type #:parse-unix-namestring #:unix-namestring
    20982079   #:split-unix-namestring-directory-components
     
    22602241    (declare (ignorable defaults))
    22612242    #.`(make-pathname :directory nil :name nil :type nil :version nil
    2262                       :device (or #+(and mkcl unix) :unspecific)
    2263                       :host (or #+cmucl lisp::*unix-host* #+(and mkcl unix) "localhost")
     2243                      :device (or #+(and mkcl os-unix) :unspecific)
     2244                      :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost")
    22642245                      #+scl ,@'(:scheme nil :scheme-specific-part nil
    22652246                                :username nil :password nil :parameters nil :query nil :fragment nil)
     
    22992280            (and (pathnamep p1) (pathnamep p2)
    23002281                 (and (=? pathname-host)
    2301                       #-(and mkcl unix) (=? pathname-device)
     2282                      #-(and mkcl os-unix) (=? pathname-device)
    23022283                      (=? normalize-pathname-directory-component pathname-directory)
    23032284                      (=? pathname-name)
     
    28122793create-lisp-op creates a lisp file from some higher-level input,
    28132794you need to still be able to use compile-op on that lisp file."))
    2814 
    28152795;;;; -------------------------------------------------------------------------
    28162796;;;; Portability layer around Common Lisp filesystem access
     
    29512931            (and
    29522932             #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
    2953              #+(and lispworks unix) (system:get-file-stat p)
     2933             #+(and lispworks os-unix) (system:get-file-stat p)
    29542934             #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
    2955              #-(or cmucl (and lispworks unix) sbcl scl) (file-write-date p)
     2935             #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
    29562936             p))))))
    29572937
     
    46604640      #+(or clasp ecl) (check-type kind (member :dll :lib :static-library :program :object :fasl))
    46614641      (apply #+clasp 'cmp:builder #+clasp kind
    4662              #+(and ecl (not clasp)) 'c::builder #+(and ecl (not clasp)) kind
     4642             #+ecl 'c::builder #+ecl kind
    46634643             #+mkcl (ecase kind
    46644644                      ((:dll) 'compiler::build-shared-library)
     
    46824662         setup-command-line-arguments setup-temporary-directory
    46834663         #+abcl detect-os)))
    4684 ;;;; -------------------------------------------------------------------------
    4685 ;;;; run-program initially from xcvb-driver.
    4686 
    4687 (uiop/package:define-package :uiop/run-program
    4688   (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
    4689   (:use :uiop/common-lisp :uiop/package :uiop/utility
    4690    :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
    4691   (:export
    4692    ;;; Escaping the command invocation madness
    4693    #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
    4694    #:escape-windows-token #:escape-windows-command
    4695    #:escape-token #:escape-command
    4696 
    4697    ;;; run-program
    4698    #:slurp-input-stream #:vomit-output-stream
    4699    #:close-streams #:launch-program #:process-alive-p #:run-program
    4700    #:terminate-process #:wait-process
    4701    #:process-info-error-output #:process-info-input #:process-info-output
    4702    #:process-info-pid
    4703    #:subprocess-error
    4704    #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
    4705    ))
    4706 (in-package :uiop/run-program)
    4707 
    4708 ;;;; ----- Escaping strings for the shell -----
    4709 
    4710 (with-upgradability ()
    4711   (defun requires-escaping-p (token &key good-chars bad-chars)
    4712     "Does this token require escaping, given the specification of
    4713 either good chars that don't need escaping or bad chars that do need escaping,
    4714 as either a recognizing function or a sequence of characters."
    4715     (some
    4716      (cond
    4717        ((and good-chars bad-chars)
    4718         (error "only one of good-chars and bad-chars can be provided"))
    4719        ((typep good-chars 'function)
    4720         (complement good-chars))
    4721        ((typep bad-chars 'function)
    4722         bad-chars)
    4723        ((and good-chars (typep good-chars 'sequence))
    4724         #'(lambda (c) (not (find c good-chars))))
    4725        ((and bad-chars (typep bad-chars 'sequence))
    4726         #'(lambda (c) (find c bad-chars)))
    4727        (t (error "requires-escaping-p: no good-char criterion")))
    4728      token))
    4729 
    4730   (defun escape-token (token &key stream quote good-chars bad-chars escaper)
    4731     "Call the ESCAPER function on TOKEN string if it needs escaping as per
    4732 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
    4733 using STREAM as output (or returning result as a string if NIL)"
    4734     (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
    4735         (with-output (stream)
    4736           (apply escaper token stream (when quote `(:quote ,quote))))
    4737         (output-string token stream)))
    4738 
    4739   (defun escape-windows-token-within-double-quotes (x &optional s)
    4740     "Escape a string token X within double-quotes
    4741 for use within a MS Windows command-line, outputing to S."
    4742     (labels ((issue (c) (princ c s))
    4743              (issue-backslash (n) (loop :repeat n :do (issue #\\))))
    4744       (loop
    4745         :initially (issue #\") :finally (issue #\")
    4746         :with l = (length x) :with i = 0
    4747         :for i+1 = (1+ i) :while (< i l) :do
    4748           (case (char x i)
    4749             ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
    4750             ((#\\)
    4751              (let* ((j (and (< i+1 l) (position-if-not
    4752                                        #'(lambda (c) (eql c #\\)) x :start i+1)))
    4753                     (n (- (or j l) i)))
    4754                (cond
    4755                  ((null j)
    4756                   (issue-backslash (* 2 n)) (setf i l))
    4757                  ((and (< j l) (eql (char x j) #\"))
    4758                   (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
    4759                  (t
    4760                   (issue-backslash n) (setf i j)))))
    4761             (otherwise
    4762              (issue (char x i)) (setf i i+1))))))
    4763 
    4764   (defun easy-windows-character-p (x)
    4765     "Is X an \"easy\" character that does not require quoting by the shell?"
    4766     (or (alphanumericp x) (find x "+-_.,@:/=")))
    4767 
    4768   (defun escape-windows-token (token &optional s)
    4769     "Escape a string TOKEN within double-quotes if needed
    4770 for use within a MS Windows command-line, outputing to S."
    4771     (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
    4772                         :escaper 'escape-windows-token-within-double-quotes))
    4773 
    4774   (defun escape-sh-token-within-double-quotes (x s &key (quote t))
    4775     "Escape a string TOKEN within double-quotes
    4776 for use within a POSIX Bourne shell, outputing to S;
    4777 omit the outer double-quotes if key argument :QUOTE is NIL"
    4778     (when quote (princ #\" s))
    4779     (loop :for c :across x :do
    4780       (when (find c "$`\\\"") (princ #\\ s))
    4781       (princ c s))
    4782     (when quote (princ #\" s)))
    4783 
    4784   (defun easy-sh-character-p (x)
    4785     "Is X an \"easy\" character that does not require quoting by the shell?"
    4786     (or (alphanumericp x) (find x "+-_.,%@:/=")))
    4787 
    4788   (defun escape-sh-token (token &optional s)
    4789     "Escape a string TOKEN within double-quotes if needed
    4790 for use within a POSIX Bourne shell, outputing to S."
    4791     (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
    4792                         :escaper 'escape-sh-token-within-double-quotes))
    4793 
    4794   (defun escape-shell-token (token &optional s)
    4795     "Escape a token for the current operating system shell"
    4796     (os-cond
    4797       ((os-unix-p) (escape-sh-token token s))
    4798       ((os-windows-p) (escape-windows-token token s))))
    4799 
    4800   (defun escape-command (command &optional s
    4801                                   (escaper 'escape-shell-token))
    4802     "Given a COMMAND as a list of tokens, return a string of the
    4803 spaced, escaped tokens, using ESCAPER to escape."
    4804     (etypecase command
    4805       (string (output-string command s))
    4806       (list (with-output (s)
    4807               (loop :for first = t :then nil :for token :in command :do
    4808                 (unless first (princ #\space s))
    4809                 (funcall escaper token s))))))
    4810 
    4811   (defun escape-windows-command (command &optional s)
    4812     "Escape a list of command-line arguments into a string suitable for parsing
    4813 by CommandLineToArgv in MS Windows"
    4814     ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
    4815     ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
    4816     (escape-command command s 'escape-windows-token))
    4817 
    4818   (defun escape-sh-command (command &optional s)
    4819     "Escape a list of command-line arguments into a string suitable for parsing
    4820 by /bin/sh in POSIX"
    4821     (escape-command command s 'escape-sh-token))
    4822 
    4823   (defun escape-shell-command (command &optional stream)
    4824     "Escape a command for the current operating system's shell"
    4825     (escape-command command stream 'escape-shell-token)))
    4826 
    4827 
    4828 ;;;; Slurping a stream, typically the output of another program
    4829 (with-upgradability ()
    4830   (defun call-stream-processor (fun processor stream)
    4831     "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
    4832 a PROCESSOR specification which is either an atom or a list specifying
    4833 a processor an keyword arguments, call the specified processor with
    4834 the given STREAM as input"
    4835     (if (consp processor)
    4836         (apply fun (first processor) stream (rest processor))
    4837         (funcall fun processor stream)))
    4838 
    4839   (defgeneric slurp-input-stream (processor input-stream &key)
    4840     (:documentation
    4841      "SLURP-INPUT-STREAM is a generic function with two positional arguments
    4842 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
    4843 the contents of the INPUT-STREAM and processes them according to a method
    4844 specified by PROCESSOR.
    4845 
    4846 Built-in methods include the following:
    4847 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
    4848 * if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
    4849   INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    4850     \(APPLY x <stream> y\)
    4851 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
    4852   per copy-stream-to-stream, with appropriate keyword arguments.
    4853 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
    4854   are returned as a string, as per SLURP-STREAM-STRING.
    4855 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
    4856 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
    4857 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
    4858 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
    4859 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
    4860 
    4861 Programmers are encouraged to define their own methods for this generic function."))
    4862 
    4863   #-genera
    4864   (defmethod slurp-input-stream ((function function) input-stream &key)
    4865     (funcall function input-stream))
    4866 
    4867   (defmethod slurp-input-stream ((list cons) input-stream &key)
    4868     (apply (first list) input-stream (rest list)))
    4869 
    4870   #-genera
    4871   (defmethod slurp-input-stream ((output-stream stream) input-stream
    4872                                  &key linewise prefix (element-type 'character) buffer-size)
    4873     (copy-stream-to-stream
    4874      input-stream output-stream
    4875      :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    4876 
    4877   (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    4878     (slurp-stream-string stream :stripped stripped))
    4879 
    4880   (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    4881     (slurp-stream-string stream :stripped stripped))
    4882 
    4883   (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
    4884     (slurp-stream-lines stream :count count))
    4885 
    4886   (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
    4887     (slurp-stream-line stream :at at))
    4888 
    4889   (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
    4890     (slurp-stream-forms stream :count count))
    4891 
    4892   (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
    4893     (slurp-stream-form stream :at at))
    4894 
    4895   (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    4896     (apply 'slurp-input-stream *standard-output* stream keys))
    4897 
    4898   (defmethod slurp-input-stream ((x null) (stream t) &key)
    4899     nil)
    4900 
    4901   (defmethod slurp-input-stream ((pathname pathname) input
    4902                                  &key
    4903                                    (element-type *default-stream-element-type*)
    4904                                    (external-format *utf-8-external-format*)
    4905                                    (if-exists :rename-and-delete)
    4906                                    (if-does-not-exist :create)
    4907                                    buffer-size
    4908                                    linewise)
    4909     (with-output-file (output pathname
    4910                               :element-type element-type
    4911                               :external-format external-format
    4912                               :if-exists if-exists
    4913                               :if-does-not-exist if-does-not-exist)
    4914       (copy-stream-to-stream
    4915        input output
    4916        :element-type element-type :buffer-size buffer-size :linewise linewise)))
    4917 
    4918   (defmethod slurp-input-stream (x stream
    4919                                  &key linewise prefix (element-type 'character) buffer-size)
    4920     (declare (ignorable stream linewise prefix element-type buffer-size))
    4921     (cond
    4922       #+genera
    4923       ((functionp x) (funcall x stream))
    4924       #+genera
    4925       ((output-stream-p x)
    4926        (copy-stream-to-stream
    4927         stream x
    4928         :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    4929       (t
    4930        (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
    4931 
    4932 
    4933 (with-upgradability ()
    4934   (defgeneric vomit-output-stream (processor output-stream &key)
    4935     (:documentation
    4936      "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
    4937 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
    4938 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
    4939 
    4940 Built-in methods include the following:
    4941 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
    4942 * if PROCESSOR is a list, its first element should be a function.
    4943   It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
    4944   That is (x . y) will be treated as \(APPLY x <stream> y\)
    4945 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
    4946   per copy-stream-to-stream, with appropriate keyword arguments.
    4947 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
    4948 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
    4949 
    4950 Programmers are encouraged to define their own methods for this generic function."))
    4951 
    4952   #-genera
    4953   (defmethod vomit-output-stream ((function function) output-stream &key)
    4954     (funcall function output-stream))
    4955 
    4956   (defmethod vomit-output-stream ((list cons) output-stream &key)
    4957     (apply (first list) output-stream (rest list)))
    4958 
    4959   #-genera
    4960   (defmethod vomit-output-stream ((input-stream stream) output-stream
    4961                                  &key linewise prefix (element-type 'character) buffer-size)
    4962     (copy-stream-to-stream
    4963      input-stream output-stream
    4964      :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    4965 
    4966   (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
    4967     (princ x stream)
    4968     (when fresh-line (fresh-line stream))
    4969     (when terpri (terpri stream))
    4970     (values))
    4971 
    4972   (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    4973     (apply 'vomit-output-stream *standard-input* stream keys))
    4974 
    4975   (defmethod vomit-output-stream ((x null) (stream t) &key)
    4976     (values))
    4977 
    4978   (defmethod vomit-output-stream ((pathname pathname) input
    4979                                  &key
    4980                                    (element-type *default-stream-element-type*)
    4981                                    (external-format *utf-8-external-format*)
    4982                                    (if-exists :rename-and-delete)
    4983                                    (if-does-not-exist :create)
    4984                                    buffer-size
    4985                                    linewise)
    4986     (with-output-file (output pathname
    4987                               :element-type element-type
    4988                               :external-format external-format
    4989                               :if-exists if-exists
    4990                               :if-does-not-exist if-does-not-exist)
    4991       (copy-stream-to-stream
    4992        input output
    4993        :element-type element-type :buffer-size buffer-size :linewise linewise)))
    4994 
    4995   (defmethod vomit-output-stream (x stream
    4996                                  &key linewise prefix (element-type 'character) buffer-size)
    4997     (declare (ignorable stream linewise prefix element-type buffer-size))
    4998     (cond
    4999       #+genera
    5000       ((functionp x) (funcall x stream))
    5001       #+genera
    5002       ((input-stream-p x)
    5003        (copy-stream-to-stream
    5004         x stream
    5005         :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    5006       (t
    5007        (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
    5008 
    5009 
    5010 ;;;; ----- Running an external program -----
    5011 ;;; Simple variant of run-program with no input, and capturing output
    5012 ;;; On some implementations, may output to a temporary file...
    5013 (with-upgradability ()
    5014   (define-condition subprocess-error (error)
    5015     ((code :initform nil :initarg :code :reader subprocess-error-code)
    5016      (command :initform nil :initarg :command :reader subprocess-error-command)
    5017      (process :initform nil :initarg :process :reader subprocess-error-process))
    5018     (:report (lambda (condition stream)
    5019                (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
    5020                        (subprocess-error-process condition)
    5021                        (subprocess-error-command condition)
    5022                        (subprocess-error-code condition)))))
    5023 
    5024   ;;; find CMD.exe on windows
    5025   (defun %cmd-shell-pathname ()
    5026     (os-cond
    5027      ((os-windows-p)
    5028       (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
    5029               "System32\\cmd.exe"))
    5030      (t
    5031       (error "CMD.EXE is not the command shell for this OS."))))
    5032 
    5033   ;;; Internal helpers for run-program
    5034   (defun %normalize-command (command)
    5035     "Given a COMMAND as a list or string, transform it in a format suitable
    5036 for the implementation's underlying run-program function"
    5037     (etypecase command
    5038       #+os-unix (string `("/bin/sh" "-c" ,command))
    5039       #+os-unix (list command)
    5040       #+os-windows
    5041       (string
    5042        ;; NB: We do NOT add cmd /c here. You might want to.
    5043        #+(or allegro clisp) command
    5044        ;; On ClozureCL for Windows, we assume you are using
    5045        ;; r15398 or later in 1.9 or later,
    5046        ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    5047        #+clozure (cons "cmd" (strcat "/c " command))
    5048        #+mkcl (list "cmd" "/c" command)
    5049        #+sbcl (list (%cmd-shell-pathname) "/c" command)
    5050        ;; NB: On other Windows implementations, this is utterly bogus
    5051        ;; except in the most trivial cases where no quoting is needed.
    5052        ;; Use at your own risk.
    5053        #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
    5054       #+os-windows
    5055       (list
    5056        #+allegro (escape-windows-command command)
    5057        #-allegro command)))
    5058 
    5059   (defun %active-io-specifier-p (specifier)
    5060     "Determines whether a run-program I/O specifier requires Lisp-side processing
    5061 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
    5062 or whether it's already taken care of by the implementation's underlying run-program."
    5063     (not (typep specifier '(or null string pathname (member :interactive :output)
    5064                             #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
    5065                             #+lispworks file-stream))))
    5066 
    5067   (defun %normalize-io-specifier (specifier &optional role)
    5068     "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
    5069 argument to pass to the internal RUN-PROGRAM"
    5070     (declare (ignorable role))
    5071     (etypecase specifier
    5072       (null (or #+(or allegro lispworks) (null-device-pathname)))
    5073       (string (parse-native-namestring specifier))
    5074       (pathname specifier)
    5075       (stream specifier)
    5076       ((eql :stream) :stream)
    5077       ((eql :interactive)
    5078        #+allegro nil
    5079        #+clisp :terminal
    5080        #+(or clozure cmucl ecl mkcl sbcl scl) t)
    5081       #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    5082       ((eql :output)
    5083        (if (eq role :error-output)
    5084            :output
    5085            (error "Wrong specifier ~S for role ~S" specifier role)))))
    5086 
    5087   (defun %normalize-if-exists (action)
    5088     (ecase action
    5089       (:supersede #+clisp :overwrite #-clisp action)
    5090       ((:append :error) action)))
    5091 
    5092   (defun %interactivep (input output error-output)
    5093     (member :interactive (list input output error-output)))
    5094 
    5095   (defun %signal-to-exit-code (signum)
    5096     (+ 128 signum))
    5097 
    5098   #+mkcl
    5099   (defun %mkcl-signal-to-number (signal)
    5100     (require :mk-unix)
    5101     (symbol-value (find-symbol signal :mk-unix)))
    5102 
    5103   (defclass process-info ()
    5104     ((process :initform nil)
    5105      (input-stream :initform nil)
    5106      (output-stream :initform nil)
    5107      (bidir-stream :initform nil)
    5108      (error-output-stream :initform nil)
    5109      ;; For backward-compatibility, to maintain the property (zerop
    5110      ;; exit-code) <-> success, an exit in response to a signal is
    5111      ;; encoded as 128+signum.
    5112      (exit-code :initform nil)
    5113      ;; If the platform allows it, distinguish exiting with a code
    5114      ;; >128 from exiting in response to a signal by setting this code
    5115      (signal-code :initform nil)))
    5116 
    5117   (defun %run-program (command
    5118                        &rest keys
    5119                        &key input (if-input-does-not-exist :error)
    5120                          output (if-output-exists :supersede)
    5121                          error-output (if-error-output-exists :supersede)
    5122                          directory wait
    5123                          #+allegro separate-streams
    5124                          &allow-other-keys)
    5125     "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
    5126 It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
    5127 INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
    5128 to be normalized by %NORMALIZE-IO-SPECIFIER.
    5129 It returns a process-info object."
    5130     ;; NB: these implementations have Unix vs Windows set at compile-time.
    5131     (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
    5132     #-(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    5133     (progn command keys input output error-output directory wait ;; ignore
    5134            (not-implemented-error '%run-program))
    5135     #-(or abcl cmucl ecl mkcl sbcl)
    5136     (when (and wait (member :stream (list input output error-output)))
    5137       (parameter-error "~S: I/O parameters cannot be ~S when ~S is ~S on this lisp"
    5138                        '%run-program :stream :wait t))
    5139     #+allegro
    5140     (when (some #'(lambda (stream)
    5141                     (and (streamp stream)
    5142                          (not (file-stream-p stream))))
    5143                 (list input output error-output))
    5144       (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
    5145                        '%run-program))
    5146     #+(or abcl clisp lispworks)
    5147     (when (some #'streamp (list input output error-output))
    5148       (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
    5149                        '%run-program))
    5150     #+clisp
    5151     (unless (eq error-output :interactive)
    5152       (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
    5153                        '%run-program :error-output :interactive))
    5154     #+clisp
    5155     (when (or (stringp input) (pathnamep input))
    5156       (unless (file-exists-p input)
    5157         (parameter-error "~S: Files passed as arguments to ~S need to exist on this lisp"
    5158                          '%run-program :input)))
    5159     #+ecl
    5160     (when (some #'(lambda (stream)
    5161                     (and (streamp stream)
    5162                          (not (file-or-synonym-stream-p stream))))
    5163                 (list input output error-output))
    5164       (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
    5165                        '%run-program))
    5166     #+(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    5167     (let* ((%command (%normalize-command command))
    5168            (%if-output-exists (%normalize-if-exists if-output-exists))
    5169            (%input (%normalize-io-specifier input :input))
    5170            (%output (%normalize-io-specifier output :output))
    5171            (%error-output (%normalize-io-specifier error-output :error-output))
    5172            #+(and allegro os-windows)
    5173            (interactive (%interactivep input output error-output))
    5174            (process*
    5175              (nest
    5176               #-(or allegro mkcl sbcl) (with-current-directory (directory))
    5177               #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list)
    5178               (apply
    5179                #+abcl #'sys:run-program
    5180                #+allegro 'excl:run-shell-command
    5181                #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
    5182                #+(and allegro os-windows) %command
    5183                #+clisp
    5184                (etypecase %command
    5185                  #+os-windows
    5186                  (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys)))
    5187                  (list (lambda (&rest keys)
    5188                          (apply 'ext:run-program (car %command) :arguments (cdr %command) keys))))
    5189                #+clozure 'ccl:run-program
    5190                #+(or cmucl ecl scl) 'ext:run-program
    5191                #+lispworks 'system:run-shell-command
    5192                #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
    5193                #+mkcl 'mk-ext:run-program
    5194                #+sbcl 'sb-ext:run-program
    5195                (append
    5196                 #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
    5197                 `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t)
    5198                 #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
    5199                             ,%error-output)
    5200                 #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
    5201                 #+clisp `(:if-output-exists ,%if-output-exists)
    5202                 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    5203                 `(:if-input-does-not-exist ,if-input-does-not-exist
    5204                   :if-output-exists ,%if-output-exists
    5205                   #-(or allegro lispworks) :if-error-exists
    5206                   #+(or allegro lispworks) :if-error-output-exists
    5207                   ,if-error-output-exists)
    5208                 #+lispworks `(:save-exit-status t)
    5209                 #+mkcl `(:directory ,(native-namestring directory))
    5210                 #+sbcl `(:search t)
    5211                 #-sbcl keys
    5212                 #+sbcl (if directory keys (remove-plist-key :directory keys))))))
    5213            (process-info (make-instance 'process-info)))
    5214       #+clisp (declare (ignore %error-output))
    5215       (labels ((prop (key value) (setf (slot-value process-info key) value))
    5216                #+(or allegro clisp ecl lispworks mkcl)
    5217                (store-codes (exit-code &optional signal-code)
    5218                  (if signal-code
    5219                      (progn (prop 'exit-code (%signal-to-exit-code signal-code))
    5220                             (prop 'signal-code signal-code))
    5221                      (prop 'exit-code exit-code))))
    5222         #+allegro
    5223         (cond
    5224           (wait (store-codes (first process*)))
    5225           (separate-streams
    5226            (destructuring-bind (in out err pid) process*
    5227              (prop 'process pid)
    5228              (when (eq input :stream) (prop 'input-stream in))
    5229              (when (eq output :stream) (prop 'output-stream out))
    5230              (when (eq error-output :stream) (prop 'error-stream err))))
    5231           (t
    5232            (prop 'process (third process*))
    5233            (let ((x (first process*)))
    5234              (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
    5235                (0)
    5236                (1 (prop 'input-stream x))
    5237                (2 (prop 'output-stream x))
    5238                (3 (prop 'bidir-stream x))))
    5239            (when (eq error-output :stream)
    5240              (prop 'error-stream (second process*)))))
    5241         #+clisp
    5242         (if wait
    5243             (let ((raw-exit-code (or (first process*) 0)))
    5244               (if (minusp raw-exit-code)
    5245                   (store-codes 0 (- raw-exit-code))
    5246                   (store-codes raw-exit-code)))
    5247             (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
    5248               (0)
    5249               (1 (prop 'input-stream (first process*)))
    5250               (2 (prop 'output-stream (first process*)))
    5251               (3 (prop 'bidir-stream (pop process*))
    5252                  (prop 'input-stream (pop process*))
    5253                  (prop 'output-stream (pop process*)))))
    5254         #+(or abcl clozure cmucl sbcl scl)
    5255         (progn
    5256           (prop 'process process*)
    5257           (when (eq input :stream)
    5258             (prop 'input-stream
    5259                   #+abcl (symbol-call :sys :process-input process*)
    5260                   #+clozure (ccl:external-process-input-stream process*)
    5261                   #+(or cmucl scl) (ext:process-input process*)
    5262                   #+sbcl (sb-ext:process-input process*)))
    5263           (when (eq output :stream)
    5264             (prop 'output-stream
    5265                   #+abcl (symbol-call :sys :process-output process*)
    5266                   #+clozure (ccl:external-process-output-stream process*)
    5267                   #+(or cmucl scl) (ext:process-output process*)
    5268                   #+sbcl (sb-ext:process-output process*)))
    5269           (when (eq error-output :stream)
    5270             (prop 'error-output-stream
    5271                   #+abcl (symbol-call :sys :process-error process*)
    5272                   #+clozure (ccl:external-process-error-stream process*)
    5273                   #+(or cmucl scl) (ext:process-error process*)
    5274                   #+sbcl (sb-ext:process-error process*))))
    5275         #+(or ecl mkcl)
    5276         (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
    5277           (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    5278             (cond
    5279               ((zerop mode))
    5280               ((null process*) (store-codes -1))
    5281               (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
    5282           (when code
    5283             (let ((signum #+mkcl (and (stringp code) (%mkcl-signal-to-number code))
    5284                           #-mkcl (and (eq (ext:external-process-wait process)
    5285                                           :signaled)
    5286                                       code)))
    5287               (store-codes code signum)))
    5288           (when process (prop 'process process)))
    5289         #+lispworks
    5290         (if wait
    5291             (store-codes (first process*) (second process*))
    5292             (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    5293               (if (or (plusp mode) (eq error-output :stream))
    5294                   (destructuring-bind (io err pid) process*
    5295                     #+lispworks7+ (declare (ignore pid))
    5296                     (prop 'process #+lispworks7+ io #-lispworks7+ pid)
    5297                     (when (plusp mode)
    5298                       (prop (ecase mode
    5299                               (1 'input-stream)
    5300                               (2 'output-stream)
    5301                               (3 'bidir-stream)) io))
    5302                     (when (eq error-output :stream)
    5303                       (prop 'error-stream err)))
    5304                   ;; lispworks6 returns (pid), lispworks7 returns (io,err,pid).
    5305                   (prop 'process (first process*)))))
    5306         process-info)))
    5307 
    5308   (defun process-info-error-output (process-info)
    5309     (slot-value process-info 'error-output-stream))
    5310   (defun process-info-input (process-info)
    5311     (or (slot-value process-info 'bidir-stream)
    5312         (slot-value process-info 'input-stream)))
    5313   (defun process-info-output (process-info)
    5314     (or (slot-value process-info 'bidir-stream)
    5315         (slot-value process-info 'output-stream)))
    5316 
    5317   (defun process-info-pid (process-info)
    5318     (let ((process (slot-value process-info 'process)))
    5319       (declare (ignorable process))
    5320       #+abcl (symbol-call :sys :process-pid process)
    5321       #+allegro process
    5322       #+clozure (ccl:external-process-id process)
    5323       #+ecl (ext:external-process-pid process)
    5324       #+(or cmucl scl) (ext:process-pid process)
    5325       #+lispworks7+ (sys:pipe-pid process)
    5326       #+(and lispworks (not lispworks7+)) process
    5327       #+mkcl (mkcl:process-id process)
    5328       #+sbcl (sb-ext:process-pid process)
    5329       #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
    5330       (not-implemented-error 'process-info-pid)))
    5331 
    5332   (defun %process-status (process-info)
    5333     (if-let (exit-code (slot-value process-info 'exit-code))
    5334       (return-from %process-status
    5335         (if-let (signal-code (slot-value process-info 'signal-code))
    5336           (values :signaled signal-code)
    5337           (values :exited exit-code))))
    5338     #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    5339     (not-implemented-error '%process-status)
    5340     (if-let (process (slot-value process-info 'process))
    5341       (multiple-value-bind (status code)
    5342           (progn
    5343             #+allegro (multiple-value-bind (exit-code pid signal)
    5344                           (sys:reap-os-subprocess :pid process :wait nil)
    5345                         (assert pid)
    5346                         (cond ((null exit-code) :running)
    5347                               ((null signal) (values :exited exit-code))
    5348                               (t (values :signaled signal))))
    5349             #+clozure (ccl:external-process-status process)
    5350             #+(or cmucl scl) (let ((status (ext:process-status process)))
    5351                                (values status (if (member status '(:exited :signaled))
    5352                                                   (ext:process-exit-code process))))
    5353             #+ecl (ext:external-process-status process)
    5354             #+lispworks
    5355             ;; a signal is only returned on LispWorks 7+
    5356             (multiple-value-bind (exit-code signal)
    5357                 (funcall #+lispworks7+ #'sys:pipe-exit-status
    5358                          #-lispworks7+ #'sys:pid-exit-status
    5359                          process :wait nil)
    5360               (cond ((null exit-code) :running)
    5361                     ((null signal) (values :exited exit-code))
    5362                     (t (values :signaled signal))))
    5363             #+mkcl (let ((status (mk-ext:process-status process))
    5364                          (code (mk-ext:process-exit-code process)))
    5365                      (if (stringp code)
    5366                          (values :signaled (%mkcl-signal-to-number code))
    5367                          (values status code)))
    5368             #+sbcl (let ((status (sb-ext:process-status process)))
    5369                      (values status (if (member status '(:exited :signaled))
    5370                                         (sb-ext:process-exit-code process)))))
    5371         (case status
    5372           (:exited (setf (slot-value process-info 'exit-code) code))
    5373           (:signaled (let ((%code (%signal-to-exit-code code)))
    5374                        (setf (slot-value process-info 'exit-code) %code
    5375                              (slot-value process-info 'signal-code) code))))
    5376         (values status code))))
    5377 
    5378   (defun process-alive-p (process-info)
    5379     "Check if a process has yet to exit."
    5380     (unless (slot-value process-info 'exit-code)
    5381       #+abcl (sys:process-alive-p (slot-value process-info 'process))
    5382       #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
    5383       #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
    5384       #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
    5385                                          '(:running :sleeping))))
    5386 
    5387   (defun wait-process (process-info)
    5388     "Wait for the process to terminate, if it is still running.
    5389 Otherwise, return immediately. An exit code (a number) will be
    5390 returned, with 0 indicating success, and anything else indicating
    5391 failure. If the process exits after receiving a signal, the exit code
    5392 will be the sum of 128 and the (positive) numeric signal code. A second
    5393 value may be returned in this case: the numeric signal code itself.
    5394 Any asynchronously spawned process requires this function to be run
    5395 before it is garbage-collected in order to free up resources that
    5396 might otherwise be irrevocably lost."
    5397     (if-let (exit-code (slot-value process-info 'exit-code))
    5398       (if-let (signal-code (slot-value process-info 'signal-code))
    5399         (values exit-code signal-code)
    5400         exit-code)
    5401       (let ((process (slot-value process-info 'process)))
    5402         #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    5403         (not-implemented-error 'wait-process)
    5404         (when process
    5405           ;; 1- wait
    5406           #+clozure (ccl::external-process-wait process)
    5407           #+(or cmucl scl) (ext:process-wait process)
    5408           #+sbcl (sb-ext:process-wait process)
    5409           ;; 2- extract result
    5410           (multiple-value-bind (exit-code signal-code)
    5411               (progn
    5412                 #+abcl (sys:process-wait process)
    5413                 #+allegro (multiple-value-bind (exit-code pid signal)
    5414                               (sys:reap-os-subprocess :pid process :wait t)
    5415                             (assert pid)
    5416                             (values exit-code signal))
    5417                 #+clozure (multiple-value-bind (status code)
    5418                               (ccl:external-process-status process)
    5419                             (if (eq status :signaled)
    5420                                 (values nil code)
    5421                                 code))
    5422                 #+(or cmucl scl) (let ((status (ext:process-status process))
    5423                                        (code (ext:process-exit-code process)))
    5424                                    (if (eq status :signaled)
    5425                                        (values nil code)
    5426                                        code))
    5427                 #+ecl (multiple-value-bind (status code)
    5428                           (ext:external-process-wait process t)
    5429                         (if (eq status :signaled)
    5430                             (values nil code)
    5431                             code))
    5432                 #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
    5433                                      #-lispworks7+ #'sys:pid-exit-status
    5434                                      process :wait t)
    5435                 #+mkcl (let ((code (mkcl:join-process process)))
    5436                          (if (stringp code)
    5437                              (values nil (%mkcl-signal-to-number code))
    5438                              code))
    5439                 #+sbcl (let ((status (sb-ext:process-status process))
    5440                              (code (sb-ext:process-exit-code process)))
    5441                          (if (eq status :signaled)
    5442                              (values nil code)
    5443                              code)))
    5444             (if signal-code
    5445                 (let ((%exit-code (%signal-to-exit-code signal-code)))
    5446                   (setf (slot-value process-info 'exit-code) %exit-code
    5447                         (slot-value process-info 'signal-code) signal-code)
    5448                   (values %exit-code signal-code))
    5449                 (progn (setf (slot-value process-info 'exit-code) exit-code)
    5450                        exit-code)))))))
    5451 
    5452   (defun %check-result (exit-code &key command process ignore-error-status)
    5453     (unless ignore-error-status
    5454       (unless (eql exit-code 0)
    5455         (cerror "IGNORE-ERROR-STATUS"
    5456                 'subprocess-error :command command :code exit-code :process process)))
    5457     exit-code)
    5458 
    5459   (defun close-streams (process-info)
    5460     "Close any stream that the process might own. Needs to be run
    5461 whenever streams were requested by passing :stream to :input, :output,
    5462 or :error-output."
    5463     (dolist (stream
    5464               (cons (slot-value process-info 'error-output-stream)
    5465                     (if-let (bidir-stream (slot-value process-info 'bidir-stream))
    5466                       (list bidir-stream)
    5467                       (list (slot-value process-info 'input-stream)
    5468                             (slot-value process-info 'output-stream)))))
    5469       (when stream (close stream))))
    5470 
    5471   ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
    5472   ;; do what you expect it to. Sending SIGSTOP to a process spawned
    5473   ;; via %run-program, e.g., will stop the shell /bin/sh that is used
    5474   ;; to run the command (via `sh -c command`) but not the actual
    5475   ;; command.
    5476   #+os-unix
    5477   (defun %posix-send-signal (process-info signal)
    5478     #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
    5479     #+clozure (ccl:signal-external-process (slot-value process-info 'process)
    5480                                            signal :error-if-exited nil)
    5481     #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
    5482     #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
    5483     #-(or allegro clozure cmucl sbcl scl)
    5484     (if-let (pid (process-info-pid process-info))
    5485       (%run-program (format nil "kill -~a ~a" signal pid) :wait t)))
    5486 
    5487   ;;; this function never gets called on Windows, but the compiler cannot tell
    5488   ;;; that. [2016/09/25:rpg]
    5489   #+os-windows
    5490   (defun %posix-send-signal (process-info signal)
    5491     (declare (ignore process-info signal))
    5492     (values))
    5493 
    5494   (defun terminate-process (process-info &key urgent)
    5495     "Cause the process to exit. To that end, the process may or may
    5496 not be sent a signal, which it will find harder (or even impossible)
    5497 to ignore if URGENT is T. On some platforms, it may also be subject to
    5498 race conditions."
    5499     (declare (ignorable urgent))
    5500     #+abcl (sys:process-kill (slot-value process-info 'process))
    5501     #+ecl (symbol-call :ext :terminate-process
    5502                        (slot-value process-info 'process) urgent)
    5503     #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
    5504     #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
    5505                                      :force urgent)
    5506     #-(or abcl ecl lispworks7+ mkcl)
    5507     (os-cond
    5508      ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
    5509      ((os-windows-p) (if-let (pid (process-info-pid process-info))
    5510                        (%run-program (format nil "taskkill ~a /pid ~a"
    5511                                              (if urgent "/f" "") pid))))
    5512      (t (not-implemented-error 'terminate-process))))
    5513 
    5514   (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
    5515                                 &key element-type external-format &allow-other-keys)
    5516     ;; handle redirection for run-program and system
    5517     ;; SPEC is the specification for the subprocess's input or output or error-output
    5518     ;; TVAL is the value used if the spec is T
    5519     ;; GF is the generic function to call to handle arbitrary values of SPEC
    5520     ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
    5521     ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
    5522     ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
    5523     ;; FUN is a function of the new reduced spec and an activity function to call with a stream
    5524     ;; when the subprocess is active and communicating through that stream.
    5525     ;; ACTIVEP is a boolean true if we will get to run code while the process is running
    5526     ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
    5527     ;; RETURNER is a function called with the value of the activity.
    5528     ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
    5529     (declare (ignorable stream-easy-p))
    5530     (let* ((actual-spec (if (eq spec t) tval spec))
    5531            (activity-spec (if (eq actual-spec :output)
    5532                               (ecase direction
    5533                                 ((:input :output)
    5534                                  (error "~S not allowed as a ~S ~S spec"
    5535                                         :output 'run-program direction))
    5536                                 ((:error-output)
    5537                                  nil))
    5538                               actual-spec)))
    5539       (labels ((activity (stream)
    5540                  (call-function returner (call-stream-processor gf activity-spec stream)))
    5541                (easy-case ()
    5542                  (funcall fun actual-spec nil))
    5543                (hard-case ()
    5544                  (if activep
    5545                      (funcall fun :stream #'activity)
    5546                      (with-temporary-file (:pathname tmp)
    5547                        (ecase direction
    5548                          (:input
    5549                           (with-output-file (s tmp :if-exists :overwrite
    5550                                                :external-format external-format
    5551                                                :element-type element-type)
    5552                             (activity s))
    5553                           (funcall fun tmp nil))
    5554                          ((:output :error-output)
    5555                           (multiple-value-prog1 (funcall fun tmp nil)
    5556                             (with-input-file (s tmp
    5557                                                :external-format external-format
    5558                                                :element-type element-type)
    5559                               (activity s)))))))))
    5560         (typecase activity-spec
    5561           ((or null string pathname (eql :interactive))
    5562            (easy-case))
    5563           #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
    5564           (stream
    5565            (if stream-easy-p (easy-case) (hard-case)))
    5566           (t
    5567            (hard-case))))))
    5568 
    5569   (defmacro place-setter (place)
    5570     (when place
    5571       (let ((value (gensym)))
    5572         `#'(lambda (,value) (setf ,place ,value)))))
    5573 
    5574   (defmacro with-program-input (((reduced-input-var
    5575                                   &optional (input-activity-var (gensym) iavp))
    5576                                  input-form &key setf stream-easy-p active keys) &body body)
    5577     `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
    5578             #'(lambda (,reduced-input-var ,input-activity-var)
    5579                 ,@(unless iavp `((declare (ignore ,input-activity-var))))
    5580                 ,@body)
    5581             :input ,input-form ,active (place-setter ,setf) ,keys))
    5582 
    5583   (defmacro with-program-output (((reduced-output-var
    5584                                   &optional (output-activity-var (gensym) oavp))
    5585                                   output-form &key setf stream-easy-p active keys) &body body)
    5586     `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
    5587             #'(lambda (,reduced-output-var ,output-activity-var)
    5588                 ,@(unless oavp `((declare (ignore ,output-activity-var))))
    5589                 ,@body)
    5590             :output ,output-form ,active (place-setter ,setf) ,keys))
    5591 
    5592   (defmacro with-program-error-output (((reduced-error-output-var
    5593                                          &optional (error-output-activity-var (gensym) eoavp))
    5594                                         error-output-form &key setf stream-easy-p active keys)
    5595                                        &body body)
    5596     `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
    5597             #'(lambda (,reduced-error-output-var ,error-output-activity-var)
    5598                 ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
    5599                 ,@body)
    5600             :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
    5601 
    5602   (defun %use-run-program (command &rest keys
    5603                            &key input output error-output ignore-error-status &allow-other-keys)
    5604     ;; helper for RUN-PROGRAM when using %run-program
    5605     #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
    5606     (progn
    5607       command keys input output error-output ignore-error-status ;; ignore
    5608       (not-implemented-error '%use-run-program))
    5609     (assert (not (member :stream (list input output error-output))))
    5610     (let* ((active-input-p (%active-io-specifier-p input))
    5611            (active-output-p (%active-io-specifier-p output))
    5612            (active-error-output-p (%active-io-specifier-p error-output))
    5613            (activity
    5614              (cond
    5615                (active-output-p :output)
    5616                (active-input-p :input)
    5617                (active-error-output-p :error-output)
    5618                (t nil)))
    5619            (wait (not activity))
    5620            output-result error-output-result exit-code process-info)
    5621       (with-program-output ((reduced-output output-activity)
    5622                             output :keys keys :setf output-result
    5623                             :stream-easy-p t :active (eq activity :output))
    5624         (with-program-error-output ((reduced-error-output error-output-activity)
    5625                                     error-output :keys keys :setf error-output-result
    5626                                     :stream-easy-p t :active (eq activity :error-output))
    5627           (with-program-input ((reduced-input input-activity)
    5628                                input :keys keys
    5629                                :stream-easy-p t :active (eq activity :input))
    5630             (setf process-info
    5631                   (apply '%run-program command
    5632                          :wait wait :input reduced-input :output reduced-output
    5633                          :error-output (if (eq error-output :output) :output reduced-error-output)
    5634                          keys))
    5635             (labels ((get-stream (stream-name &optional fallbackp)
    5636                        (or (slot-value process-info stream-name)
    5637                            (when fallbackp
    5638                              (slot-value process-info 'bidir-stream))))
    5639                      (run-activity (activity stream-name &optional fallbackp)
    5640                        (if-let (stream (get-stream stream-name fallbackp))
    5641                          (funcall activity stream)
    5642                          (error 'subprocess-error
    5643                                 :code `(:missing ,stream-name)
    5644                                 :command command :process process-info))))
    5645               (unwind-protect
    5646                    (ecase activity
    5647                      ((nil))
    5648                      (:input (run-activity input-activity 'input-stream t))
    5649                      (:output (run-activity output-activity 'output-stream t))
    5650                      (:error-output (run-activity error-output-activity 'error-output-stream)))
    5651                 (close-streams process-info)
    5652                 (setf exit-code (wait-process process-info)))))))
    5653       (%check-result exit-code
    5654                      :command command :process process-info
    5655                      :ignore-error-status ignore-error-status)
    5656       (values output-result error-output-result exit-code)))
    5657 
    5658   (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
    5659     (etypecase command
    5660       (string
    5661        (os-cond
    5662         ((os-windows-p)
    5663          #+(or allegro clisp)
    5664          (strcat (%cmd-shell-pathname) " /c " command)
    5665          #-(or allegro clisp) command)
    5666         (t command)))
    5667       (list (escape-shell-command
    5668              (os-cond
    5669               ((os-unix-p) (cons "exec" command))
    5670               ((os-windows-p)
    5671                #+(or allegro sbcl clisp)
    5672                (cons (%cmd-shell-pathname) (cons "/c" command))
    5673                #-(or allegro sbcl clisp) command)
    5674               (t command))))))
    5675 
    5676   (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
    5677     (flet ((redirect (spec operator)
    5678              (let ((pathname
    5679                      (typecase spec
    5680                        (null (null-device-pathname))
    5681                        (string (parse-native-namestring spec))
    5682                        (pathname spec)
    5683                        ((eql :output)
    5684                         (assert (equal operator " 2>"))
    5685                         (return-from redirect '(" 2>&1"))))))
    5686                (when pathname
    5687                  (list operator " "
    5688                        (escape-shell-token (native-namestring pathname)))))))
    5689       (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
    5690              (normalized (%normalize-system-command command))
    5691              (directory (or directory #+(or abcl xcl) (getcwd)))
    5692              (chdir (when directory
    5693                       (let ((dir-arg (escape-shell-token (native-namestring directory))))
    5694                         (os-cond
    5695                          ((os-unix-p) `("cd " ,dir-arg " ; "))
    5696                          ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
    5697         (reduce/strcat
    5698          (os-cond
    5699           ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
    5700           ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
    5701 
    5702   (defun %system (command &rest keys
    5703                   &key input output error-output directory &allow-other-keys)
    5704     "A portable abstraction of a low-level call to libc's system()."
    5705     (declare (ignorable input output error-output directory keys))
    5706     #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
    5707     (wait-process
    5708      (apply '%run-program (%normalize-system-command command) :wait t keys))
    5709     #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
    5710     (let ((%command (%redirected-system-command command input output error-output directory)))
    5711       #+(and lispworks os-windows)
    5712       (system:call-system %command :current-directory directory :wait t)
    5713       #+clisp
    5714       (wait-process
    5715        (apply '%run-program %command :wait t
    5716               :input :interactive :output :interactive :error-output :interactive keys))
    5717       #-(or clisp (and lispworks os-windows))
    5718       (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
    5719         #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated
    5720         #+cormanlisp (win32:system %command)
    5721         #+(or clasp ecl) (let ((*standard-input* *stdin*)
    5722                     (*standard-output* *stdout*)
    5723                     (*error-output* *stderr*))
    5724                 (ext:system %command))
    5725         #+gcl (system:system %command)
    5726         #+genera (not-implemented-error '%system)
    5727         #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
    5728         #+mkcl (mkcl:system %command)
    5729         #+xcl (system:%run-shell-command %command))))
    5730 
    5731   (defun %use-system (command &rest keys
    5732                       &key input output error-output ignore-error-status &allow-other-keys)
    5733     ;; helper for RUN-PROGRAM when using %system
    5734     (let (output-result error-output-result exit-code)
    5735       (with-program-output ((reduced-output)
    5736                             output :keys keys :setf output-result)
    5737         (with-program-error-output ((reduced-error-output)
    5738                                     error-output :keys keys :setf error-output-result)
    5739           (with-program-input ((reduced-input) input :keys keys)
    5740             (setf exit-code (apply '%system command
    5741                                    :input reduced-input :output reduced-output
    5742                                    :error-output reduced-error-output keys)))))
    5743       (%check-result exit-code
    5744                      :command command
    5745                      :ignore-error-status ignore-error-status)
    5746       (values output-result error-output-result exit-code)))
    5747 
    5748   (defun launch-program (command &rest keys &key
    5749                                               input (if-input-does-not-exist :error)
    5750                                               output (if-output-exists :supersede)
    5751                                               error-output (if-error-output-exists :supersede)
    5752                                               (element-type #-clozure *default-stream-element-type*
    5753                                                             #+clozure 'character)
    5754                                               (external-format *utf-8-external-format*)
    5755                                               &allow-other-keys)
    5756     "Launch program specified by COMMAND,
    5757 either a list of strings specifying a program and list of arguments,
    5758 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
    5759 Windows) _asynchronously_.
    5760 
    5761 If OUTPUT is a pathname, a string designating a pathname, or NIL
    5762 designating the null device, the file at that path is used as output.
    5763 If it's :INTERACTIVE, output is inherited from the current process;
    5764 beware that this may be different from your *STANDARD-OUTPUT*, and
    5765 under SLIME will be on your *inferior-lisp* buffer.  If it's T, output
    5766 goes to your current *STANDARD-OUTPUT* stream.  If it's :STREAM, a new
    5767 stream will be made available that can be accessed via
    5768 PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
    5769 that the underlying lisp implementation knows how to handle.
    5770 
    5771 ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
    5772 :OUTPUT means redirecting the error output to the output stream,
    5773 and :STREAM causes a stream to be made available via
    5774 PROCESS-INFO-ERROR-OUTPUT.
    5775 
    5776 INPUT is similar to OUTPUT, except that T designates the
    5777 *STANDARD-INPUT* and a stream requested through the :STREAM keyword
    5778 would be available through PROCESS-INFO-INPUT.
    5779 
    5780 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
    5781 implementation, when applicable, for creation of the output stream.
    5782 
    5783 LAUNCH-PROGRAM returns a process-info object."
    5784     (apply '%run-program command
    5785            :wait nil
    5786            :input input :if-input-does-not-exist if-input-does-not-exist
    5787            :output output :if-output-exists if-output-exists
    5788            :error-output error-output :if-error-output-exists if-error-output-exists
    5789            :element-type element-type :external-format external-format
    5790            keys))
    5791 
    5792   (defun run-program (command &rest keys
    5793                        &key ignore-error-status (force-shell nil force-shell-suppliedp)
    5794                          (input nil inputp) (if-input-does-not-exist :error)
    5795                          output (if-output-exists :supersede)
    5796                          (error-output nil error-output-p) (if-error-output-exists :supersede)
    5797                          (element-type #-clozure *default-stream-element-type* #+clozure 'character)
    5798                          (external-format *utf-8-external-format*)
    5799                       &allow-other-keys)
    5800     "Run program specified by COMMAND,
    5801 either a list of strings specifying a program and list of arguments,
    5802 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
    5803 _synchronously_ process its output as specified and return the processing results
    5804 when the program and its output processing are complete.
    5805 
    5806 Always call a shell (rather than directly execute the command when possible)
    5807 if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
    5808 specified to be NIL.
    5809 
    5810 Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
    5811 unless IGNORE-ERROR-STATUS is specified.
    5812 
    5813 If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
    5814 the file at that path is used as output.
    5815 If it's :INTERACTIVE, output is inherited from the current process;
    5816 beware that this may be different from your *STANDARD-OUTPUT*,
    5817 and under SLIME will be on your *inferior-lisp* buffer.
    5818 If it's T, output goes to your current *STANDARD-OUTPUT* stream.
    5819 Otherwise, OUTPUT should be a value that is a suitable first argument to
    5820 SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
    5821 In this case, RUN-PROGRAM will create a temporary stream for the program output;
    5822 the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
    5823 using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
    5824 The primary value resulting from that call (or NIL if no call was needed)
    5825 will be the first value returned by RUN-PROGRAM.
    5826 E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
    5827 And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
    5828 stripped of any ending newline.
    5829 
    5830 ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
    5831 as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
    5832 Also :OUTPUT means redirecting the error output to the output stream,
    5833 in which case NIL is returned.
    5834 
    5835 INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
    5836 no value is returned, and T designates the *STANDARD-INPUT*.
    5837 
    5838 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
    5839 to your Lisp implementation, when applicable, for creation of the output stream.
    5840 
    5841 One and only one of the stream slurping or vomiting may or may not happen
    5842 in parallel in parallel with the subprocess,
    5843 depending on options and implementation,
    5844 and with priority being given to output processing.
    5845 Other streams are completely produced or consumed
    5846 before or after the subprocess is spawned, using temporary files.
    5847 
    5848 RUN-PROGRAM returns 3 values:
    5849 0- the result of the OUTPUT slurping if any, or NIL
    5850 1- the result of the ERROR-OUTPUT slurping if any, or NIL
    5851 2- either 0 if the subprocess exited with success status,
    5852 or an indication of failure via the EXIT-CODE of the process"
    5853     (declare (ignorable ignore-error-status))
    5854     #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    5855     (not-implemented-error 'run-program)
    5856     ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
    5857     ;; don't override user's specified preference. [2015/06/29:rpg]
    5858     (when (stringp command)
    5859       (unless force-shell-suppliedp
    5860         #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16
    5861         (setf force-shell t)))
    5862     (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
    5863       (apply (if (or force-shell
    5864                      #+(or clasp clisp) t
    5865                      ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
    5866                      #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
    5867                                (lexicographic<= '< ver '(16 0 1)))
    5868                      #+(and lispworks os-unix) (%interactivep input output error-output)
    5869                      #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
    5870                  '%use-system '%use-run-program)
    5871              command
    5872              :input (default input inputp output)
    5873              :error-output (default error-output error-output-p output)
    5874              :if-input-does-not-exist if-input-does-not-exist
    5875              :if-output-exists if-output-exists
    5876              :if-error-output-exists if-error-output-exists
    5877              :element-type element-type :external-format external-format
    5878              keys))))
    58794664;;;; -------------------------------------------------------------------------
    58804665;;;; Support to build (compile and load) Lisp files
     
    59454730                    ccl::*nx-debug* ccl::*nx-cspeed*)
    59464731        #+(or cmucl scl) '(c::*default-cookie*)
    5947         #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
    59484732        #+clasp '()
     4733        #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
    59494734        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
    59504735        #+lispworks '(compiler::*optimization-level*)
     
    66745459        (loop :for f :in fasls :do (ignore-errors (delete-file f)))
    66755460        (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
     5461;;;; -------------------------------------------------------------------------
     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.
     5466  (:use :uiop/common-lisp :uiop/package :uiop/utility
     5467   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
     5468  (:export
     5469   ;;; Escaping the command invocation madness
     5470   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
     5471   #:escape-windows-token #:escape-windows-command
     5472   #:escape-token #:escape-command
     5473
     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)
     5484
     5485;;;; ----- Escaping strings for the shell -----
     5486
     5487(with-upgradability ()
     5488  (defun requires-escaping-p (token &key good-chars bad-chars)
     5489    "Does this token require escaping, given the specification of
     5490either good chars that don't need escaping or bad chars that do need escaping,
     5491as either a recognizing function or a sequence of characters."
     5492    (some
     5493     (cond
     5494       ((and good-chars bad-chars)
     5495        (error "only one of good-chars and bad-chars can be provided"))
     5496       ((typep good-chars 'function)
     5497        (complement good-chars))
     5498       ((typep bad-chars 'function)
     5499        bad-chars)
     5500       ((and good-chars (typep good-chars 'sequence))
     5501        #'(lambda (c) (not (find c good-chars))))
     5502       ((and bad-chars (typep bad-chars 'sequence))
     5503        #'(lambda (c) (find c bad-chars)))
     5504       (t (error "requires-escaping-p: no good-char criterion")))
     5505     token))
     5506
     5507  (defun escape-token (token &key stream quote good-chars bad-chars escaper)
     5508    "Call the ESCAPER function on TOKEN string if it needs escaping as per
     5509REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
     5510using STREAM as output (or returning result as a string if NIL)"
     5511    (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
     5512        (with-output (stream)
     5513          (apply escaper token stream (when quote `(:quote ,quote))))
     5514        (output-string token stream)))
     5515
     5516  (defun escape-windows-token-within-double-quotes (x &optional s)
     5517    "Escape a string token X within double-quotes
     5518for use within a MS Windows command-line, outputing to S."
     5519    (labels ((issue (c) (princ c s))
     5520             (issue-backslash (n) (loop :repeat n :do (issue #\\))))
     5521      (loop
     5522        :initially (issue #\") :finally (issue #\")
     5523        :with l = (length x) :with i = 0
     5524        :for i+1 = (1+ i) :while (< i l) :do
     5525          (case (char x i)
     5526            ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
     5527            ((#\\)
     5528             (let* ((j (and (< i+1 l) (position-if-not
     5529                                       #'(lambda (c) (eql c #\\)) x :start i+1)))
     5530                    (n (- (or j l) i)))
     5531               (cond
     5532                 ((null j)
     5533                  (issue-backslash (* 2 n)) (setf i l))
     5534                 ((and (< j l) (eql (char x j) #\"))
     5535                  (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
     5536                 (t
     5537                  (issue-backslash n) (setf i j)))))
     5538            (otherwise
     5539             (issue (char x i)) (setf i i+1))))))
     5540
     5541  (defun easy-windows-character-p (x)
     5542    "Is X an \"easy\" character that does not require quoting by the shell?"
     5543    (or (alphanumericp x) (find x "+-_.,@:/=")))
     5544
     5545  (defun escape-windows-token (token &optional s)
     5546    "Escape a string TOKEN within double-quotes if needed
     5547for use within a MS Windows command-line, outputing to S."
     5548    (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
     5549                        :escaper 'escape-windows-token-within-double-quotes))
     5550
     5551  (defun escape-sh-token-within-double-quotes (x s &key (quote t))
     5552    "Escape a string TOKEN within double-quotes
     5553for use within a POSIX Bourne shell, outputing to S;
     5554omit the outer double-quotes if key argument :QUOTE is NIL"
     5555    (when quote (princ #\" s))
     5556    (loop :for c :across x :do
     5557      (when (find c "$`\\\"") (princ #\\ s))
     5558      (princ c s))
     5559    (when quote (princ #\" s)))
     5560
     5561  (defun easy-sh-character-p (x)
     5562    "Is X an \"easy\" character that does not require quoting by the shell?"
     5563    (or (alphanumericp x) (find x "+-_.,%@:/=")))
     5564
     5565  (defun escape-sh-token (token &optional s)
     5566    "Escape a string TOKEN within double-quotes if needed
     5567for use within a POSIX Bourne shell, outputing to S."
     5568    (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
     5569                        :escaper 'escape-sh-token-within-double-quotes))
     5570
     5571  (defun escape-shell-token (token &optional s)
     5572    "Escape a token for the current operating system shell"
     5573    (os-cond
     5574      ((os-unix-p) (escape-sh-token token s))
     5575      ((os-windows-p) (escape-windows-token token s))))
     5576
     5577  (defun escape-command (command &optional s
     5578                                  (escaper 'escape-shell-token))
     5579    "Given a COMMAND as a list of tokens, return a string of the
     5580spaced, escaped tokens, using ESCAPER to escape."
     5581    (etypecase command
     5582      (string (output-string command s))
     5583      (list (with-output (s)
     5584              (loop :for first = t :then nil :for token :in command :do
     5585                (unless first (princ #\space s))
     5586                (funcall escaper token s))))))
     5587
     5588  (defun escape-windows-command (command &optional s)
     5589    "Escape a list of command-line arguments into a string suitable for parsing
     5590by CommandLineToArgv in MS Windows"
     5591    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
     5592    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
     5593    (escape-command command s 'escape-windows-token))
     5594
     5595  (defun escape-sh-command (command &optional s)
     5596    "Escape a list of command-line arguments into a string suitable for parsing
     5597by /bin/sh in POSIX"
     5598    (escape-command command s 'escape-sh-token))
     5599
     5600  (defun escape-shell-command (command &optional stream)
     5601    "Escape a command for the current operating system's shell"
     5602    (escape-command command stream 'escape-shell-token)))
     5603
     5604
     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,
     5609a PROCESSOR specification which is either an atom or a list specifying
     5610a processor an keyword arguments, call the specified processor with
     5611the 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
     5619PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
     5620the contents of the INPUT-STREAM and processes them according to a method
     5621specified by PROCESSOR.
     5622
     5623Built-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
     5638Programmers 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
     5714PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
     5715some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
     5716
     5717Built-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
     5727Programmers 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
     5801  ;;; Internal helpers for run-program
     5802  (defun %normalize-command (command)
     5803    "Given a COMMAND as a list or string, transform it in a format suitable
     5804for the implementation's underlying run-program function"
     5805    (etypecase command
     5806      #+os-unix (string `("/bin/sh" "-c" ,command))
     5807      #+os-unix (list command)
     5808      #+os-windows
     5809      (string
     5810       ;; NB: We do NOT add cmd /c here. You might want to.
     5811       #+(or allegro clisp) command
     5812       ;; On ClozureCL for Windows, we assume you are using
     5813       ;; r15398 or later in 1.9 or later,
     5814       ;; 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))
     5817       ;; NB: On other Windows implementations, this is utterly bogus
     5818       ;; except in the most trivial cases where no quoting is needed.
     5819       ;; Use at your own risk.
     5820       #-(or allegro clisp clozure sbcl) (list "cmd" "/c" command))
     5821      #+os-windows
     5822      (list
     5823       #+allegro (escape-windows-command command)
     5824       #-allegro command)))
     5825
     5826  (defun %active-io-specifier-p (specifier)
     5827    "Determines whether a run-program I/O specifier requires Lisp-side processing
     5828via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
     5829or 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))))
     5833
     5834  (defun %normalize-io-specifier (specifier &optional role)
     5835    "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
     5836argument to pass to the internal RUN-PROGRAM"
     5837    (declare (ignorable role))
     5838    (typecase specifier
     5839      (null (or #+(or allegro lispworks) (null-device-pathname)))
     5840      (string (parse-native-namestring specifier))
     5841      (pathname specifier)
     5842      (stream specifier)
     5843      ((eql :stream) :stream)
     5844      ((eql :interactive)
     5845       #+(or allegro lispworks) nil
     5846       #+clisp :terminal
     5847       #+(or abcl clozure cmucl ecl mkcl sbcl scl) t
     5848       #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
     5849       (not-implemented-error :interactive-output
     5850                              "On this lisp implementation, cannot interpret ~a value of ~a"
     5851                              specifier role))
     5852      ((eql :output)
     5853       (cond ((eq role :error-output)
     5854              #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5855              :output
     5856              #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5857              (not-implemented-error :error-output-redirect
     5858                                     "Can't send ~a to ~a on this lisp implementation."
     5859                                     role specifier))
     5860             (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
     5861      (otherwise
     5862       (parameter-error "Incorrect I/O specifier ~S for ~S"
     5863                        specifier role))))
     5864
     5865  (defun %interactivep (input output error-output)
     5866    (member :interactive (list input output error-output)))
     5867
     5868  (defun %signal-to-exit-code (signum)
     5869    (+ 128 signum))
     5870
     5871  #+mkcl
     5872  (defun %mkcl-signal-to-number (signal)
     5873    (require :mk-unix)
     5874    (symbol-value (find-symbol signal :mk-unix)))
     5875
     5876  (defclass process-info ()
     5877    ((process :initform nil)
     5878     (input-stream :initform nil)
     5879     (output-stream :initform nil)
     5880     (bidir-stream :initform nil)
     5881     (error-output-stream :initform nil)
     5882     ;; For backward-compatibility, to maintain the property (zerop
     5883     ;; exit-code) <-> success, an exit in response to a signal is
     5884     ;; encoded as 128+signum.
     5885     (exit-code :initform nil)
     5886     ;; If the platform allows it, distinguish exiting with a code
     5887     ;; >128 from exiting in response to a signal by setting this code
     5888     (signal-code :initform nil)))
     5889
     5890;;;---------------------------------------------------------------------------
     5891;;; The following two helper functions take care of handling the IF-EXISTS and
     5892;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
     5893;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
     5894;;; function to treat input and output files unconditionally for reading and
     5895;;; writing.
     5896;;;---------------------------------------------------------------------------
     5897
     5898  (defun %handle-if-exists (file if-exists)
     5899    (when (or (stringp file) (pathnamep file))
     5900      (ecase if-exists
     5901        ((:append :supersede :error)
     5902         (with-open-file (dummy file :direction :output :if-exists if-exists)
     5903           (declare (ignorable dummy)))))))
     5904
     5905  (defun %handle-if-does-not-exist (file if-does-not-exist)
     5906    (when (or (stringp file) (pathnamep file))
     5907      (ecase if-does-not-exist
     5908        ((:create :error)
     5909         (with-open-file (dummy file :direction :probe
     5910                                :if-does-not-exist if-does-not-exist)
     5911           (declare (ignorable dummy)))))))
     5912
     5913  (defun launch-program (command &rest keys
     5914                         &key
     5915                           input (if-input-does-not-exist :error)
     5916                           output (if-output-exists :supersede)
     5917                           error-output (if-error-output-exists :supersede)
     5918                           (element-type #-clozure *default-stream-element-type*
     5919                                         #+clozure 'character)
     5920                           (external-format *utf-8-external-format*)
     5921                           directory
     5922                           #+allegro separate-streams
     5923                           &allow-other-keys)
     5924    "Launch program specified by COMMAND,
     5925either a list of strings specifying a program and list of arguments,
     5926or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
     5927Windows) _asynchronously_.
     5928
     5929If OUTPUT is a pathname, a string designating a pathname, or NIL (the
     5930default) designating the null device, the file at that path is used as
     5931output.
     5932If it's :INTERACTIVE, output is inherited from the current process;
     5933beware that this may be different from your *STANDARD-OUTPUT*, and
     5934under SLIME will be on your *inferior-lisp* buffer.  If it's T, output
     5935goes to your current *STANDARD-OUTPUT* stream.  If it's :STREAM, a new
     5936stream will be made available that can be accessed via
     5937PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
     5938that the underlying lisp implementation knows how to handle.
     5939
     5940IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
     5941pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
     5942default). The meaning of these values and their effect on the case
     5943where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
     5944to OPEN with :DIRECTION :OUTPUT.
     5945
     5946ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
     5947:OUTPUT means redirecting the error output to the output stream,
     5948and :STREAM causes a stream to be made available via
     5949PROCESS-INFO-ERROR-OUTPUT.
     5950
     5951IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
     5952affects ERROR-OUTPUT rather than OUTPUT.
     5953
     5954INPUT is similar to OUTPUT, except that T designates the
     5955*STANDARD-INPUT* and a stream requested through the :STREAM keyword
     5956would be available through PROCESS-INFO-INPUT.
     5957
     5958IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
     5959or a pathname, can take the values :CREATE and :ERROR (the
     5960default). The meaning of these values is analogous to the
     5961IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
     5962
     5963ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
     5964implementation, when applicable, for creation of the output stream.
     5965
     5966LAUNCH-PROGRAM returns a PROCESS-INFO object."
     5967    #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
     5968    (progn command keys input output error-output directory element-type external-format
     5969           if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
     5970           (not-implemented-error 'launch-program))
     5971    #+allegro
     5972    (when (some #'(lambda (stream)
     5973                    (and (streamp stream)
     5974                         (not (file-stream-p stream))))
     5975                (list input output error-output))
     5976      (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
     5977                       'launch-program))
     5978    #+(or abcl clisp lispworks)
     5979    (when (some #'streamp (list input output error-output))
     5980      (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
     5981                       'launch-program))
     5982    #+clisp
     5983    (unless (eq error-output :interactive)
     5984      (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
     5985                       'launch-program :error-output :interactive))
     5986    #+ecl
     5987    (when (some #'(lambda (stream)
     5988                    (and (streamp stream)
     5989                         (not (file-or-synonym-stream-p stream))))
     5990                (list input output error-output))
     5991      (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
     5992                       'launch-program))
     5993    ;; see comments for these functions
     5994    (%handle-if-does-not-exist input if-input-does-not-exist)
     5995    (%handle-if-exists output if-output-exists)
     5996    (%handle-if-exists error-output if-error-output-exists)
     5997    #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
     5998    (let* ((%command (%normalize-command command))
     5999           (%input (%normalize-io-specifier input :input))
     6000           (%output (%normalize-io-specifier output :output))
     6001           (%error-output (%normalize-io-specifier error-output :error-output))
     6002           #+(and allegro os-windows)
     6003           (interactive (%interactivep input output error-output))
     6004           (process*
     6005             (nest
     6006              #-(or allegro mkcl sbcl) (with-current-directory (directory))
     6007              #+(or allegro ecl lispworks mkcl) (multiple-value-list)
     6008              (apply
     6009               #+abcl #'sys:run-program
     6010               #+allegro 'excl:run-shell-command
     6011               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
     6012               #+(and allegro os-windows) %command
     6013               #+clozure 'ccl:run-program
     6014               #+(or cmucl ecl scl) 'ext:run-program
     6015               #+lispworks 'system:run-shell-command
     6016               #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
     6017               #+mkcl 'mk-ext:run-program
     6018               #+sbcl 'sb-ext:run-program
     6019               (append
     6020                #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
     6021                `(:input ,%input :output ,%output
     6022                  #.(or #+(or allegro lispworks) :error-output :error) ,%error-output
     6023                  :wait nil :element-type ,element-type :external-format ,external-format
     6024                  :if-input-does-not-exist :error
     6025                  :if-output-exists :append
     6026                  #-(or allegro lispworks) :if-error-exists
     6027                  #+(or allegro lispworks) :if-error-output-exists :append
     6028                  :allow-other-keys t)
     6029                #+allegro `(:directory ,directory)
     6030                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
     6031                #+lispworks `(:save-exit-status t)
     6032                #+mkcl `(:directory ,(native-namestring directory))
     6033                #+sbcl `(:search t)
     6034                #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
     6035                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
     6036           (process-info (make-instance 'process-info)))
     6037      (labels ((prop (key value) (setf (slot-value process-info key) value)))
     6038        #+allegro
     6039        (cond
     6040          (separate-streams
     6041           (destructuring-bind (in out err pid) process*
     6042             (prop 'process pid)
     6043             (when (eq input :stream) (prop 'input-stream in))
     6044             (when (eq output :stream) (prop 'output-stream out))
     6045             (when (eq error-output :stream) (prop 'error-stream err))))
     6046          (t
     6047           (prop 'process (third process*))
     6048           (let ((x (first process*)))
     6049             (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
     6050               (0)
     6051               (1 (prop 'input-stream x))
     6052               (2 (prop 'output-stream x))
     6053               (3 (prop 'bidir-stream x))))
     6054           (when (eq error-output :stream)
     6055             (prop 'error-stream (second process*)))))
     6056        #+(or abcl clozure cmucl sbcl scl)
     6057        (progn
     6058          (prop 'process process*)
     6059          (when (eq input :stream)
     6060            (prop 'input-stream
     6061                  #+abcl (symbol-call :sys :process-input process*)
     6062                  #+clozure (ccl:external-process-input-stream process*)
     6063                  #+(or cmucl scl) (ext:process-input process*)
     6064                  #+sbcl (sb-ext:process-input process*)))
     6065          (when (eq output :stream)
     6066            (prop 'output-stream
     6067                  #+abcl (symbol-call :sys :process-output process*)
     6068                  #+clozure (ccl:external-process-output-stream process*)
     6069                  #+(or cmucl scl) (ext:process-output process*)
     6070                  #+sbcl (sb-ext:process-output process*)))
     6071          (when (eq error-output :stream)
     6072            (prop 'error-output-stream
     6073                  #+abcl (symbol-call :sys :process-error process*)
     6074                  #+clozure (ccl:external-process-error-stream process*)
     6075                  #+(or cmucl scl) (ext:process-error process*)
     6076                  #+sbcl (sb-ext:process-error process*))))
     6077        #+(or ecl mkcl)
     6078        (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
     6079          (declare (ignore code))
     6080          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
     6081            (unless (zerop mode)
     6082              (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)))
     6083          (prop 'process process))
     6084        #+lispworks
     6085        (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
     6086          (if (or (plusp mode) (eq error-output :stream))
     6087              (destructuring-bind (io err pid) process*
     6088                #+lispworks7+ (declare (ignore pid))
     6089                (prop 'process #+lispworks7+ io #-lispworks7+ pid)
     6090                (when (plusp mode)
     6091                  (prop (ecase mode
     6092                          (1 'input-stream)
     6093                          (2 'output-stream)
     6094                          (3 'bidir-stream)) io))
     6095                (when (eq error-output :stream)
     6096                  (prop 'error-stream err)))
     6097              ;; lispworks6 returns (pid), lispworks7 returns (io err pid) of which we keep io
     6098              (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.
     6186Otherwise, return immediately. An exit code (a number) will be
     6187returned, with 0 indicating success, and anything else indicating
     6188failure. If the process exits after receiving a signal, the exit code
     6189will be the sum of 128 and the (positive) numeric signal code. A second
     6190value may be returned in this case: the numeric signal code itself.
     6191Any asynchronously spawned process requires this function to be run
     6192before it is garbage-collected in order to free up resources that
     6193might 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)))))))
     6248
     6249  (defun %check-result (exit-code &key command process ignore-error-status)
     6250    (unless ignore-error-status
     6251      (unless (eql exit-code 0)
     6252        (cerror "IGNORE-ERROR-STATUS"
     6253                'subprocess-error :command command :code exit-code :process process)))
     6254    exit-code)
     6255
     6256  (defun close-streams (process-info)
     6257    "Close any stream that the process might own. Needs to be run
     6258whenever streams were requested by passing :stream to :input, :output,
     6259or :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))))
     6267
     6268  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
     6269                                &key element-type external-format &allow-other-keys)
     6270    ;; handle redirection for run-program and system
     6271    ;; SPEC is the specification for the subprocess's input or output or error-output
     6272    ;; TVAL is the value used if the spec is T
     6273    ;; GF is the generic function to call to handle arbitrary values of SPEC
     6274    ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
     6275    ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
     6276    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
     6277    ;; FUN is a function of the new reduced spec and an activity function to call with a stream
     6278    ;; when the subprocess is active and communicating through that stream.
     6279    ;; ACTIVEP is a boolean true if we will get to run code while the process is running
     6280    ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
     6281    ;; RETURNER is a function called with the value of the activity.
     6282    ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
     6283    (declare (ignorable stream-easy-p))
     6284    (let* ((actual-spec (if (eq spec t) tval spec))
     6285           (activity-spec (if (eq actual-spec :output)
     6286                              (ecase direction
     6287                                ((:input :output)
     6288                                 (error "~S not allowed as a ~S ~S spec"
     6289                                        :output 'run-program direction))
     6290                                ((:error-output)
     6291                                 nil))
     6292                              actual-spec)))
     6293      (labels ((activity (stream)
     6294                 (call-function returner (call-stream-processor gf activity-spec stream)))
     6295               (easy-case ()
     6296                 (funcall fun actual-spec nil))
     6297               (hard-case ()
     6298                 (if activep
     6299                     (funcall fun :stream #'activity)
     6300                     (with-temporary-file (:pathname tmp)
     6301                       (ecase direction
     6302                         (:input
     6303                          (with-output-file (s tmp :if-exists :overwrite
     6304                                               :external-format external-format
     6305                                               :element-type element-type)
     6306                            (activity s))
     6307                          (funcall fun tmp nil))
     6308                         ((:output :error-output)
     6309                          (multiple-value-prog1 (funcall fun tmp nil)
     6310                            (with-input-file (s tmp
     6311                                               :external-format external-format
     6312                                               :element-type element-type)
     6313                              (activity s)))))))))
     6314        (typecase activity-spec
     6315          ((or null string pathname (eql :interactive))
     6316           (easy-case))
     6317          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
     6318          (stream
     6319           (if stream-easy-p (easy-case) (hard-case)))
     6320          (t
     6321           (hard-case))))))
     6322
     6323  (defmacro place-setter (place)
     6324    (when place
     6325      (let ((value (gensym)))
     6326        `#'(lambda (,value) (setf ,place ,value)))))
     6327
     6328  (defmacro with-program-input (((reduced-input-var
     6329                                  &optional (input-activity-var (gensym) iavp))
     6330                                 input-form &key setf stream-easy-p active keys) &body body)
     6331    `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
     6332            #'(lambda (,reduced-input-var ,input-activity-var)
     6333                ,@(unless iavp `((declare (ignore ,input-activity-var))))
     6334                ,@body)
     6335            :input ,input-form ,active (place-setter ,setf) ,keys))
     6336
     6337  (defmacro with-program-output (((reduced-output-var
     6338                                  &optional (output-activity-var (gensym) oavp))
     6339                                  output-form &key setf stream-easy-p active keys) &body body)
     6340    `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
     6341            #'(lambda (,reduced-output-var ,output-activity-var)
     6342                ,@(unless oavp `((declare (ignore ,output-activity-var))))
     6343                ,@body)
     6344            :output ,output-form ,active (place-setter ,setf) ,keys))
     6345
     6346  (defmacro with-program-error-output (((reduced-error-output-var
     6347                                         &optional (error-output-activity-var (gensym) eoavp))
     6348                                        error-output-form &key setf stream-easy-p active keys)
     6349                                       &body body)
     6350    `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
     6351            #'(lambda (,reduced-error-output-var ,error-output-activity-var)
     6352                ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
     6353                ,@body)
     6354            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
     6355
     6356  (defun %use-launch-program (command &rest keys
     6357                           &key input output error-output ignore-error-status &allow-other-keys)
     6358    ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
     6359    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
     6360    (progn
     6361      command keys input output error-output ignore-error-status ;; ignore
     6362      (not-implemented-error '%use-launch-program))
     6363    (when (member :stream (list input output error-output))
     6364      (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
     6365                       'run-program :stream))
     6366    (let* ((active-input-p (%active-io-specifier-p input))
     6367           (active-output-p (%active-io-specifier-p output))
     6368           (active-error-output-p (%active-io-specifier-p error-output))
     6369           (activity
     6370             (cond
     6371               (active-output-p :output)
     6372               (active-input-p :input)
     6373               (active-error-output-p :error-output)
     6374               (t nil)))
     6375           output-result error-output-result exit-code process-info)
     6376      (with-program-output ((reduced-output output-activity)
     6377                            output :keys keys :setf output-result
     6378                            :stream-easy-p t :active (eq activity :output))
     6379        (with-program-error-output ((reduced-error-output error-output-activity)
     6380                                    error-output :keys keys :setf error-output-result
     6381                                    :stream-easy-p t :active (eq activity :error-output))
     6382          (with-program-input ((reduced-input input-activity)
     6383                               input :keys keys
     6384                               :stream-easy-p t :active (eq activity :input))
     6385            (setf process-info
     6386                  (apply 'launch-program command
     6387                         :input reduced-input :output reduced-output
     6388                         :error-output (if (eq error-output :output) :output reduced-error-output)
     6389                         keys))
     6390            (labels ((get-stream (stream-name &optional fallbackp)
     6391                       (or (slot-value process-info stream-name)
     6392                           (when fallbackp
     6393                             (slot-value process-info 'bidir-stream))))
     6394                     (run-activity (activity stream-name &optional fallbackp)
     6395                       (if-let (stream (get-stream stream-name fallbackp))
     6396                         (funcall activity stream)
     6397                         (error 'subprocess-error
     6398                                :code `(:missing ,stream-name)
     6399                                :command command :process process-info))))
     6400              (unwind-protect
     6401                   (ecase activity
     6402                     ((nil))
     6403                     (:input (run-activity input-activity 'input-stream t))
     6404                     (:output (run-activity output-activity 'output-stream t))
     6405                     (:error-output (run-activity error-output-activity 'error-output-stream)))
     6406                (close-streams process-info)
     6407                (setf exit-code (wait-process process-info)))))))
     6408      (%check-result exit-code
     6409                     :command command :process process-info
     6410                     :ignore-error-status ignore-error-status)
     6411      (values output-result error-output-result exit-code)))
     6412
     6413  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
     6414    (etypecase command
     6415      (string
     6416       (os-cond
     6417        ((os-windows-p)
     6418         #+(or allegro clisp ecl)
     6419         (strcat "cmd" " /c " command)
     6420         #-(or allegro clisp ecl) command)
     6421        (t command)))
     6422      (list (escape-shell-command
     6423             (os-cond
     6424              ((os-unix-p) (cons "exec" command))
     6425              ((os-windows-p)
     6426               #+(or allegro clisp ecl sbcl)
     6427               (list* "cmd" "/c" command)
     6428               #-(or allegro clisp ecl sbcl) command)
     6429              (t command))))))
     6430
     6431  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
     6432    (flet ((redirect (spec operator)
     6433             (let ((pathname
     6434                     (typecase spec
     6435                       (null (null-device-pathname))
     6436                       (string (parse-native-namestring spec))
     6437                       (pathname spec)
     6438                       ((eql :output)
     6439                        (unless (equal operator " 2>>")
     6440                          (parameter-error "~S: only the ~S argument can be ~S"
     6441                                           'run-program :error-output :output))
     6442                        (return-from redirect '(" 2>&1"))))))
     6443               (when pathname
     6444                 (list operator " "
     6445                       (escape-shell-token (native-namestring pathname)))))))
     6446      (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>")))
     6447             (normalized (%normalize-system-command command))
     6448             (directory (or directory #+(or abcl xcl) (getcwd)))
     6449             (chdir (when directory
     6450                      (let ((dir-arg (escape-shell-token (native-namestring directory))))
     6451                        (os-cond
     6452                         ((os-unix-p) `("cd " ,dir-arg " ; "))
     6453                         ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
     6454        (reduce/strcat
     6455         (os-cond
     6456          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
     6457          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
     6458
     6459  (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
     6463                                       &allow-other-keys)
     6464    "A portable abstraction of a low-level call to libc's system()."
     6465    (declare (ignorable keys directory input if-input-does-not-exist output
     6466                        if-output-exists error-output if-error-output-exists))
     6467    #+(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))))
     6469      (nest
     6470       #+abcl (unless (lexicographic< '< version '(1 4 0)))
     6471       #+ecl (unless (lexicographic<= '< version '(16 0 0)))
     6472       #+mkcl (unless (lexicographic<= '< version '(1 1 9)))
     6473       (return-from %system
     6474         (wait-process
     6475          (apply 'launch-program (%normalize-system-command command) keys)))))
     6476    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
     6477    (let ((%command (%redirected-system-command command input output error-output directory)))
     6478      ;; see comments for these functions
     6479      (%handle-if-does-not-exist input if-input-does-not-exist)
     6480      (%handle-if-exists output if-output-exists)
     6481      (%handle-if-exists error-output if-error-output-exists)
     6482      #+abcl (ext:run-shell-command %command)
     6483      #+(or clasp ecl) (let ((*standard-input* *stdin*)
     6484                             (*standard-output* *stdout*)
     6485                             (*error-output* *stderr*))
     6486                         (ext:system %command))
     6487      #+clisp
     6488      (let ((raw-exit-code
     6489             (or
     6490              #.`(#+os-windows ,@'(ext:run-shell-command %command)
     6491                  #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command))
     6492                  :wait t :input :terminal :output :terminal)
     6493              0)))
     6494        (if (minusp raw-exit-code)
     6495            (- 128 raw-exit-code)
     6496            raw-exit-code))
     6497      #+cormanlisp (win32:system %command)
     6498      #+gcl (system:system %command)
     6499      #+genera (not-implemented-error '%system)
     6500      #+(and lispworks os-windows)
     6501      (system:call-system %command :current-directory directory :wait t)
     6502      #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
     6503      #+mkcl (mkcl:system %command)
     6504      #+xcl (system:%run-shell-command %command)))
     6505
     6506  (defun %use-system (command &rest keys
     6507                      &key input output error-output ignore-error-status &allow-other-keys)
     6508    ;; helper for RUN-PROGRAM when using %system
     6509    (let (output-result error-output-result exit-code)
     6510      (with-program-output ((reduced-output)
     6511                            output :keys keys :setf output-result)
     6512        (with-program-error-output ((reduced-error-output)
     6513                                    error-output :keys keys :setf error-output-result)
     6514          (with-program-input ((reduced-input) input :keys keys)
     6515            (setf exit-code (apply '%system command
     6516                                   :input reduced-input :output reduced-output
     6517                                   :error-output reduced-error-output keys)))))
     6518      (%check-result exit-code
     6519                     :command command
     6520                     :ignore-error-status ignore-error-status)
     6521      (values output-result error-output-result exit-code)))
     6522
     6523  (defun run-program (command &rest keys
     6524                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
     6525                         input (if-input-does-not-exist :error)
     6526                         output (if-output-exists :supersede)
     6527                         error-output (if-error-output-exists :supersede)
     6528                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
     6529                         (external-format *utf-8-external-format*)
     6530                      &allow-other-keys)
     6531    "Run program specified by COMMAND,
     6532either a list of strings specifying a program and list of arguments,
     6533or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
     6534_synchronously_ process its output as specified and return the processing results
     6535when the program and its output processing are complete.
     6536
     6537Always call a shell (rather than directly execute the command when possible)
     6538if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
     6539specified to be NIL.
     6540
     6541Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
     6542unless IGNORE-ERROR-STATUS is specified.
     6543
     6544If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
     6545designating the null device, the file at that path is used as output.
     6546If it's :INTERACTIVE, output is inherited from the current process;
     6547beware that this may be different from your *STANDARD-OUTPUT*,
     6548and under SLIME will be on your *inferior-lisp* buffer.
     6549If it's T, output goes to your current *STANDARD-OUTPUT* stream.
     6550Otherwise, OUTPUT should be a value that is a suitable first argument to
     6551SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
     6552In this case, RUN-PROGRAM will create a temporary stream for the program output;
     6553the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
     6554using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
     6555The primary value resulting from that call (or NIL if no call was needed)
     6556will be the first value returned by RUN-PROGRAM.
     6557E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
     6558And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
     6559stripped of any ending newline.
     6560
     6561IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
     6562pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
     6563default). The meaning of these values and their effect on the case
     6564where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
     6565to OPEN with :DIRECTION :OUTPUT.
     6566
     6567ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
     6568as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
     6569Also :OUTPUT means redirecting the error output to the output stream,
     6570in which case NIL is returned.
     6571
     6572IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
     6573affects ERROR-OUTPUT rather than OUTPUT.
     6574
     6575INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
     6576no value is returned, and T designates the *STANDARD-INPUT*.
     6577
     6578IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
     6579or a pathname, can take the values :CREATE and :ERROR (the
     6580default). The meaning of these values is analogous to the
     6581IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
     6582
     6583ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
     6584to your Lisp implementation, when applicable, for creation of the output stream.
     6585
     6586One and only one of the stream slurping or vomiting may or may not happen
     6587in parallel in parallel with the subprocess,
     6588depending on options and implementation,
     6589and with priority being given to output processing.
     6590Other streams are completely produced or consumed
     6591before or after the subprocess is spawned, using temporary files.
     6592
     6593RUN-PROGRAM returns 3 values:
     65940- the result of the OUTPUT slurping if any, or NIL
     65951- the result of the ERROR-OUTPUT slurping if any, or NIL
     65962- either 0 if the subprocess exited with success status,
     6597or an indication of failure via the EXIT-CODE of the process"
     6598    (declare (ignorable ignore-error-status))
     6599    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
     6600    (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)))
     6607    (apply (if (or force-shell
     6608                   #+(or clasp clisp) t
     6609                   ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
     6610                   #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
     6611                                   (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)
     6614               '%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
     6651not be sent a signal, which it will find harder (or even impossible)
     6652to ignore if URGENT is T. On some platforms, it may also be subject to
     6653race 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)))))
     6670
    66766671;;;; ---------------------------------------------------------------------------
    66776672;;;; Generic support for configuration files
     
    69526947:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
    69536948     Returns NIL when the folder is not defined (e.g., not on Windows)."
    6954     (or #+(and lispworks mswindows) (sys:get-folder-path folder)
     6949    (or #+(and lispworks os-windows) (sys:get-folder-path folder)
    69556950        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    69566951        (ecase folder
     
    71947189    (let ((previous (asdf-version)))
    71957190      (when previous
    7196         ;; Punt on hard package upgrade: from ASDF1 or ASDF2
     7191        ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package.
    71977192        (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature.
    71987193          (let ((away (format nil "~A-~A" :asdf previous)))
    71997194            (rename-package :asdf away)
    72007195            (when *load-verbose*
    7201               (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))
    7202       (list previous)))
     7196              (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))
     7197        (list previous))))
    72037198  ;; This public variable will be bound shortly to the currently loaded version of ASDF.
    72047199  (defvar *asdf-version* nil)
    7205   ;; We need to clear systems from versions older than the one in this (private) parameter:
    7206   (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component.
     7200  ;; We need to clear systems from versions older than the one in this (private) parameter.
     7201  ;; The latest incompatible defclass is 2.32.13 renaming a slot in component;
     7202  ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below).
     7203  (defparameter *oldest-forward-compatible-asdf-version* "3.1.7.20")
    72077204  ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages
    72087205  (defvar *verbose-out* nil)
     
    72497246         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    72507247         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    7251          (asdf-version "3.1.7.27")
     7248         (asdf-version "3.1.7.35")
    72527249         (existing-version (asdf-version)))
    72537250    (setf *asdf-version* asdf-version)
     
    72617258;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
    72627259(when-upgrading ()
    7263   (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
    7264           ;; NB: it's too late to do anything about functions in UIOP!
    7265           ;; If you introduce some critically incompatibility there, you must change name.
    7266           '()) ;; empty now that we don't unintern, but wholly punt on ASDF 2.26 or earlier.
     7260  (let ((redefined-functions ;; List of functions that changes incompatibly since 2.27:
     7261         ;; gf signature changed (should NOT happen), defun that became a generic function,
     7262         ;; method removed that will mess up with new ones (especially :around :before :after,
     7263         ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops.
     7264         ;; NB: it's too late to do anything about functions in UIOP!
     7265         ;; If you introduce some critical incompatibility there, you must change the function name.
     7266         ;; Note that we don't need do anything about functions that changed incompatibly
     7267         ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
     7268         ;; Also note that we don't include the defgeneric=>defun, because they are
     7269         ;; done directly with defun* and need not trigger a punt on data.
     7270         ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
     7271         '(#:component-depends-on #:input-files ;; methods removed before 3.1.2
     7272           #:find-component ;; gf modified in 3.1.7.20
     7273           ))
    72677274        (redefined-classes
    7268           ;; redefining the classes causes interim circularities
    7269           ;; with the old ASDF during upgrade, and many implementations bork
    7270           '((#:compile-concatenated-source-op (#:operation) ()))))
     7275         ;; redefining the classes causes interim circularities
     7276         ;; with the old ASDF during upgrade, and many implementations bork
     7277         '((#:compile-concatenated-source-op (#:operation) ()))))
    72717278    (loop :for name :in redefined-functions
    7272           :for sym = (find-symbol* name :asdf nil) :do
    7273             (when sym
    7274               ;; CLISP seemingly can't fmakunbound and define a function in the same fasl. Sigh.
    7275               #-clisp (fmakunbound sym)))
    7276     (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
     7279      :for sym = (find-symbol* name :asdf nil)
     7280      :do (when sym (fmakunbound sym)))
     7281    (labels ((asym (x) (multiple-value-bind (s p)
     7282                           (if (consp x) (values (car x) (cadr x)) (values x :asdf))
    72777283                         (find-symbol* s p nil)))
    72787284             (asyms (l) (mapcar #'asym l)))
     
    73127318      (handler-bind (((or style-warning) #'muffle-warning))
    73137319        (symbol-call :asdf :load-system :asdf :verbose nil)))))
     7320;;;; -------------------------------------------------------------------------
     7321;;;; Session cache
     7322
     7323(uiop/package:define-package :asdf/cache
     7324  (:use :uiop/common-lisp :uiop :asdf/upgrade)
     7325  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
     7326           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
     7327           #:do-asdf-cache #:normalize-namestring
     7328           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
     7329           #:clear-configuration-and-retry #:retry))
     7330(in-package :asdf/cache)
     7331
     7332;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
     7333;; * Consistency in the view of the world relied on by ASDF within a given session.
     7334;;   Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
     7335;;   (a.k.a. stack overflows) and other erratic behavior.
     7336;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
     7337;;   no expensive recomputations of transitive dependencies for some input-files or output-files.
     7338;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
     7339
     7340(with-upgradability ()
     7341  ;; The session cache variable.
     7342  ;; NIL when outside a session, an equal hash-table when inside a session.
     7343  (defvar *asdf-cache* nil)
     7344
     7345  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
     7346  ;; Return those values.
     7347  (defun set-asdf-cache-entry (key value-list)
     7348    (values-list (if *asdf-cache*
     7349                     (setf (gethash key *asdf-cache*) value-list)
     7350                     value-list)))
     7351
     7352  ;; Unset the session cache entry for KEY, when inside a session.
     7353  (defun unset-asdf-cache-entry (key)
     7354    (when *asdf-cache*
     7355      (remhash key *asdf-cache*)))
     7356
     7357  ;; Consult the session cache entry for KEY if present and in a session;
     7358  ;; if not present, compute it by calling the THUNK,
     7359  ;; and set the session cache entry accordingly, if in a session.
     7360  ;; Return the values from the cache and/or the thunk computation.
     7361  (defun consult-asdf-cache (key &optional thunk)
     7362    (if *asdf-cache*
     7363        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
     7364          (if foundp
     7365              (values-list results)
     7366              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
     7367        (call-function thunk)))
     7368
     7369  ;; Syntactic sugar for consult-asdf-cache
     7370  (defmacro do-asdf-cache (key &body body)
     7371    `(consult-asdf-cache ,key #'(lambda () ,@body)))
     7372
     7373  ;; Compute inside a ASDF session with a cache.
     7374  ;; First, make sure an ASDF session is underway, by binding the session cache variable
     7375  ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
     7376  ;; Second, if a new session was started, establish restarts for retrying the overall computation.
     7377  ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
     7378  ;; entry isn't found, or just call the THUNK if no KEY was specified.
     7379  (defun call-with-asdf-cache (thunk &key override key)
     7380    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
     7381      (if (and *asdf-cache* (not override))
     7382          (funcall fun)
     7383          (loop
     7384            (restart-case
     7385                (let ((*asdf-cache* (make-hash-table :test 'equal)))
     7386                  (return (funcall fun)))
     7387              (retry ()
     7388                :report (lambda (s)
     7389                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
     7390              (clear-configuration-and-retry ()
     7391                :report (lambda (s)
     7392                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
     7393                (clear-configuration)))))))
     7394
     7395  ;; Syntactic sugar for call-with-asdf-cache
     7396  (defmacro with-asdf-cache ((&key key override) &body body)
     7397    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
     7398
     7399
     7400  ;;; Define specific accessor for file (date) stamp.
     7401
     7402  ;; Normalize a namestring for use as a key in the session cache.
     7403  (defun normalize-namestring (pathname)
     7404    (let ((resolved (resolve-symlinks*
     7405                     (ensure-absolute-pathname
     7406                      (physicalize-pathname pathname)
     7407                      'get-pathname-defaults))))
     7408      (with-pathname-defaults () (namestring resolved))))
     7409
     7410  ;; Compute the file stamp for a normalized namestring
     7411  (defun compute-file-stamp (normalized-namestring)
     7412    (with-pathname-defaults ()
     7413      (safe-file-write-date normalized-namestring)))
     7414
     7415  ;; Override the time STAMP associated to a given FILE in the session cache.
     7416  ;; If no STAMP is specified, recompute a new one from the filesystem.
     7417  (defun register-file-stamp (file &optional (stamp nil stampp))
     7418    (let* ((namestring (normalize-namestring file))
     7419           (stamp (if stampp stamp (compute-file-stamp namestring))))
     7420      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
     7421
     7422  ;; Get or compute a memoized stamp for given FILE from the session cache.
     7423  (defun get-file-stamp (file)
     7424    (when file
     7425      (let ((namestring (normalize-namestring file)))
     7426        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
     7427
    73147428;;;; -------------------------------------------------------------------------
    73157429;;;; Components
     
    73637477  (defgeneric component-pathname (component)
    73647478    (:documentation "Pathname of the COMPONENT if any, or NIL."))
    7365   (defgeneric* (component-relative-pathname) (component)
     7479  (defgeneric component-relative-pathname (component)
    73667480    ;; in ASDF4, rename that to component-specified-pathname ?
    73677481    (:documentation "Specified pathname of the COMPONENT,
     
    73927506  ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
    73937507  ;; TODO: find users, have them stop using that, remove it for ASDF4.
    7394   (defgeneric* (source-file-type) (component system)
     7508  (defgeneric source-file-type (component system)
    73957509    (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
    73967510
     
    75467660;;;; component pathnames
    75477661(with-upgradability ()
    7548   (defgeneric* (component-parent-pathname) (component)
     7662  (defgeneric component-parent-pathname (component)
    75497663    (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
    75507664  (defmethod component-parent-pathname (component)
     
    76737787  ;; The method is actually defined in asdf/find-system,
    76747788  ;; but we declare the function here to avoid a forward reference.
    7675   (defgeneric* (find-system) (system &optional error-p)
     7789  (defgeneric find-system (system &optional error-p)
    76767790    (:documentation "Given a system designator, find the actual corresponding system object.
    76777791If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
    76787792A system designator is usually a string (conventionally all lowercase) or a symbol, designating
    76797793the same system as its downcased name; it can also be a system object (designating itself)."))
    7680   (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
     7794  (defgeneric system-source-file (system)
    76817795    (:documentation "Return the source file in which system is defined."))
    76827796  ;; This is bad design, but was the easiest kluge I found to let the user specify that
     
    78047918
    78057919;;;; -------------------------------------------------------------------------
    7806 ;;;; Session cache
    7807 
    7808 (uiop/package:define-package :asdf/cache
    7809   (:use :uiop/common-lisp :uiop :asdf/upgrade)
    7810   (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
    7811            #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
    7812            #:do-asdf-cache #:normalize-namestring
    7813            #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
    7814            #:clear-configuration-and-retry #:retry))
    7815 (in-package :asdf/cache)
    7816 
    7817 ;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
    7818 ;; * Consistency in the view of the world relied on by ASDF within a given session.
    7819 ;;   Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
    7820 ;;   (a.k.a. stack overflows) and other erratic behavior.
    7821 ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
    7822 ;;   no expensive recomputations of transitive dependencies for some input-files or output-files.
    7823 ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
    7824 
    7825 (with-upgradability ()
    7826   ;; The session cache variable.
    7827   ;; NIL when outside a session, an equal hash-table when inside a session.
    7828   (defvar *asdf-cache* nil)
    7829 
    7830   ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
    7831   ;; Return those values.
    7832   (defun set-asdf-cache-entry (key value-list)
    7833     (values-list (if *asdf-cache*
    7834                      (setf (gethash key *asdf-cache*) value-list)
    7835                      value-list)))
    7836 
    7837   ;; Unset the session cache entry for KEY, when inside a session.
    7838   (defun unset-asdf-cache-entry (key)
    7839     (when *asdf-cache*
    7840       (remhash key *asdf-cache*)))
    7841 
    7842   ;; Consult the session cache entry for KEY if present and in a session;
    7843   ;; if not present, compute it by calling the THUNK,
    7844   ;; and set the session cache entry accordingly, if in a session.
    7845   ;; Return the values from the cache and/or the thunk computation.
    7846   (defun consult-asdf-cache (key &optional thunk)
    7847     (if *asdf-cache*
    7848         (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
    7849           (if foundp
    7850               (values-list results)
    7851               (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
    7852         (call-function thunk)))
    7853 
    7854   ;; Syntactic sugar for consult-asdf-cache
    7855   (defmacro do-asdf-cache (key &body body)
    7856     `(consult-asdf-cache ,key #'(lambda () ,@body)))
    7857 
    7858   ;; Compute inside a ASDF session with a cache.
    7859   ;; First, make sure an ASDF session is underway, by binding the session cache variable
    7860   ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
    7861   ;; Second, if a new session was started, establish restarts for retrying the overall computation.
    7862   ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
    7863   ;; entry isn't found, or just call the THUNK if no KEY was specified.
    7864   (defun call-with-asdf-cache (thunk &key override key)
    7865     (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
    7866       (if (and *asdf-cache* (not override))
    7867           (funcall fun)
    7868           (loop
    7869             (restart-case
    7870                 (let ((*asdf-cache* (make-hash-table :test 'equal)))
    7871                   (return (funcall fun)))
    7872               (retry ()
    7873                 :report (lambda (s)
    7874                           (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
    7875               (clear-configuration-and-retry ()
    7876                 :report (lambda (s)
    7877                           (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
    7878                 (clear-configuration)))))))
    7879 
    7880   ;; Syntactic sugar for call-with-asdf-cache
    7881   (defmacro with-asdf-cache ((&key key override) &body body)
    7882     `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
    7883 
    7884 
    7885   ;;; Define specific accessor for file (date) stamp.
    7886 
    7887   ;; Normalize a namestring for use as a key in the session cache.
    7888   (defun normalize-namestring (pathname)
    7889     (let ((resolved (resolve-symlinks*
    7890                      (ensure-absolute-pathname
    7891                       (physicalize-pathname pathname)
    7892                       'get-pathname-defaults))))
    7893       (with-pathname-defaults () (namestring resolved))))
    7894 
    7895   ;; Compute the file stamp for a normalized namestring
    7896   (defun compute-file-stamp (normalized-namestring)
    7897     (with-pathname-defaults ()
    7898       (safe-file-write-date normalized-namestring)))
    7899 
    7900   ;; Override the time STAMP associated to a given FILE in the session cache.
    7901   ;; If no STAMP is specified, recompute a new one from the filesystem.
    7902   (defun register-file-stamp (file &optional (stamp nil stampp))
    7903     (let* ((namestring (normalize-namestring file))
    7904            (stamp (if stampp stamp (compute-file-stamp namestring))))
    7905       (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
    7906 
    7907   ;; Get or compute a memoized stamp for given FILE from the session cache.
    7908   (defun get-file-stamp (file)
    7909     (when file
    7910       (let ((namestring (normalize-namestring file)))
    7911         (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
    7912 
    7913 ;;;; -------------------------------------------------------------------------
    79147920;;;; Finding systems
    79157921
     
    81138119                   :format-arguments (list name))))))
    81148120
    8115 (defun register-immutable-system (system-name &rest keys)
    8116   "Register SYSTEM-NAME as preloaded and immutable.
     8121  (defun register-immutable-system (system-name &rest keys)
     8122    "Register SYSTEM-NAME as preloaded and immutable.
    81178123It will automatically be considered as passed to FORCE-NOT in a plan."
    81188124    (let ((system-name (coerce-name system-name)))
     
    85098515
    85108516(with-upgradability ()
    8511   (defgeneric* (find-component) (base path &key registered)
     8517  (defgeneric find-component (base path &key registered)
    85128518    (:documentation "Find a component by resolving the PATH starting from BASE parent.
    85138519If REGISTERED is true, only search currently registered systems."))
     
    86538659      (setf (operation-original-initargs o) initargs)))
    86548660
     8661  (defvar *in-make-operation* nil)
     8662
     8663  (defun check-operation-constructor ()
     8664    "Enforce that OPERATION instances must be created with MAKE-OPERATION."
     8665    (unless *in-make-operation*
     8666      (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION.")))
     8667
    86558668  (defmethod print-object ((o operation) stream)
    86568669    (print-unreadable-object (o stream :type t :identity nil)
     
    86718684Use of INITARGS is for backward compatibility and may be discontinued at any time."
    86728685    (let ((class (coerce-class operation-class
    8673                                :package :asdf/interface :super 'operation :error 'sysdef-error)))
     8686                               :package :asdf/interface :super 'operation :error 'sysdef-error))
     8687          (*in-make-operation* t))
    86748688      (ensure-gethash (cons class initargs) *operations*
    86758689                      (list* 'make-instance class initargs))))
     
    86998713  (:use :uiop/common-lisp :uiop :asdf/upgrade
    87008714   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
     8715  (:import-from :asdf/operation #:check-operation-constructor)
    87018716  (:export
    87028717   #:action #:define-convenience-action-methods
     
    87068721   #:input-files #:output-files #:output-file #:operation-done-p
    87078722   #:action-status #:action-stamp #:action-done-p
     8723   #:action-operation #:action-component #:make-action
    87088724   #:component-operation-time #:mark-operation-done #:compute-action-stamp
    87098725   #:perform #:perform-with-restarts #:retry #:accept
     
    87258741    '(or operation null symbol class)))
    87268742
     8743;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan
     8744;;; actions.
     8745(with-upgradability ()
     8746  (defun make-action (operation component)
     8747    (cons operation component))
     8748  (defun action-operation (action)
     8749    (car action))
     8750  (defun action-component (action)
     8751    (cdr action)))
    87278752
    87288753;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
     
    87308755  (defun action-path (action)
    87318756    "A readable data structure that identifies the action."
    8732     (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
     8757    (let ((o (action-operation action))
     8758          (c (action-component action)))
     8759      (cons (type-of o) (component-find-path c))))
    87338760  (defun find-action (path)
    87348761    "Reconstitute an action from its action-path"
    8735     (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
    8736 
     8762    (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
    87378763
    87388764;;;; Convenience methods
     
    87848810             (if (typep ,component 'component)
    87858811                 (error "No defined method for ~S on ~/asdf-action:format-action/"
    8786                         ',function (cons ,operation ,component))
     8812                        ',function (make-action ,operation ,component))
    87878813                 (if-let (,found (find-component () ,component))
    87888814                    ,(next-method operation found)
     
    88108836;;;; Dependencies
    88118837(with-upgradability ()
    8812   (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
     8838  (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
    88138839    (:documentation
    88148840     "Returns a list of dependencies needed by the component to perform
     
    89258951
    89268952  (defmethod initialize-instance :before ((o operation) &key)
     8953    (check-operation-constructor)
    89278954    (unless (typep o '(or downward-operation upward-operation sideway-operation
    89288955                          selfward-operation non-propagating-operation))
     
    89638990;;;; Inputs, Outputs, and invisible dependencies
    89648991(with-upgradability ()
    8965   (defgeneric* (output-files) (operation component)
     8992  (defgeneric output-files (operation component)
    89668993    (:documentation "Methods for this function return two values: a list of output files
    89678994corresponding to this action, and a boolean indicating if they have already been subjected
     
    89718998They may rely on the order of the files to discriminate between outputs.
    89728999"))
    8973   (defgeneric* (input-files) (operation component)
     9000  (defgeneric input-files (operation component)
    89749001    (:documentation "A list of input files corresponding to this action.
    89759002
     
    89779004They may rely on the order of the files to discriminate between inputs.
    89789005"))
    8979   (defgeneric* (operation-done-p) (operation component)
     9006  (defgeneric operation-done-p (operation component)
    89809007    (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
    89819008  (define-convenience-action-methods output-files (operation component))
     
    89879014
    89889015  ;; Translate output files, unless asked not to. Memoize the result.
    8989   (defmethod output-files :around (operation component)
    8990     operation component ;; hush genera, not convinced by declare ignorable(!)
     9016  (defmethod output-files :around ((operation t) (component t))
    89919017    (do-asdf-cache `(output-files ,operation ,component)
    89929018      (values
     
    90519077    (:documentation "Has this action been successfully done already,
    90529078and at what known timestamp has it been done at or will it be done at?
    9053 Takes two keywords JUST-DONE and PLAN:
     9079* PLAN is a plan object modelling future effects of actions,
     9080  or NIL to denote what actually happened.
     9081* OPERATION and COMPONENT denote the action.
     9082Takes keyword JUST-DONE:
    90549083* JUST-DONE is a boolean that is true if the action was just successfully performed,
    90559084  at which point we want compute the actual stamp and warn if files are missing;
    90569085  otherwise we are making plans, anticipating the effects of the action.
    9057 * PLAN is a plan object modelling future effects of actions,
    9058   or NIL to denote what actually happened.
    90599086Returns two values:
    90609087* a STAMP saying when it was done or will be done,
     
    90909117;;;; Perform
    90919118(with-upgradability ()
    9092   (defgeneric* (perform) (operation component)
     9119  (defgeneric perform (operation component)
    90939120    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
    90949121  (define-convenience-action-methods perform (operation component))
     
    91069133      (sysdef-error
    91079134       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
    9108        'perform (cons o c))))
     9135       'perform (make-action o c))))
    91099136
    91109137  ;; The restarts of the perform-with-restarts variant matter in an interactive context.
    91119138  ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
    91129139  ;; may call perform directly rather than call p-w-r.
    9113   (defgeneric* (perform-with-restarts) (operation component)
     9140  (defgeneric perform-with-restarts (operation component)
    91149141    (:documentation "PERFORM an action in a context where suitable restarts are in place."))
    91159142  (defmethod perform-with-restarts (operation component)
     
    96109637  (defun* (direct-dependencies) (plan operation component)
    96119638    "Compute a list of the direct dependencies of the action within the plan"
    9612     (reduce-direct-dependencies plan operation component #'acons nil))
     9639    (reverse (reduce-direct-dependencies plan operation component #'acons nil)))
    96139640
    96149641  ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
     
    97309757    (with-accessors ((action-set plan-visiting-action-set)
    97319758                     (action-list plan-visiting-action-list)) plan
    9732       (let ((action (cons operation component)))
     9759      (let ((action (make-action operation component)))
    97339760        (when (gethash action action-set)
    97349761          (error 'circular-dependency :actions
     
    98279854      (new-status (p sequential-plan) (o operation) (c component))
    98289855    (when (action-planned-p new-status)
    9829       (push (cons o c) (plan-actions-r p)))))
     9856      (push (make-action o c) (plan-actions-r p)))))
    98309857
    98319858
     
    98619888
    98629889  (defmethod perform-plan ((steps list) &key force &allow-other-keys)
    9863     (loop* :for (o . c) :in steps
     9890    (loop* :for action :in steps
     9891           :as o = (action-operation action)
     9892           :as c = (action-component action)
    98649893           :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
    98659894           :do (perform-with-restarts o c)))
     
    98699898
    98709899  (defmethod plan-operates-on-p ((plan list) (component-path list))
    9871     (find component-path (mapcar 'cdr plan)
     9900    (find component-path (mapcar 'action-component plan)
    98729901          :test 'equal :key 'component-find-path)))
    98739902
     
    99059934    "Given a list of actions, build a plan with these actions as roots."
    99069935    (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
    9907       (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
     9936      (loop* :for action :in actions
     9937             :as o = (action-operation action)
     9938             :as c = (action-component action)
     9939             :do (traverse-action plan o c t))
    99089940      plan))
    99099941
     
    99179949  (defmethod plan-actions ((plan filtered-sequential-plan))
    99189950    (with-slots (keep-operation keep-component) plan
    9919       (loop* :for (o . c) :in (call-next-method)
     9951      (loop* :for action :in (call-next-method)
     9952             :as o = (action-operation action)
     9953             :as c = (action-component action)
    99209954             :when (and (typep o keep-operation) (typep c keep-component))
    9921              :collect (cons o c))))
     9955             :collect (make-action o c))))
    99229956
    99239957  (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
     
    99259959return a list of the components involved in building the desired action."
    99269960    (remove-duplicates
    9927      (mapcar 'cdr (plan-actions
    9928                    (apply 'traverse-sub-actions goal-operation system
    9929                           (remove-plist-key :goal-operation keys))))
     9961     (mapcar 'action-component
     9962             (plan-actions
     9963              (apply 'traverse-sub-actions goal-operation system
     9964                     (remove-plist-key :goal-operation keys))))
    99309965     :from-end t)))
    99319966
     
    99489983
    99499984(with-upgradability ()
    9950   (defgeneric* (operate) (operation component &key &allow-other-keys)
     9985  (defgeneric operate (operation component &key &allow-other-keys)
    99519986    (:documentation
    99529987     "Operate does mainly four things for the user:
     
    1014010175      (assert (null (component-children s)))
    1014110176      ;; CMUCL likes its module names to be all upcase.
    10142       (require #-cmucl module #+cmucl (string-upcase module))))
     10177      (require (nest #+cmucl (string-upcase) module))))
    1014310178
    1014410179  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
     
    1021710252        (dolist (o '(load-op compile-op prepare-op))
    1021810253          (setf (gethash o times) 0))))))
    10219 
    10220 ;;;; ---------------------------------------------------------------------------
    10221 ;;;; asdf-output-translations
    10222 
    10223 (uiop/package:define-package :asdf/output-translations
    10224   (:recycle :asdf/output-translations :asdf)
    10225   (:use :uiop/common-lisp :uiop :asdf/upgrade)
    10226   (:export
    10227    #:*output-translations* #:*output-translations-parameter*
    10228    #:invalid-output-translation
    10229    #:output-translations #:output-translations-initialized-p
    10230    #:initialize-output-translations #:clear-output-translations
    10231    #:disable-output-translations #:ensure-output-translations
    10232    #:apply-output-translations
    10233    #:validate-output-translations-directive #:validate-output-translations-form
    10234    #:validate-output-translations-file #:validate-output-translations-directory
    10235    #:parse-output-translations-string #:wrapping-output-translations
    10236    #:user-output-translations-pathname #:system-output-translations-pathname
    10237    #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
    10238    #:environment-output-translations #:process-output-translations
    10239    #:compute-output-translations
    10240    #+abcl #:translate-jar-pathname
    10241    ))
    10242 (in-package :asdf/output-translations)
    10243 
    10244 ;; (setf output-translations) at some point used to be a macro for the sake of
    10245 ;; obsolete versions of GCL. Make sure that macro doesn't come to haunt us.
    10246 (when-upgrading () (undefine-function '(setf output-translations)))
    10247 
    10248 (with-upgradability ()
    10249   (define-condition invalid-output-translation (invalid-configuration warning)
    10250     ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    10251 
    10252   (defvar *output-translations* ()
    10253     "Either NIL (for uninitialized), or a list of one element,
    10254 said element itself being a sorted list of mappings.
    10255 Each mapping is a pair of a source pathname and destination pathname,
    10256 and the order is by decreasing length of namestring of the source pathname.")
    10257 
    10258   (defun output-translations ()
    10259     "Return the configured output-translations, if any"
    10260     (car *output-translations*))
    10261 
    10262   ;; Set the output-translations, by sorting the provided new-value.
    10263   (defun set-output-translations (new-value)
    10264     (setf *output-translations*
    10265           (list
    10266            (stable-sort (copy-list new-value) #'>
    10267                         :key #'(lambda (x)
    10268                                  (etypecase (car x)
    10269                                    ((eql t) -1)
    10270                                    (pathname
    10271                                     (let ((directory
    10272                                            (normalize-pathname-directory-component
    10273                                             (pathname-directory (car x)))))
    10274                                       (if (listp directory) (length directory) 0))))))))
    10275     new-value)
    10276   (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
    10277 
    10278   (defun output-translations-initialized-p ()
    10279     "Have the output-translations been initialized yet?"
    10280     (and *output-translations* t))
    10281 
    10282   (defun clear-output-translations ()
    10283     "Undoes any initialization of the output translations."
    10284     (setf *output-translations* '())
    10285     (values))
    10286   (register-clear-configuration-hook 'clear-output-translations)
    10287 
    10288 
    10289   ;;; Validation of the configuration directives...
    10290 
    10291   (defun validate-output-translations-directive (directive)
    10292     (or (member directive '(:enable-user-cache :disable-cache nil))
    10293         (and (consp directive)
    10294              (or (and (length=n-p directive 2)
    10295                       (or (and (eq (first directive) :include)
    10296                                (typep (second directive) '(or string pathname null)))
    10297                           (and (location-designator-p (first directive))
    10298                                (or (location-designator-p (second directive))
    10299                                    (location-function-p (second directive))))))
    10300                  (and (length=n-p directive 1)
    10301                       (location-designator-p (first directive)))))))
    10302 
    10303   (defun validate-output-translations-form (form &key location)
    10304     (validate-configuration-form
    10305      form
    10306      :output-translations
    10307      'validate-output-translations-directive
    10308      :location location :invalid-form-reporter 'invalid-output-translation))
    10309 
    10310   (defun validate-output-translations-file (file)
    10311     (validate-configuration-file
    10312      file 'validate-output-translations-form :description "output translations"))
    10313 
    10314   (defun validate-output-translations-directory (directory)
    10315     (validate-configuration-directory
    10316      directory :output-translations 'validate-output-translations-directive
    10317                :invalid-form-reporter 'invalid-output-translation))
    10318 
    10319 
    10320   ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
    10321   (defun parse-output-translations-string (string &key location)
    10322     (cond
    10323       ((or (null string) (equal string ""))
    10324        '(:output-translations :inherit-configuration))
    10325       ((not (stringp string))
    10326        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    10327       ((eql (char string 0) #\")
    10328        (parse-output-translations-string (read-from-string string) :location location))
    10329       ((eql (char string 0) #\()
    10330        (validate-output-translations-form (read-from-string string) :location location))
    10331       (t
    10332        (loop
    10333          :with inherit = nil
    10334          :with directives = ()
    10335          :with start = 0
    10336          :with end = (length string)
    10337          :with source = nil
    10338          :with separator = (inter-directory-separator)
    10339          :for i = (or (position separator string :start start) end) :do
    10340            (let ((s (subseq string start i)))
    10341              (cond
    10342                (source
    10343                 (push (list source (if (equal "" s) nil s)) directives)
    10344                 (setf source nil))
    10345                ((equal "" s)
    10346                 (when inherit
    10347                   (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    10348                          string))
    10349                 (setf inherit t)
    10350                 (push :inherit-configuration directives))
    10351                (t
    10352                 (setf source s)))
    10353              (setf start (1+ i))
    10354              (when (> start end)
    10355                (when source
    10356                  (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    10357                         string))
    10358                (unless inherit
    10359                  (push :ignore-inherited-configuration directives))
    10360                (return `(:output-translations ,@(nreverse directives)))))))))
    10361 
    10362 
    10363   ;; The default sources of configuration for output-translations
    10364   (defparameter* *default-output-translations*
    10365     '(environment-output-translations
    10366       user-output-translations-pathname
    10367       user-output-translations-directory-pathname
    10368       system-output-translations-pathname
    10369       system-output-translations-directory-pathname))
    10370 
    10371   ;; Compulsory implementation-dependent wrapping for the translations:
    10372   ;; handle implementation-provided systems.
    10373   (defun wrapping-output-translations ()
    10374     `(:output-translations
    10375     ;; Some implementations have precompiled ASDF systems,
    10376     ;; so we must disable translations for implementation paths.
    10377       #+(or clasp #|clozure|# ecl mkcl sbcl)
    10378       ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
    10379           (when h `(((,h ,*wild-path*) ()))))
    10380       #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
    10381       ;; All-import, here is where we want user stuff to be:
    10382       :inherit-configuration
    10383       ;; These are for convenience, and can be overridden by the user:
    10384       #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    10385       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    10386       ;; We enable the user cache by default, and here is the place we do:
    10387       :enable-user-cache))
    10388 
    10389   ;; Relative pathnames of output-translations configuration to XDG configuration directory
    10390   (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
    10391   (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
    10392 
    10393   ;; Locating various configuration pathnames, depending on input or output intent.
    10394   (defun user-output-translations-pathname (&key (direction :input))
    10395     (xdg-config-pathname *output-translations-file* direction))
    10396   (defun system-output-translations-pathname (&key (direction :input))
    10397     (find-preferred-file (system-config-pathnames *output-translations-file*)
    10398                          :direction direction))
    10399   (defun user-output-translations-directory-pathname (&key (direction :input))
    10400     (xdg-config-pathname *output-translations-directory* direction))
    10401   (defun system-output-translations-directory-pathname (&key (direction :input))
    10402     (find-preferred-file (system-config-pathnames *output-translations-directory*)
    10403                          :direction direction))
    10404   (defun environment-output-translations ()
    10405     (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    10406 
    10407 
    10408   ;;; Processing the configuration.
    10409 
    10410   (defgeneric process-output-translations (spec &key inherit collect))
    10411 
    10412   (defun inherit-output-translations (inherit &key collect)
    10413     (when inherit
    10414       (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    10415 
    10416   (defun* (process-output-translations-directive) (directive &key inherit collect)
    10417     (if (atom directive)
    10418         (ecase directive
    10419           ((:enable-user-cache)
    10420            (process-output-translations-directive '(t :user-cache) :collect collect))
    10421           ((:disable-cache)
    10422            (process-output-translations-directive '(t t) :collect collect))
    10423           ((:inherit-configuration)
    10424            (inherit-output-translations inherit :collect collect))
    10425           ((:ignore-inherited-configuration :ignore-invalid-entries nil)
    10426            nil))
    10427         (let ((src (first directive))
    10428               (dst (second directive)))
    10429           (if (eq src :include)
    10430               (when dst
    10431                 (process-output-translations (pathname dst) :inherit nil :collect collect))
    10432               (when src
    10433                 (let ((trusrc (or (eql src t)
    10434                                   (let ((loc (resolve-location src :ensure-directory t :wilden t)))
    10435                                     (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
    10436                   (cond
    10437                     ((location-function-p dst)
    10438                      (funcall collect
    10439                               (list trusrc (ensure-function (second dst)))))
    10440                     ((typep dst 'boolean)
    10441                      (funcall collect (list trusrc t)))
    10442                     (t
    10443                      (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
    10444                        (funcall collect (list trudst t))
    10445                        (funcall collect (list trusrc trudst)))))))))))
    10446 
    10447   (defmethod process-output-translations ((x symbol) &key
    10448                                                        (inherit *default-output-translations*)
    10449                                                        collect)
    10450     (process-output-translations (funcall x) :inherit inherit :collect collect))
    10451   (defmethod process-output-translations ((pathname pathname) &key inherit collect)
    10452     (cond
    10453       ((directory-pathname-p pathname)
    10454        (process-output-translations (validate-output-translations-directory pathname)
    10455                                     :inherit inherit :collect collect))
    10456       ((probe-file* pathname :truename *resolve-symlinks*)
    10457        (process-output-translations (validate-output-translations-file pathname)
    10458                                     :inherit inherit :collect collect))
    10459       (t
    10460        (inherit-output-translations inherit :collect collect))))
    10461   (defmethod process-output-translations ((string string) &key inherit collect)
    10462     (process-output-translations (parse-output-translations-string string)
    10463                                  :inherit inherit :collect collect))
    10464   (defmethod process-output-translations ((x null) &key inherit collect)
    10465     (inherit-output-translations inherit :collect collect))
    10466   (defmethod process-output-translations ((form cons) &key inherit collect)
    10467     (dolist (directive (cdr (validate-output-translations-form form)))
    10468       (process-output-translations-directive directive :inherit inherit :collect collect)))
    10469 
    10470 
    10471   ;;; Top-level entry-points to configure output-translations
    10472 
    10473   (defun compute-output-translations (&optional parameter)
    10474     "read the configuration, return it"
    10475     (remove-duplicates
    10476      (while-collecting (c)
    10477        (inherit-output-translations
    10478         `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
    10479      :test 'equal :from-end t))
    10480 
    10481   ;; Saving the user-provided parameter to output-translations, if any,
    10482   ;; so we can recompute the translations after code upgrade.
    10483   (defvar *output-translations-parameter* nil)
    10484 
    10485   ;; Main entry-point for users.
    10486   (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
    10487     "read the configuration, initialize the internal configuration variable,
    10488 return the configuration"
    10489     (setf *output-translations-parameter* parameter
    10490           (output-translations) (compute-output-translations parameter)))
    10491 
    10492   (defun disable-output-translations ()
    10493     "Initialize output translations in a way that maps every file to itself,
    10494 effectively disabling the output translation facility."
    10495     (initialize-output-translations
    10496      '(:output-translations :disable-cache :ignore-inherited-configuration)))
    10497 
    10498   ;; checks an initial variable to see whether the state is initialized
    10499   ;; or cleared. In the former case, return current configuration; in
    10500   ;; the latter, initialize.  ASDF will call this function at the start
    10501   ;; of (asdf:find-system).
    10502   (defun ensure-output-translations ()
    10503     (if (output-translations-initialized-p)
    10504         (output-translations)
    10505         (initialize-output-translations)))
    10506 
    10507 
    10508   ;; Top-level entry-point to _use_ output-translations
    10509   (defun* (apply-output-translations) (path)
    10510     (etypecase path
    10511       (logical-pathname
    10512        path)
    10513       ((or pathname string)
    10514        (ensure-output-translations)
    10515        (loop* :with p = (resolve-symlinks* path)
    10516               :for (source destination) :in (car *output-translations*)
    10517               :for root = (when (or (eq source t)
    10518                                     (and (pathnamep source)
    10519                                          (not (absolute-pathname-p source))))
    10520                             (pathname-root p))
    10521               :for absolute-source = (cond
    10522                                        ((eq source t) (wilden root))
    10523                                        (root (merge-pathnames* source root))
    10524                                        (t source))
    10525               :when (or (eq source t) (pathname-match-p p absolute-source))
    10526               :return (translate-pathname* p absolute-source destination root source)
    10527               :finally (return p)))))
    10528 
    10529 
    10530   ;; Hook into uiop's output-translation mechanism
    10531   #-cormanlisp
    10532   (setf *output-translation-function* 'apply-output-translations)
    10533 
    10534 
    10535   ;;; Implementation-dependent hacks
    10536   #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
    10537   (defun translate-jar-pathname (source wildcard)
    10538     (declare (ignore wildcard))
    10539     (flet ((normalize-device (pathname)
    10540              (if (find :windows *features*)
    10541                  pathname
    10542                  (make-pathname :defaults pathname :device :unspecific))))
    10543       (let* ((jar
    10544                (pathname (first (pathname-device source))))
    10545              (target-root-directory-namestring
    10546                (format nil "/___jar___file___root___/~@[~A/~]"
    10547                        (and (find :windows *features*)
    10548                             (pathname-device jar))))
    10549              (relative-source
    10550                (relativize-pathname-directory source))
    10551              (relative-jar
    10552                (relativize-pathname-directory (ensure-directory-pathname jar)))
    10553              (target-root-directory
    10554                (normalize-device
    10555                 (pathname-directory-pathname
    10556                  (parse-namestring target-root-directory-namestring))))
    10557              (target-root
    10558                (merge-pathnames* relative-jar target-root-directory))
    10559              (target
    10560                (merge-pathnames* relative-source target-root)))
    10561         (normalize-device (apply-output-translations target))))))
    10562 
    10563 ;;;; -----------------------------------------------------------------
    10564 ;;;; Source Registry Configuration, by Francois-Rene Rideau
    10565 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
    10566 
    10567 (uiop/package:define-package :asdf/source-registry
    10568   (:recycle :asdf/source-registry :asdf)
    10569   (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
    10570   (:export
    10571    #:*source-registry-parameter* #:*default-source-registries*
    10572    #:invalid-source-registry
    10573    #:source-registry-initialized-p
    10574    #:initialize-source-registry #:clear-source-registry #:*source-registry*
    10575    #:ensure-source-registry #:*source-registry-parameter*
    10576    #:*default-source-registry-exclusions* #:*source-registry-exclusions*
    10577    #:*wild-asd* #:directory-asd-files #:register-asd-directory
    10578    #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
    10579    #:validate-source-registry-directive #:validate-source-registry-form
    10580    #:validate-source-registry-file #:validate-source-registry-directory
    10581    #:parse-source-registry-string #:wrapping-source-registry
    10582    #:default-user-source-registry #:default-system-source-registry
    10583    #:user-source-registry #:system-source-registry
    10584    #:user-source-registry-directory #:system-source-registry-directory
    10585    #:environment-source-registry #:process-source-registry #:inherit-source-registry
    10586    #:compute-source-registry #:flatten-source-registry
    10587    #:sysdef-source-registry-search))
    10588 (in-package :asdf/source-registry)
    10589 
    10590 (with-upgradability ()
    10591   (define-condition invalid-source-registry (invalid-configuration warning)
    10592     ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    10593 
    10594   ;; Default list of directories under which the source-registry tree search won't recurse
    10595   (defvar *default-source-registry-exclusions*
    10596     '(;;-- Using ack 1.2 exclusions
    10597       ".bzr" ".cdv"
    10598       ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    10599       ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    10600       "_sgbak" "autom4te.cache" "cover_db" "_build"
    10601       ;;-- debian often builds stuff under the debian directory... BAD.
    10602       "debian"))
    10603 
    10604   ;; Actual list of directories under which the source-registry tree search won't recurse
    10605   (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    10606 
    10607   ;; The state of the source-registry after search in configured locations
    10608   (defvar *source-registry* nil
    10609     "Either NIL (for uninitialized), or an equal hash-table, mapping
    10610 system names to pathnames of .asd files")
    10611 
    10612   ;; Saving the user-provided parameter to the source-registry, if any,
    10613   ;; so we can recompute the source-registry after code upgrade.
    10614   (defvar *source-registry-parameter* nil)
    10615 
    10616   (defun source-registry-initialized-p ()
    10617     (typep *source-registry* 'hash-table))
    10618 
    10619   (defun clear-source-registry ()
    10620     "Undoes any initialization of the source registry."
    10621     (setf *source-registry* nil)
    10622     (values))
    10623   (register-clear-configuration-hook 'clear-source-registry)
    10624 
    10625   (defparameter *wild-asd*
    10626     (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
    10627 
    10628   (defun directory-asd-files (directory)
    10629     (directory-files directory *wild-asd*))
    10630 
    10631   (defun collect-asds-in-directory (directory collect)
    10632     (let ((asds (directory-asd-files directory)))
    10633       (map () collect asds)
    10634       asds))
    10635 
    10636   (defvar *recurse-beyond-asds* t
    10637     "Should :tree entries of the source-registry recurse in subdirectories
    10638 after having found a .asd file? True by default.")
    10639 
    10640   ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
    10641   ;; read its contents instead of further recursively querying the filesystem.
    10642   (defun process-source-registry-cache (directory collect)
    10643     (let ((cache (ignore-errors
    10644                   (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
    10645       (when (and (listp cache) (eq :source-registry-cache (first cache)))
    10646         (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
    10647         t)))
    10648 
    10649   (defun collect-sub*directories-asd-files
    10650       (directory &key (exclude *default-source-registry-exclusions*) collect
    10651                    (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
    10652     (let ((visited (make-hash-table :test 'equalp)))
    10653       (flet ((collectp (dir)
    10654                (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
    10655                  (let ((asds (collect-asds-in-directory dir collect)))
    10656                    (or recurse-beyond-asds (not asds)))))
    10657              (recursep (x)                    ; x will be a directory pathname
    10658                (and
    10659                 (not (member (car (last (pathname-directory x))) exclude :test #'equal))
    10660                 (flet ((pathname-key (x)
    10661                          (namestring (truename* x))))
    10662                   (let ((visitedp (gethash (pathname-key x) visited)))
    10663                     (if visitedp nil
    10664                         (setf (gethash (pathname-key x) visited) t)))))))
    10665       (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
    10666 
    10667 
    10668   ;;; Validate the configuration forms
    10669 
    10670   (defun validate-source-registry-directive (directive)
    10671     (or (member directive '(:default-registry))
    10672         (and (consp directive)
    10673              (let ((rest (rest directive)))
    10674                (case (first directive)
    10675                  ((:include :directory :tree)
    10676                   (and (length=n-p rest 1)
    10677                        (location-designator-p (first rest))))
    10678                  ((:exclude :also-exclude)
    10679                   (every #'stringp rest))
    10680                  ((:default-registry)
    10681                   (null rest)))))))
    10682 
    10683   (defun validate-source-registry-form (form &key location)
    10684     (validate-configuration-form
    10685      form :source-registry 'validate-source-registry-directive
    10686           :location location :invalid-form-reporter 'invalid-source-registry))
    10687 
    10688   (defun validate-source-registry-file (file)
    10689     (validate-configuration-file
    10690      file 'validate-source-registry-form :description "a source registry"))
    10691 
    10692   (defun validate-source-registry-directory (directory)
    10693     (validate-configuration-directory
    10694      directory :source-registry 'validate-source-registry-directive
    10695                :invalid-form-reporter 'invalid-source-registry))
    10696 
    10697 
    10698   ;;; Parse the configuration string
    10699 
    10700   (defun parse-source-registry-string (string &key location)
    10701     (cond
    10702       ((or (null string) (equal string ""))
    10703        '(:source-registry :inherit-configuration))
    10704       ((not (stringp string))
    10705        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    10706       ((find (char string 0) "\"(")
    10707        (validate-source-registry-form (read-from-string string) :location location))
    10708       (t
    10709        (loop
    10710          :with inherit = nil
    10711          :with directives = ()
    10712          :with start = 0
    10713          :with end = (length string)
    10714          :with separator = (inter-directory-separator)
    10715          :for pos = (position separator string :start start) :do
    10716            (let ((s (subseq string start (or pos end))))
    10717              (flet ((check (dir)
    10718                       (unless (absolute-pathname-p dir)
    10719                         (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
    10720                       dir))
    10721                (cond
    10722                  ((equal "" s) ; empty element: inherit
    10723                   (when inherit
    10724                     (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    10725                            string))
    10726                   (setf inherit t)
    10727                   (push ':inherit-configuration directives))
    10728                  ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
    10729                   (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
    10730                  (t
    10731                   (push `(:directory ,(check s)) directives))))
    10732              (cond
    10733                (pos
    10734                 (setf start (1+ pos)))
    10735                (t
    10736                 (unless inherit
    10737                   (push '(:ignore-inherited-configuration) directives))
    10738                 (return `(:source-registry ,@(nreverse directives))))))))))
    10739 
    10740   (defun register-asd-directory (directory &key recurse exclude collect)
    10741     (if (not recurse)
    10742         (collect-asds-in-directory directory collect)
    10743         (collect-sub*directories-asd-files
    10744          directory :exclude exclude :collect collect)))
    10745 
    10746   (defparameter* *default-source-registries*
    10747     '(environment-source-registry
    10748       user-source-registry
    10749       user-source-registry-directory
    10750       default-user-source-registry
    10751       system-source-registry
    10752       system-source-registry-directory
    10753       default-system-source-registry)
    10754     "List of default source registries" "3.1.0.102")
    10755 
    10756   (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
    10757   (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
    10758 
    10759   (defun wrapping-source-registry ()
    10760     `(:source-registry
    10761       #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    10762       :inherit-configuration
    10763       #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
    10764       #+cmucl (:tree #p"modules:")
    10765       #+scl (:tree #p"file://modules/")))
    10766   (defun default-user-source-registry ()
    10767     `(:source-registry
    10768       (:tree (:home "common-lisp/"))
    10769       #+sbcl (:directory (:home ".sbcl/systems/"))
    10770       (:directory ,(xdg-data-home "common-lisp/systems/"))
    10771       (:tree ,(xdg-data-home "common-lisp/source/"))
    10772       :inherit-configuration))
    10773   (defun default-system-source-registry ()
    10774     `(:source-registry
    10775       ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
    10776               :collect `(:directory (,dir "systems/"))
    10777               :collect `(:tree (,dir "source/")))
    10778       :inherit-configuration))
    10779   (defun user-source-registry (&key (direction :input))
    10780     (xdg-config-pathname *source-registry-file* direction))
    10781   (defun system-source-registry (&key (direction :input))
    10782     (find-preferred-file (system-config-pathnames *source-registry-file*)
    10783                          :direction direction))
    10784   (defun user-source-registry-directory (&key (direction :input))
    10785     (xdg-config-pathname *source-registry-directory* direction))
    10786   (defun system-source-registry-directory (&key (direction :input))
    10787     (find-preferred-file (system-config-pathnames *source-registry-directory*)
    10788                          :direction direction))
    10789   (defun environment-source-registry ()
    10790     (getenv "CL_SOURCE_REGISTRY"))
    10791 
    10792 
    10793   ;;; Process the source-registry configuration
    10794 
    10795   (defgeneric* (process-source-registry) (spec &key inherit register))
    10796 
    10797   (defun* (inherit-source-registry) (inherit &key register)
    10798     (when inherit
    10799       (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    10800 
    10801   (defun* (process-source-registry-directive) (directive &key inherit register)
    10802     (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    10803       (ecase kw
    10804         ((:include)
    10805          (destructuring-bind (pathname) rest
    10806            (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    10807         ((:directory)
    10808          (destructuring-bind (pathname) rest
    10809            (when pathname
    10810              (funcall register (resolve-location pathname :ensure-directory t)))))
    10811         ((:tree)
    10812          (destructuring-bind (pathname) rest
    10813            (when pathname
    10814              (funcall register (resolve-location pathname :ensure-directory t)
    10815                       :recurse t :exclude *source-registry-exclusions*))))
    10816         ((:exclude)
    10817          (setf *source-registry-exclusions* rest))
    10818         ((:also-exclude)
    10819          (appendf *source-registry-exclusions* rest))
    10820         ((:default-registry)
    10821          (inherit-source-registry
    10822           '(default-user-source-registry default-system-source-registry) :register register))
    10823         ((:inherit-configuration)
    10824          (inherit-source-registry inherit :register register))
    10825         ((:ignore-inherited-configuration)
    10826          nil)))
    10827     nil)
    10828 
    10829   (defmethod process-source-registry ((x symbol) &key inherit register)
    10830     (process-source-registry (funcall x) :inherit inherit :register register))
    10831   (defmethod process-source-registry ((pathname pathname) &key inherit register)
    10832     (cond
    10833       ((directory-pathname-p pathname)
    10834        (let ((*here-directory* (resolve-symlinks* pathname)))
    10835          (process-source-registry (validate-source-registry-directory pathname)
    10836                                   :inherit inherit :register register)))
    10837       ((probe-file* pathname :truename *resolve-symlinks*)
    10838        (let ((*here-directory* (pathname-directory-pathname pathname)))
    10839          (process-source-registry (validate-source-registry-file pathname)
    10840                                   :inherit inherit :register register)))
    10841       (t
    10842        (inherit-source-registry inherit :register register))))
    10843   (defmethod process-source-registry ((string string) &key inherit register)
    10844     (process-source-registry (parse-source-registry-string string)
    10845                              :inherit inherit :register register))
    10846   (defmethod process-source-registry ((x null) &key inherit register)
    10847     (inherit-source-registry inherit :register register))
    10848   (defmethod process-source-registry ((form cons) &key inherit register)
    10849     (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    10850       (dolist (directive (cdr (validate-source-registry-form form)))
    10851         (process-source-registry-directive directive :inherit inherit :register register))))
    10852 
    10853 
    10854   ;; Flatten the user-provided configuration into an ordered list of directories and trees
    10855   (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
    10856     (remove-duplicates
    10857      (while-collecting (collect)
    10858        (with-pathname-defaults () ;; be location-independent
    10859          (inherit-source-registry
    10860           `(wrapping-source-registry
    10861             ,parameter
    10862             ,@*default-source-registries*)
    10863           :register #'(lambda (directory &key recurse exclude)
    10864                         (collect (list directory :recurse recurse :exclude exclude))))))
    10865      :test 'equal :from-end t))
    10866 
    10867   ;; Will read the configuration and initialize all internal variables.
    10868   (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
    10869                                     (registry *source-registry*))
    10870     (dolist (entry (flatten-source-registry parameter))
    10871       (destructuring-bind (directory &key recurse exclude) entry
    10872         (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    10873           (register-asd-directory
    10874            directory :recurse recurse :exclude exclude :collect
    10875            #'(lambda (asd)
    10876                (let* ((name (pathname-name asd))
    10877                       (name (if (typep asd 'logical-pathname)
    10878                                 ;; logical pathnames are upper-case,
    10879                                 ;; at least in the CLHS and on SBCL,
    10880                                 ;; yet (coerce-name :foo) is lower-case.
    10881                                 ;; won't work well with (load-system "Foo")
    10882                                 ;; instead of (load-system 'foo)
    10883                                 (string-downcase name)
    10884                                 name)))
    10885                  (cond
    10886                    ((gethash name registry) ; already shadowed by something else
    10887                     nil)
    10888                    ((gethash name h) ; conflict at current level
    10889                     (when *verbose-out*
    10890                       (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
    10891                                 found several entries for ~A - picking ~S over ~S~:>")
    10892                             directory recurse name (gethash name h) asd)))
    10893                    (t
    10894                     (setf (gethash name registry) asd)
    10895                     (setf (gethash name h) asd))))))
    10896           h)))
    10897     (values))
    10898 
    10899   (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
    10900     ;; Record the parameter used to configure the registry
    10901     (setf *source-registry-parameter* parameter)
    10902     ;; Clear the previous registry database:
    10903     (setf *source-registry* (make-hash-table :test 'equal))
    10904     ;; Do it!
    10905     (compute-source-registry parameter))
    10906 
    10907   ;; Checks an initial variable to see whether the state is initialized
    10908   ;; or cleared. In the former case, return current configuration; in
    10909   ;; the latter, initialize.  ASDF will call this function at the start
    10910   ;; of (asdf:find-system) to make sure the source registry is initialized.
    10911   ;; However, it will do so *without* a parameter, at which point it
    10912   ;; will be too late to provide a parameter to this function, though
    10913   ;; you may override the configuration explicitly by calling
    10914   ;; initialize-source-registry directly with your parameter.
    10915   (defun ensure-source-registry (&optional parameter)
    10916     (unless (source-registry-initialized-p)
    10917       (initialize-source-registry parameter))
    10918     (values))
    10919 
    10920   (defun sysdef-source-registry-search (system)
    10921     (ensure-source-registry)
    10922     (values (gethash (primary-system-name system) *source-registry*))))
    10923 
    1092410254
    1092510255;;;; -------------------------------------------------------------------------
     
    1133310663    (let* ((mono (operation-monolithic-p o))
    1133410664           (deps
    11335              (required-components
    11336               s :other-systems mono :component-type (if mono 'system '(not system))
    11337                 :goal-operation (find-operation o 'load-op)
    11338                 :keep-operation 'compile-op)))
    11339       ;; NB: the explicit make-operation on ECL and MKCL
    11340       ;; ensures that we drop the original-initargs and its magic flags when recursing.
     10665            ;; Required-components only looks at the dependencies of an action, excluding the action
     10666            ;; itself, so it may be safely used by an action recursing on its dependencies (which
     10667            ;; may or may not be an overdesigned API, since in practice we never use it that way).
     10668            ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
     10669            ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
     10670            ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
     10671            ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
     10672            ;; for our needs of gathering all the files we want to include in a bundle.
     10673            ;; Note that we use basic-compile-op rather than compile-op so it will still work on
     10674            ;; systems when *load-system-operation* is load-bundle-op.
     10675            (required-components
     10676             s :other-systems mono :component-type (if mono 'system '(not system))
     10677             :goal-operation 'load-op :keep-operation 'basic-compile-op)))
    1134110678      `((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps)
    1134210679        ,@(call-next-method))))
     
    1136810705a static runtime for your system, or a dynamic library to load in an existing runtime."))
    1136910706
     10707  ;; What works: On ECL (and CLASP?), we link the .a output of lib-op into a .so;
     10708  ;; on MKCL, we link the many .o files from the system directly into the .so;
     10709  ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
    1137010710  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
    1137110711                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-operation)
     
    1154810888           (operation-original-initargs instance))))
    1154910889
    11550   (defgeneric* (trivial-system-p) (component))
     10890  (defgeneric trivial-system-p (component))
    1155110891
    1155210892  (defun user-system-p (s)
     
    1172411064           (dependencies
    1172511065             (if (operation-monolithic-p o)
     11066                 ;; We want only dependencies, and we use basic-load-op rather than load-op so that
     11067                 ;; this will keep working on systems when *load-system-operation* is load-bundle-op
    1172611068                 (remove-if-not 'builtin-system-p
    1172711069                                (required-components s :component-type 'system
    11728                                                        :keep-operation 'load-op))
     11070                                                       :keep-operation 'basic-load-op))
    1172911071                 (while-collecting (x) ;; resolve the sideway-dependencies of s
    1173011072                   (map-direct-dependencies
     
    1173611078      (when (pathname-equal asd (system-source-file s))
    1173711079        (cerror "overwrite the asd file"
    11738                 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
     11080                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
     11081which is probably not what you want; you probably need to tweak your output translations."
    1173911082                (cons o s) asd))
    1174011083      (with-open-file (s asd :direction :output :if-exists :supersede
     
    1191711260          :with around-compile = (around-compile-hook s)
    1191811261          :with other-around-compile = '()
    11919           :for c :in (required-components
    11920                       s :goal-operation 'compile-op
    11921                         :keep-operation 'compile-op
     11262          :for c :in (required-components  ;; see note about similar call to required-components
     11263                      s :goal-operation 'load-op ;;  in bundle.lisp
     11264                        :keep-operation 'basic-compile-op
    1192211265                        :other-systems (operation-monolithic-p operation))
    1192311266          :append
     
    1195711300    (perform-lisp-load-fasl o s)))
    1195811301
     11302;;;; ---------------------------------------------------------------------------
     11303;;;; asdf-output-translations
     11304
     11305(uiop/package:define-package :asdf/output-translations
     11306  (:recycle :asdf/output-translations :asdf)
     11307  (:use :uiop/common-lisp :uiop :asdf/upgrade)
     11308  (:export
     11309   #:*output-translations* #:*output-translations-parameter*
     11310   #:invalid-output-translation
     11311   #:output-translations #:output-translations-initialized-p
     11312   #:initialize-output-translations #:clear-output-translations
     11313   #:disable-output-translations #:ensure-output-translations
     11314   #:apply-output-translations
     11315   #:validate-output-translations-directive #:validate-output-translations-form
     11316   #:validate-output-translations-file #:validate-output-translations-directory
     11317   #:parse-output-translations-string #:wrapping-output-translations
     11318   #:user-output-translations-pathname #:system-output-translations-pathname
     11319   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
     11320   #:environment-output-translations #:process-output-translations
     11321   #:compute-output-translations
     11322   #+abcl #:translate-jar-pathname
     11323   ))
     11324(in-package :asdf/output-translations)
     11325
     11326;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
     11327;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
     11328#-mkcl ; mkcl 1.1.9 can't fmakunbound a setf function.
     11329(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
     11330
     11331(with-upgradability ()
     11332  (define-condition invalid-output-translation (invalid-configuration warning)
     11333    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     11334
     11335  (defvar *output-translations* ()
     11336    "Either NIL (for uninitialized), or a list of one element,
     11337said element itself being a sorted list of mappings.
     11338Each mapping is a pair of a source pathname and destination pathname,
     11339and the order is by decreasing length of namestring of the source pathname.")
     11340
     11341  (defun output-translations ()
     11342    "Return the configured output-translations, if any"
     11343    (car *output-translations*))
     11344
     11345  ;; Set the output-translations, by sorting the provided new-value.
     11346  (defun set-output-translations (new-value)
     11347    (setf *output-translations*
     11348          (list
     11349           (stable-sort (copy-list new-value) #'>
     11350                        :key #'(lambda (x)
     11351                                 (etypecase (car x)
     11352                                   ((eql t) -1)
     11353                                   (pathname
     11354                                    (let ((directory
     11355                                           (normalize-pathname-directory-component
     11356                                            (pathname-directory (car x)))))
     11357                                      (if (listp directory) (length directory) 0))))))))
     11358    new-value)
     11359  (defun (setf output-translations) (new-value) (set-output-translations new-value))
     11360
     11361  (defun output-translations-initialized-p ()
     11362    "Have the output-translations been initialized yet?"
     11363    (and *output-translations* t))
     11364
     11365  (defun clear-output-translations ()
     11366    "Undoes any initialization of the output translations."
     11367    (setf *output-translations* '())
     11368    (values))
     11369  (register-clear-configuration-hook 'clear-output-translations)
     11370
     11371
     11372  ;;; Validation of the configuration directives...
     11373
     11374  (defun validate-output-translations-directive (directive)
     11375    (or (member directive '(:enable-user-cache :disable-cache nil))
     11376        (and (consp directive)
     11377             (or (and (length=n-p directive 2)
     11378                      (or (and (eq (first directive) :include)
     11379                               (typep (second directive) '(or string pathname null)))
     11380                          (and (location-designator-p (first directive))
     11381                               (or (location-designator-p (second directive))
     11382                                   (location-function-p (second directive))))))
     11383                 (and (length=n-p directive 1)
     11384                      (location-designator-p (first directive)))))))
     11385
     11386  (defun validate-output-translations-form (form &key location)
     11387    (validate-configuration-form
     11388     form
     11389     :output-translations
     11390     'validate-output-translations-directive
     11391     :location location :invalid-form-reporter 'invalid-output-translation))
     11392
     11393  (defun validate-output-translations-file (file)
     11394    (validate-configuration-file
     11395     file 'validate-output-translations-form :description "output translations"))
     11396
     11397  (defun validate-output-translations-directory (directory)
     11398    (validate-configuration-directory
     11399     directory :output-translations 'validate-output-translations-directive
     11400               :invalid-form-reporter 'invalid-output-translation))
     11401
     11402
     11403  ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
     11404  (defun parse-output-translations-string (string &key location)
     11405    (cond
     11406      ((or (null string) (equal string ""))
     11407       '(:output-translations :inherit-configuration))
     11408      ((not (stringp string))
     11409       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     11410      ((eql (char string 0) #\")
     11411       (parse-output-translations-string (read-from-string string) :location location))
     11412      ((eql (char string 0) #\()
     11413       (validate-output-translations-form (read-from-string string) :location location))
     11414      (t
     11415       (loop
     11416         :with inherit = nil
     11417         :with directives = ()
     11418         :with start = 0
     11419         :with end = (length string)
     11420         :with source = nil
     11421         :with separator = (inter-directory-separator)
     11422         :for i = (or (position separator string :start start) end) :do
     11423           (let ((s (subseq string start i)))
     11424             (cond
     11425               (source
     11426                (push (list source (if (equal "" s) nil s)) directives)
     11427                (setf source nil))
     11428               ((equal "" s)
     11429                (when inherit
     11430                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     11431                         string))
     11432                (setf inherit t)
     11433                (push :inherit-configuration directives))
     11434               (t
     11435                (setf source s)))
     11436             (setf start (1+ i))
     11437             (when (> start end)
     11438               (when source
     11439                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
     11440                        string))
     11441               (unless inherit
     11442                 (push :ignore-inherited-configuration directives))
     11443               (return `(:output-translations ,@(nreverse directives)))))))))
     11444
     11445
     11446  ;; The default sources of configuration for output-translations
     11447  (defparameter* *default-output-translations*
     11448    '(environment-output-translations
     11449      user-output-translations-pathname
     11450      user-output-translations-directory-pathname
     11451      system-output-translations-pathname
     11452      system-output-translations-directory-pathname))
     11453
     11454  ;; Compulsory implementation-dependent wrapping for the translations:
     11455  ;; handle implementation-provided systems.
     11456  (defun wrapping-output-translations ()
     11457    `(:output-translations
     11458    ;; Some implementations have precompiled ASDF systems,
     11459    ;; so we must disable translations for implementation paths.
     11460      #+(or clasp #|clozure|# ecl mkcl sbcl)
     11461      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
     11462          (when h `(((,h ,*wild-path*) ()))))
     11463      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
     11464      ;; All-import, here is where we want user stuff to be:
     11465      :inherit-configuration
     11466      ;; These are for convenience, and can be overridden by the user:
     11467      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     11468      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     11469      ;; We enable the user cache by default, and here is the place we do:
     11470      :enable-user-cache))
     11471
     11472  ;; Relative pathnames of output-translations configuration to XDG configuration directory
     11473  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
     11474  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
     11475
     11476  ;; Locating various configuration pathnames, depending on input or output intent.
     11477  (defun user-output-translations-pathname (&key (direction :input))
     11478    (xdg-config-pathname *output-translations-file* direction))
     11479  (defun system-output-translations-pathname (&key (direction :input))
     11480    (find-preferred-file (system-config-pathnames *output-translations-file*)
     11481                         :direction direction))
     11482  (defun user-output-translations-directory-pathname (&key (direction :input))
     11483    (xdg-config-pathname *output-translations-directory* direction))
     11484  (defun system-output-translations-directory-pathname (&key (direction :input))
     11485    (find-preferred-file (system-config-pathnames *output-translations-directory*)
     11486                         :direction direction))
     11487  (defun environment-output-translations ()
     11488    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     11489
     11490
     11491  ;;; Processing the configuration.
     11492
     11493  (defgeneric process-output-translations (spec &key inherit collect))
     11494
     11495  (defun inherit-output-translations (inherit &key collect)
     11496    (when inherit
     11497      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     11498
     11499  (defun* (process-output-translations-directive) (directive &key inherit collect)
     11500    (if (atom directive)
     11501        (ecase directive
     11502          ((:enable-user-cache)
     11503           (process-output-translations-directive '(t :user-cache) :collect collect))
     11504          ((:disable-cache)
     11505           (process-output-translations-directive '(t t) :collect collect))
     11506          ((:inherit-configuration)
     11507           (inherit-output-translations inherit :collect collect))
     11508          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
     11509           nil))
     11510        (let ((src (first directive))
     11511              (dst (second directive)))
     11512          (if (eq src :include)
     11513              (when dst
     11514                (process-output-translations (pathname dst) :inherit nil :collect collect))
     11515              (when src
     11516                (let ((trusrc (or (eql src t)
     11517                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
     11518                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
     11519                  (cond
     11520                    ((location-function-p dst)
     11521                     (funcall collect
     11522                              (list trusrc (ensure-function (second dst)))))
     11523                    ((typep dst 'boolean)
     11524                     (funcall collect (list trusrc t)))
     11525                    (t
     11526                     (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
     11527                       (funcall collect (list trudst t))
     11528                       (funcall collect (list trusrc trudst)))))))))))
     11529
     11530  (defmethod process-output-translations ((x symbol) &key
     11531                                                       (inherit *default-output-translations*)
     11532                                                       collect)
     11533    (process-output-translations (funcall x) :inherit inherit :collect collect))
     11534  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
     11535    (cond
     11536      ((directory-pathname-p pathname)
     11537       (process-output-translations (validate-output-translations-directory pathname)
     11538                                    :inherit inherit :collect collect))
     11539      ((probe-file* pathname :truename *resolve-symlinks*)
     11540       (process-output-translations (validate-output-translations-file pathname)
     11541                                    :inherit inherit :collect collect))
     11542      (t
     11543       (inherit-output-translations inherit :collect collect))))
     11544  (defmethod process-output-translations ((string string) &key inherit collect)
     11545    (process-output-translations (parse-output-translations-string string)
     11546                                 :inherit inherit :collect collect))
     11547  (defmethod process-output-translations ((x null) &key inherit collect)
     11548    (inherit-output-translations inherit :collect collect))
     11549  (defmethod process-output-translations ((form cons) &key inherit collect)
     11550    (dolist (directive (cdr (validate-output-translations-form form)))
     11551      (process-output-translations-directive directive :inherit inherit :collect collect)))
     11552
     11553
     11554  ;;; Top-level entry-points to configure output-translations
     11555
     11556  (defun compute-output-translations (&optional parameter)
     11557    "read the configuration, return it"
     11558    (remove-duplicates
     11559     (while-collecting (c)
     11560       (inherit-output-translations
     11561        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     11562     :test 'equal :from-end t))
     11563
     11564  ;; Saving the user-provided parameter to output-translations, if any,
     11565  ;; so we can recompute the translations after code upgrade.
     11566  (defvar *output-translations-parameter* nil)
     11567
     11568  ;; Main entry-point for users.
     11569  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
     11570    "read the configuration, initialize the internal configuration variable,
     11571return the configuration"
     11572    (setf *output-translations-parameter* parameter
     11573          (output-translations) (compute-output-translations parameter)))
     11574
     11575  (defun disable-output-translations ()
     11576    "Initialize output translations in a way that maps every file to itself,
     11577effectively disabling the output translation facility."
     11578    (initialize-output-translations
     11579     '(:output-translations :disable-cache :ignore-inherited-configuration)))
     11580
     11581  ;; checks an initial variable to see whether the state is initialized
     11582  ;; or cleared. In the former case, return current configuration; in
     11583  ;; the latter, initialize.  ASDF will call this function at the start
     11584  ;; of (asdf:find-system).
     11585  (defun ensure-output-translations ()
     11586    (if (output-translations-initialized-p)
     11587        (output-translations)
     11588        (initialize-output-translations)))
     11589
     11590
     11591  ;; Top-level entry-point to _use_ output-translations
     11592  (defun* (apply-output-translations) (path)
     11593    (etypecase path
     11594      (logical-pathname
     11595       path)
     11596      ((or pathname string)
     11597       (ensure-output-translations)
     11598       (loop* :with p = (resolve-symlinks* path)
     11599              :for (source destination) :in (car *output-translations*)
     11600              :for root = (when (or (eq source t)
     11601                                    (and (pathnamep source)
     11602                                         (not (absolute-pathname-p source))))
     11603                            (pathname-root p))
     11604              :for absolute-source = (cond
     11605                                       ((eq source t) (wilden root))
     11606                                       (root (merge-pathnames* source root))
     11607                                       (t source))
     11608              :when (or (eq source t) (pathname-match-p p absolute-source))
     11609              :return (translate-pathname* p absolute-source destination root source)
     11610              :finally (return p)))))
     11611
     11612
     11613  ;; Hook into uiop's output-translation mechanism
     11614  #-cormanlisp
     11615  (setf *output-translation-function* 'apply-output-translations)
     11616
     11617
     11618  ;;; Implementation-dependent hacks
     11619  #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
     11620  (defun translate-jar-pathname (source wildcard)
     11621    (declare (ignore wildcard))
     11622    (flet ((normalize-device (pathname)
     11623             (if (find :windows *features*)
     11624                 pathname
     11625                 (make-pathname :defaults pathname :device :unspecific))))
     11626      (let* ((jar
     11627               (pathname (first (pathname-device source))))
     11628             (target-root-directory-namestring
     11629               (format nil "/___jar___file___root___/~@[~A/~]"
     11630                       (and (find :windows *features*)
     11631                            (pathname-device jar))))
     11632             (relative-source
     11633               (relativize-pathname-directory source))
     11634             (relative-jar
     11635               (relativize-pathname-directory (ensure-directory-pathname jar)))
     11636             (target-root-directory
     11637               (normalize-device
     11638                (pathname-directory-pathname
     11639                 (parse-namestring target-root-directory-namestring))))
     11640             (target-root
     11641               (merge-pathnames* relative-jar target-root-directory))
     11642             (target
     11643               (merge-pathnames* relative-source target-root)))
     11644        (normalize-device (apply-output-translations target))))))
     11645
     11646;;;; -----------------------------------------------------------------
     11647;;;; Source Registry Configuration, by Francois-Rene Rideau
     11648;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     11649
     11650(uiop/package:define-package :asdf/source-registry
     11651  (:recycle :asdf/source-registry :asdf)
     11652  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     11653  (:export
     11654   #:*source-registry-parameter* #:*default-source-registries*
     11655   #:invalid-source-registry
     11656   #:source-registry-initialized-p
     11657   #:initialize-source-registry #:clear-source-registry #:*source-registry*
     11658   #:ensure-source-registry #:*source-registry-parameter*
     11659   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
     11660   #:*wild-asd* #:directory-asd-files #:register-asd-directory
     11661   #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
     11662   #:validate-source-registry-directive #:validate-source-registry-form
     11663   #:validate-source-registry-file #:validate-source-registry-directory
     11664   #:parse-source-registry-string #:wrapping-source-registry
     11665   #:default-user-source-registry #:default-system-source-registry
     11666   #:user-source-registry #:system-source-registry
     11667   #:user-source-registry-directory #:system-source-registry-directory
     11668   #:environment-source-registry #:process-source-registry #:inherit-source-registry
     11669   #:compute-source-registry #:flatten-source-registry
     11670   #:sysdef-source-registry-search))
     11671(in-package :asdf/source-registry)
     11672
     11673(with-upgradability ()
     11674  (define-condition invalid-source-registry (invalid-configuration warning)
     11675    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     11676
     11677  ;; Default list of directories under which the source-registry tree search won't recurse
     11678  (defvar *default-source-registry-exclusions*
     11679    '(;;-- Using ack 1.2 exclusions
     11680      ".bzr" ".cdv"
     11681      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     11682      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     11683      "_sgbak" "autom4te.cache" "cover_db" "_build"
     11684      ;;-- debian often builds stuff under the debian directory... BAD.
     11685      "debian"))
     11686
     11687  ;; Actual list of directories under which the source-registry tree search won't recurse
     11688  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     11689
     11690  ;; The state of the source-registry after search in configured locations
     11691  (defvar *source-registry* nil
     11692    "Either NIL (for uninitialized), or an equal hash-table, mapping
     11693system names to pathnames of .asd files")
     11694
     11695  ;; Saving the user-provided parameter to the source-registry, if any,
     11696  ;; so we can recompute the source-registry after code upgrade.
     11697  (defvar *source-registry-parameter* nil)
     11698
     11699  (defun source-registry-initialized-p ()
     11700    (typep *source-registry* 'hash-table))
     11701
     11702  (defun clear-source-registry ()
     11703    "Undoes any initialization of the source registry."
     11704    (setf *source-registry* nil)
     11705    (values))
     11706  (register-clear-configuration-hook 'clear-source-registry)
     11707
     11708  (defparameter *wild-asd*
     11709    (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
     11710
     11711  (defun directory-asd-files (directory)
     11712    (directory-files directory *wild-asd*))
     11713
     11714  (defun collect-asds-in-directory (directory collect)
     11715    (let ((asds (directory-asd-files directory)))
     11716      (map () collect asds)
     11717      asds))
     11718
     11719  (defvar *recurse-beyond-asds* t
     11720    "Should :tree entries of the source-registry recurse in subdirectories
     11721after having found a .asd file? True by default.")
     11722
     11723  ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
     11724  ;; read its contents instead of further recursively querying the filesystem.
     11725  (defun process-source-registry-cache (directory collect)
     11726    (let ((cache (ignore-errors
     11727                  (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
     11728      (when (and (listp cache) (eq :source-registry-cache (first cache)))
     11729        (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
     11730        t)))
     11731
     11732  (defun collect-sub*directories-asd-files
     11733      (directory &key (exclude *default-source-registry-exclusions*) collect
     11734                   (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
     11735    (let ((visited (make-hash-table :test 'equalp)))
     11736      (flet ((collectp (dir)
     11737               (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
     11738                 (let ((asds (collect-asds-in-directory dir collect)))
     11739                   (or recurse-beyond-asds (not asds)))))
     11740             (recursep (x)                    ; x will be a directory pathname
     11741               (and
     11742                (not (member (car (last (pathname-directory x))) exclude :test #'equal))
     11743                (flet ((pathname-key (x)
     11744                         (namestring (truename* x))))
     11745                  (let ((visitedp (gethash (pathname-key x) visited)))
     11746                    (if visitedp nil
     11747                        (setf (gethash (pathname-key x) visited) t)))))))
     11748      (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
     11749
     11750
     11751  ;;; Validate the configuration forms
     11752
     11753  (defun validate-source-registry-directive (directive)
     11754    (or (member directive '(:default-registry))
     11755        (and (consp directive)
     11756             (let ((rest (rest directive)))
     11757               (case (first directive)
     11758                 ((:include :directory :tree)
     11759                  (and (length=n-p rest 1)
     11760                       (location-designator-p (first rest))))
     11761                 ((:exclude :also-exclude)
     11762                  (every #'stringp rest))
     11763                 ((:default-registry)
     11764                  (null rest)))))))
     11765
     11766  (defun validate-source-registry-form (form &key location)
     11767    (validate-configuration-form
     11768     form :source-registry 'validate-source-registry-directive
     11769          :location location :invalid-form-reporter 'invalid-source-registry))
     11770
     11771  (defun validate-source-registry-file (file)
     11772    (validate-configuration-file
     11773     file 'validate-source-registry-form :description "a source registry"))
     11774
     11775  (defun validate-source-registry-directory (directory)
     11776    (validate-configuration-directory
     11777     directory :source-registry 'validate-source-registry-directive
     11778               :invalid-form-reporter 'invalid-source-registry))
     11779
     11780
     11781  ;;; Parse the configuration string
     11782
     11783  (defun parse-source-registry-string (string &key location)
     11784    (cond
     11785      ((or (null string) (equal string ""))
     11786       '(:source-registry :inherit-configuration))
     11787      ((not (stringp string))
     11788       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     11789      ((find (char string 0) "\"(")
     11790       (validate-source-registry-form (read-from-string string) :location location))
     11791      (t
     11792       (loop
     11793         :with inherit = nil
     11794         :with directives = ()
     11795         :with start = 0
     11796         :with end = (length string)
     11797         :with separator = (inter-directory-separator)
     11798         :for pos = (position separator string :start start) :do
     11799           (let ((s (subseq string start (or pos end))))
     11800             (flet ((check (dir)
     11801                      (unless (absolute-pathname-p dir)
     11802                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     11803                      dir))
     11804               (cond
     11805                 ((equal "" s) ; empty element: inherit
     11806                  (when inherit
     11807                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     11808                           string))
     11809                  (setf inherit t)
     11810                  (push ':inherit-configuration directives))
     11811                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
     11812                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     11813                 (t
     11814                  (push `(:directory ,(check s)) directives))))
     11815             (cond
     11816               (pos
     11817                (setf start (1+ pos)))
     11818               (t
     11819                (unless inherit
     11820                  (push '(:ignore-inherited-configuration) directives))
     11821                (return `(:source-registry ,@(nreverse directives))))))))))
     11822
     11823  (defun register-asd-directory (directory &key recurse exclude collect)
     11824    (if (not recurse)
     11825        (collect-asds-in-directory directory collect)
     11826        (collect-sub*directories-asd-files
     11827         directory :exclude exclude :collect collect)))
     11828
     11829  (defparameter* *default-source-registries*
     11830    '(environment-source-registry
     11831      user-source-registry
     11832      user-source-registry-directory
     11833      default-user-source-registry
     11834      system-source-registry
     11835      system-source-registry-directory
     11836      default-system-source-registry)
     11837    "List of default source registries" "3.1.0.102")
     11838
     11839  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
     11840  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
     11841
     11842  (defun wrapping-source-registry ()
     11843    `(:source-registry
     11844      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
     11845      :inherit-configuration
     11846      #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
     11847      #+cmucl (:tree #p"modules:")
     11848      #+scl (:tree #p"file://modules/")))
     11849  (defun default-user-source-registry ()
     11850    `(:source-registry
     11851      (:tree (:home "common-lisp/"))
     11852      #+sbcl (:directory (:home ".sbcl/systems/"))
     11853      (:directory ,(xdg-data-home "common-lisp/systems/"))
     11854      (:tree ,(xdg-data-home "common-lisp/source/"))
     11855      :inherit-configuration))
     11856  (defun default-system-source-registry ()
     11857    `(:source-registry
     11858      ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
     11859              :collect `(:directory (,dir "systems/"))
     11860              :collect `(:tree (,dir "source/")))
     11861      :inherit-configuration))
     11862  (defun user-source-registry (&key (direction :input))
     11863    (xdg-config-pathname *source-registry-file* direction))
     11864  (defun system-source-registry (&key (direction :input))
     11865    (find-preferred-file (system-config-pathnames *source-registry-file*)
     11866                         :direction direction))
     11867  (defun user-source-registry-directory (&key (direction :input))
     11868    (xdg-config-pathname *source-registry-directory* direction))
     11869  (defun system-source-registry-directory (&key (direction :input))
     11870    (find-preferred-file (system-config-pathnames *source-registry-directory*)
     11871                         :direction direction))
     11872  (defun environment-source-registry ()
     11873    (getenv "CL_SOURCE_REGISTRY"))
     11874
     11875
     11876  ;;; Process the source-registry configuration
     11877
     11878  (defgeneric process-source-registry (spec &key inherit register))
     11879
     11880  (defun* (inherit-source-registry) (inherit &key register)
     11881    (when inherit
     11882      (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     11883
     11884  (defun* (process-source-registry-directive) (directive &key inherit register)
     11885    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     11886      (ecase kw
     11887        ((:include)
     11888         (destructuring-bind (pathname) rest
     11889           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
     11890        ((:directory)
     11891         (destructuring-bind (pathname) rest
     11892           (when pathname
     11893             (funcall register (resolve-location pathname :ensure-directory t)))))
     11894        ((:tree)
     11895         (destructuring-bind (pathname) rest
     11896           (when pathname
     11897             (funcall register (resolve-location pathname :ensure-directory t)
     11898                      :recurse t :exclude *source-registry-exclusions*))))
     11899        ((:exclude)
     11900         (setf *source-registry-exclusions* rest))
     11901        ((:also-exclude)
     11902         (appendf *source-registry-exclusions* rest))
     11903        ((:default-registry)
     11904         (inherit-source-registry
     11905          '(default-user-source-registry default-system-source-registry) :register register))
     11906        ((:inherit-configuration)
     11907         (inherit-source-registry inherit :register register))
     11908        ((:ignore-inherited-configuration)
     11909         nil)))
     11910    nil)
     11911
     11912  (defmethod process-source-registry ((x symbol) &key inherit register)
     11913    (process-source-registry (funcall x) :inherit inherit :register register))
     11914  (defmethod process-source-registry ((pathname pathname) &key inherit register)
     11915    (cond
     11916      ((directory-pathname-p pathname)
     11917       (let ((*here-directory* (resolve-symlinks* pathname)))
     11918         (process-source-registry (validate-source-registry-directory pathname)
     11919                                  :inherit inherit :register register)))
     11920      ((probe-file* pathname :truename *resolve-symlinks*)
     11921       (let ((*here-directory* (pathname-directory-pathname pathname)))
     11922         (process-source-registry (validate-source-registry-file pathname)
     11923                                  :inherit inherit :register register)))
     11924      (t
     11925       (inherit-source-registry inherit :register register))))
     11926  (defmethod process-source-registry ((string string) &key inherit register)
     11927    (process-source-registry (parse-source-registry-string string)
     11928                             :inherit inherit :register register))
     11929  (defmethod process-source-registry ((x null) &key inherit register)
     11930    (inherit-source-registry inherit :register register))
     11931  (defmethod process-source-registry ((form cons) &key inherit register)
     11932    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
     11933      (dolist (directive (cdr (validate-source-registry-form form)))
     11934        (process-source-registry-directive directive :inherit inherit :register register))))
     11935
     11936
     11937  ;; Flatten the user-provided configuration into an ordered list of directories and trees
     11938  (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
     11939    (remove-duplicates
     11940     (while-collecting (collect)
     11941       (with-pathname-defaults () ;; be location-independent
     11942         (inherit-source-registry
     11943          `(wrapping-source-registry
     11944            ,parameter
     11945            ,@*default-source-registries*)
     11946          :register #'(lambda (directory &key recurse exclude)
     11947                        (collect (list directory :recurse recurse :exclude exclude))))))
     11948     :test 'equal :from-end t))
     11949
     11950  ;; Will read the configuration and initialize all internal variables.
     11951  (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
     11952                                    (registry *source-registry*))
     11953    (dolist (entry (flatten-source-registry parameter))
     11954      (destructuring-bind (directory &key recurse exclude) entry
     11955        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
     11956          (register-asd-directory
     11957           directory :recurse recurse :exclude exclude :collect
     11958           #'(lambda (asd)
     11959               (let* ((name (pathname-name asd))
     11960                      (name (if (typep asd 'logical-pathname)
     11961                                ;; logical pathnames are upper-case,
     11962                                ;; at least in the CLHS and on SBCL,
     11963                                ;; yet (coerce-name :foo) is lower-case.
     11964                                ;; won't work well with (load-system "Foo")
     11965                                ;; instead of (load-system 'foo)
     11966                                (string-downcase name)
     11967                                name)))
     11968                 (cond
     11969                   ((gethash name registry) ; already shadowed by something else
     11970                    nil)
     11971                   ((gethash name h) ; conflict at current level
     11972                    (when *verbose-out*
     11973                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     11974                                found several entries for ~A - picking ~S over ~S~:>")
     11975                            directory recurse name (gethash name h) asd)))
     11976                   (t
     11977                    (setf (gethash name registry) asd)
     11978                    (setf (gethash name h) asd))))))
     11979          h)))
     11980    (values))
     11981
     11982  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
     11983    ;; Record the parameter used to configure the registry
     11984    (setf *source-registry-parameter* parameter)
     11985    ;; Clear the previous registry database:
     11986    (setf *source-registry* (make-hash-table :test 'equal))
     11987    ;; Do it!
     11988    (compute-source-registry parameter))
     11989
     11990  ;; Checks an initial variable to see whether the state is initialized
     11991  ;; or cleared. In the former case, return current configuration; in
     11992  ;; the latter, initialize.  ASDF will call this function at the start
     11993  ;; of (asdf:find-system) to make sure the source registry is initialized.
     11994  ;; However, it will do so *without* a parameter, at which point it
     11995  ;; will be too late to provide a parameter to this function, though
     11996  ;; you may override the configuration explicitly by calling
     11997  ;; initialize-source-registry directly with your parameter.
     11998  (defun ensure-source-registry (&optional parameter)
     11999    (unless (source-registry-initialized-p)
     12000      (initialize-source-registry parameter))
     12001    (values))
     12002
     12003  (defun sysdef-source-registry-search (system)
     12004    (ensure-source-registry)
     12005    (values (gethash (primary-system-name system) *source-registry*))))
     12006
     12007
    1195912008;;;; -------------------------------------------------------------------------
    1196012009;;;; Package systems in the style of quick-build or faslpath
     
    1205312102otherwise return a default system name computed from PACKAGE-NAME."
    1205412103    (check-type package-name string)
    12055     (if-let ((system-name (gethash package-name *package-inferred-systems*)))
    12056       system-name
    12057       (string-downcase package-name)))
     12104    (or (gethash package-name *package-inferred-systems*)
     12105        (string-downcase package-name)))
    1205812106
    1205912107  ;; Given a file in package-inferred-system style, find its dependencies
     
    1210912157                *system-definition-search-functions*)))
    1211012158;;;; -------------------------------------------------------------------------
    12111 ;;; Internal hacks for backward-compatibility
    12112 
    12113 (uiop/package:define-package :asdf/backward-internals
    12114   (:recycle :asdf/backward-internals :asdf)
    12115   (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
    12116   (:export #:load-sysdef))
    12117 (in-package :asdf/backward-internals)
    12118 
    12119 (with-upgradability ()
    12120   (defun load-sysdef (name pathname)
    12121     (declare (ignore name pathname))
    12122     ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
    12123     (error "Use asdf:load-asd instead of asdf::load-sysdef")))
    12124 ;;;; -------------------------------------------------------------------------
    1212512159;;; Backward-compatible interfaces
    1212612160
     
    1213612170   #:component-load-dependencies
    1213712171   #:enable-asdf-binary-locations-compatibility
    12138    #:operation-forced
    1213912172   #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
    1214012173   #:component-property
     
    1216412197    ;; Old deprecated name for the same thing. Please update your software.
    1216512198    (component-sideway-dependencies component))
    12166 
    12167   (defgeneric operation-forced (operation)
    12168     (:documentation "DEPRECATED. Assume it's (constantly t) instead."))
    12169   ;; This method exists for backward compatibility with swank.asd, its only user,
    12170   ;; that still uses it as of 2016-09-21.
    12171   ;;
    12172   ;; The magic PERFORM method in swank.asd only actually loads swank if it sees that
    12173   ;; the operation was forced. But except for the first time, the only reason the action
    12174   ;; would be performed to begin with is because it was forced; and the first time over,
    12175   ;; it doesn't hurt that :reload t :delete t should be used. So the check is redundant.
    12176   ;; More generally, if you have to do something when the operation was forced,
    12177   ;; you should also do it when not, and vice-versa, because it really shouldn't matter.
    12178   ;; Thus, the backward-compatible thing to do is to always return T.
    12179   (defmethod operation-forced ((o operation)) t)
    12180 
    1218112199
    1218212200  ;; These old interfaces from ASDF1 have never been very meaningful
     
    1221412232  ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
    1221512233  ;; It was never officially exposed but some people still used it.
    12216   (defgeneric* (traverse) (operation component &key &allow-other-keys)
     12234  (defgeneric traverse (operation component &key &allow-other-keys)
    1221712235    (:documentation
    1221812236     "Generate and return a plan for performing OPERATION on COMPONENT.
     
    1232912347;;; This method survives from ASDF 1, but really it is superseded by action-description.
    1233012348(with-upgradability ()
    12331   (defgeneric* (explain) (operation component)
     12349  (defgeneric explain (operation component)
    1233212350    (:documentation "Display a message describing an action.
    1233312351DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
     
    1233712355
    1233812356
     12357;;;; -------------------------------------------------------------------------
     12358;;; Internal hacks for backward-compatibility
     12359
     12360(uiop/package:define-package :asdf/backward-internals
     12361  (:recycle :asdf/backward-internals :asdf)
     12362  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     12363  (:export #:load-sysdef))
     12364(in-package :asdf/backward-internals)
     12365
     12366(with-upgradability ()
     12367  (defun load-sysdef (name pathname)
     12368    (declare (ignore name pathname))
     12369    ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
     12370    (error "Use asdf:load-asd instead of asdf::load-sysdef")))
    1233912371;;;; ---------------------------------------------------------------------------
    1234012372;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    1255212584  ;; Hook into CL:REQUIRE.
    1255312585  #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
    12554   #+clisp (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
     12586  #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil))
    1255512587            (eval `(pushnew 'module-provide-asdf ,x)))
    1255612588
Note: See TracChangeset for help on using the changeset viewer.