Changeset 14873

09/26/16 21:26:36 (6 years ago)
Mark Evenson

asdf: update to

2 edited


  • trunk/abcl/doc/asdf/asdf.texinfo

    r14856 r14873  
    6767@title ASDF: Another System Definition Facility
    68 @subtitle Manual for Version
     68@subtitle Manual for Version
    6969@c The following two commands start the copyright page.
    8383@top ASDF: Another System Definition Facility
    85 Manual for Version
     85Manual for Version
    8686@end ifnottex
    42344234@section Shell-friendly syntax for configuration
    4236 When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS}
    4237 ASDF will skip to the next configuration if it's an empty string.
    4238 It will @code{READ} the string as an SEXP in the DSL
    4239 if it begins with a paren @code{(}
    4240 and it will be interpreted as a list of directories.
    4241 Directories should come by pairs, indicating a mapping directive.
     4236When processing the environment variable
     4239@item ASDF will skip to the next configuration if it's an empty string.
     4240@item ASDF will @code{READ} the string as an SEXP in the DSL, if it
     4241begins with a parenthesis @code{(}.
     4242@item Otherwise ASDF will interpret the value as a list of directories
     4243(see below).
     4244@end itemize
     4246In the directory list format,
     4247directories should come in pairs, each pair indicating a mapping directive.
    42424248Entries are separated
    4243 by a @code{:} (colon) on Unix platforms (including cygwin),
     4249by a @code{:} (colon) on Unix platforms (including Mac and cygwin), and
    42444250by a @code{;} (semicolon) on other platforms (mainly, Windows).
    42464252The magic empty entry,
    42474253if it comes in what would otherwise be the first entry in a pair,
    4248 indicates the splicing of inherited configuration.
    4249 If it comes as the second entry in a pair,
    4250 it indicates that the directory specified first is to be left untranslated
     4254indicates the splicing of inherited configuration;
     4255the next entry (if any) then starts a new pair.
     4256If the second entry in a pair is empty,
     4257it indicates that the directory in the first entry is to be left untranslated
    42514258(which has the same effect as if the directory had been repeated).
    4252 Thus @code{"/foo:/bar::/baz:"} means that
    4253 things under directory @file{/foo/}
    4254 are translated to be under @file{/bar/},
    4255 then include the inherited configuration,
    4256 then specify that things under directory @file{/baz/} are not translated.
     4260For example, @code{"/foo:/bar::/baz:"} means:
     4261specify that outputs for things under directory @file{/foo/}
     4262are translated to be under @file{/bar/};
     4263then include the inherited configuration;
     4264then specify that outputs for things under directory @file{/baz/} are not translated.
    42584267@node Semantics of Output Translations, Output Caching Results, Output Shell-friendly syntax for configuration, Controlling where ASDF saves compiled files
    47094718@end defun
    4711 @defun register-preloaded-system name @Arest{} keys
     4720@defun register-preloaded-system name @Arest{} keys @Akey{} version @AallowOtherKeys{}
    47124721A system with name @var{name},
    47134722created by @code{make-instance} with extra keys @var{keys}
    47144723(e.g. @code{:version}),
    47154724is registered as @emph{preloaded}.
    4716 That is, its code has already been loaded into the current image,
     4725If @var{version} is @code{t} (default), then the version is copied from the defined system
     4726of the same name (if registered) or else is @code{nil}
     4727(this automatic copy of version is only available starting since ASDF 3.1.8).
     4729A preloaded system is considered as having already been loaded into the current image,
    47174730and if at some point some other system @code{:depends-on} it yet no source code is found,
    47184731it is considered as already provided,
    47234736and want to register systems so that dependencies will work uniformly
    47244737whether you're using your software from source or from fasl.
     4739Note that if the system was already defined or loaded from source code,
     4740its build information will remain active until you call @code{clear-system} on it,
     4741at which point a system without build information will be registered in its place.
    47254742@end defun
    47274744@defun register-immutable-system name @Arest{} keys
    4728 A system with name @var{name},
    4729 created by @code{make-instance} with extra keys @var{keys}
    4730 (e.g. @code{:version}),
    4731 is registered as @emph{immutable}.
    4732 That is, its code has already been loaded into the current image,
    4733 and if at some point some other system @code{:depends-on} it,
    4734 it is considered as already provided, and
    4735 no attempt will be made to search for an updated version from the source-registry
    4736 or any other method.
    4737 There will be no search for an @file{.asd} file, and no @code{missing-component} error.
    4739 This function (available since ASDF 3.1.5) is particularly useful if
    4740 you distribute a large body of code as a precompiled image,
     4745A system with name @var{name} is registered as preloaded,
     4746and additionally is marked as @emph{immutable}:
     4747that is, attempts to compile or load it will be succeed
     4748without actually reading, creating or loading any file,
     4749as if the system was passed as a @code{force-not} argument
     4750to all calls to @code{plan} or @code{operate}.
     4751There will be no search for an updated @file{.asd} file
     4752to override the loaded version,
     4753whether from the source-register or any other method.
     4755If a @var{version} keyword argument is specified as @code{t} or left unspecified,
     4756then the version is copied from the defined system
     4757of the same name (if registered) or else is @code{nil}.
     4758This automatic copy of version is available starting
     4759since immutable systems have been available in ASDF 3.1.5.
     4761This function, available since ASDF 3.1.5, is particularly useful
     4762if you distribute a large body of code as a precompiled image,
    47414763and want to allow users to extend the image with further extension systems,
    4742 but without making thousands of filesystem requests looking for inexistent (or worse, out of date) source code
     4764but without making thousands of filesystem requests looking for inexistent
     4765(or worse, out of date) source code
    47434766for all the systems that came bundled with the image but aren't
    47444767distributed as source code to regular users.
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14856 r14873  
    11;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF Another System Definition Facility.
     2;;; This is ASDF Another System Definition Facility.
    44;;; Feedback, bug reports, and patches are all welcome:
    4646;;; we can't use defsystem to compile it.  Hence, all in one file.
    48 #+xcvb (module ())
    4948;;;; ---------------------------------------------------------------------------
    5049;;;; Handle ASDF package upgrade, including implementation-dependent magic.
    817816;;;; Early meta-level tweaks
    819 #+(or allegro clasp clisp cmucl ecl mkcl mkcl sbcl)
     818#+(or allegro clasp clisp clozure cmucl ecl mkcl sbcl)
    820819(eval-when (:load-toplevel :compile-toplevel :execute)
    821820  (when (and #+allegro (member :ics *features*)
    822821             #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*)
     822             #+clozure (member :openmcl-unicode-strings *features*)
    823823             #+sbcl (member :sb-unicode *features*))
    824824    ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
    10361036   #:ensure-function #:access-at #:access-at-count ;; functions
    10371037   #:call-function #:call-functions #:register-hook-function
     1038   #:lexicographic< #:lexicographic<= ;; version
     1039   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p
    10381040   #:match-condition-p #:match-any-condition-p ;; conditions
    10391041   #:call-with-muffled-conditions #:with-muffled-conditions
    1040    #:lexicographic< #:lexicographic<=
    1041    #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
     1042   #:not-implemented-error #:parameter-error))
    10421043(in-package :uiop/utility)
    12101211                       ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
    12111212                       ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
    1212                        #+(and lispworks (not (or lispworks4 lispworks5 lispworks6)))
    1213                        lw:bmp-char
     1213                       #+lispworks7+ lw:bmp-char
    12141214                       #+lispworks lw:simple-char
    12151215                       character)
    15241524(with-upgradability ()
    15251525  (defun unparse-version (version-list)
     1526    "From a parsed version (a list of natural numbers), compute the version string"
    15261527    (format nil "~{~D~^.~}" version-list))
    15281529  (defun parse-version (version-string &optional on-error)
    1529     "Parse a VERSION-STRING as a series of natural integers separated by dots.
     1530    "Parse a VERSION-STRING as a series of natural numbers separated by dots.
    15301531Return a (non-null) list of integers if the string is valid;
    15311532otherwise return NIL.
    15531554        version-list)))
    1555   (defun lexicographic< (< x y)
     1556  (defun lexicographic< (element< x y)
     1557    "Lexicographically compare two lists of using the function element< to compare elements.
     1558element< is a strict total order; the resulting order on X and Y will also be strict."
    15561559    (cond ((null y) nil)
    15571560          ((null x) t)
    1558           ((funcall < (car x) (car y)) t)
    1559           ((funcall < (car y) (car x)) nil)
    1560           (t (lexicographic< < (cdr x) (cdr y)))))
    1562   (defun lexicographic<= (< x y)
    1563     (not (lexicographic< < y x)))
     1561          ((funcall element< (car x) (car y)) t)
     1562          ((funcall element< (car y) (car x)) nil)
     1563          (t (lexicographic< element< (cdr x) (cdr y)))))
     1565  (defun lexicographic<= (element< x y)
     1566    "Lexicographically compare two lists of using the function element< to compare elements.
     1567element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
     1568    (not (lexicographic< element< y x)))
    15651570  (defun version< (version1 version2)
     1571    "Compare two version strings"
    15661572    (let ((v1 (parse-version version1 nil))
    15671573          (v2 (parse-version version2 nil)))
    15701576  (defun version<= (version1 version2)
     1577    "Compare two version strings"
    15711578    (not (version< version2 version1)))
    15871594    #+abcl 'system::format-control
    15881595    #+allegro 'excl::format-control
     1596    #+(or clasp ecl mkcl) 'si::format-control
    15891597    #+clisp 'system::$format-control
    15901598    #+clozure 'ccl::format-control
    15911599    #+(or cmucl scl) 'conditions::format-control
    1592     #+(or clasp ecl mkcl) 'si::format-control
    15931600    #+(or gcl lispworks) 'conditions::format-string
    15941601    #+sbcl 'sb-kernel:format-control
    16261633    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
     1635;;; Conditions
     1637(with-upgradability ()
     1638  (define-condition not-implemented-error (error)
     1639    ((functionality :initarg :functionality)
     1640     (format-control :initarg :format-control)
     1641     (format-arguments :initarg :format-arguments))
     1642    (:report (lambda (condition stream)
     1643               (format stream "Not implemented: ~s~@[ ~?~]"
     1644                       (slot-value condition 'functionality)
     1645                       (slot-value condition 'format-control)
     1646                       (slot-value condition 'format-arguments)))))
     1648  (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
     1649    "Signal an error because some FUNCTIONALITY is not implemented in the current version
     1650of the software on the current platform; it may or may not be implemented in different combinations
     1651of version of the software and of the underlying platform. Optionally, report a formatted error
     1653    (error 'not-implemented-error
     1654           :functionality functionality
     1655           :format-control format-control
     1656           :format-arguments format-arguments))
     1658  (define-condition parameter-error (error)
     1659    ((functionality :initarg :functionality)
     1660     (format-control :initarg :format-control)
     1661     (format-arguments :initarg :format-arguments))
     1662    (:report (lambda (condition stream)
     1663               (apply 'format stream
     1664                       (slot-value condition 'format-control)
     1665                       (slot-value condition 'functionality)
     1666                       (slot-value condition 'format-arguments)))))
     1668  ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
     1669  ;; the format-control. If you want it to not appear in first position in actual message, use
     1670  ;; ~* and ~:* to adjust parameter order.
     1671  (defun parameter-error (format-control functionality &rest format-arguments)
     1672    "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
     1673platform does not accept a given parameter or combination of parameters. Report a formatted error
     1674message, that takes the functionality as its first argument (that can be skipped with ~*)."
     1675    (error 'parameter-error
     1676           :functionality functionality
     1677           :format-control format-control
     1678           :format-arguments format-arguments)))
    16281680;;;; ---------------------------------------------------------------------------
    16291681;;;; Access to the Operating System
    16831735    (featurep :mcl))
     1737  (defun os-haiku-p ()
     1738    "Is the underlying operating system Haiku?"
     1739    (featurep :haiku))
    16851741  (defun detect-os ()
    16861742    "Detects the current operating system. Only needs be run at compile-time,
    16891745           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
    16901746                                         (:os-windows . os-windows-p)
    1691                                          (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
     1747                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)
     1748                                         (:haiku . os-haiku-p))
    16921749           :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
    16931750           :do (setf o feature) (pushnew feature *features*)
    18441901                      ;; ANSI upper case vs lower case.
    18451902                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
    1846         #+clasp (format nil "~A-~A"
    1847                         s (core:lisp-implementation-id))
    1848         #+(and ecl (not clasp)) (format nil "~A~@[-~A~]" s
    1849                                        (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    1850                                          (subseq vcs-id 0 (min (length vcs-id) 8))))
     1903        #+ecl (format nil "~A~@[-~A~]" s
     1904                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     1905                        (subseq vcs-id 0 (min (length vcs-id) 8))))
    18511906        #+gcl (subseq s (1+ (position #\space s)))
    18521907        #+genera
    18541909          (format nil "~D.~D" major minor))
    18551910        #+mcl (subseq s 8) ; strip the leading "Version "
     1911        ;; seems like there should be a shorter way to do this, like ACALL.
     1912        #+mkcl (or
     1913                (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil)))
     1914                  (when (and fname (fboundp fname))
     1915                    (funcall fname)))
     1916                s)
    18561917        s))))
    18631924     (format nil "~(~a~@{~@[-~a~]~}~)"
    18641925             (or (implementation-type) (lisp-implementation-type))
    1865              (or (lisp-version-string) (lisp-implementation-version))
     1926             (lisp-version-string)
    18661927             (or (operating-system) (software-type))
    18671928             (or (architecture) (machine-type))))))
    23392400       pathspec)
    23402401      (t
    2341        (make-pathname :directory (append (or (normalize-pathname-directory-component
    2342                                               (pathname-directory pathspec))
    2343                                              (list :relative))
    2344                                          (list (file-namestring pathspec)))
    2345                       :name nil :type nil :version nil :defaults pathspec)))))
     2402       (handler-case
     2403           (make-pathname :directory (append (or (normalize-pathname-directory-component
     2404                                                  (pathname-directory pathspec))
     2405                                                 (list :relative))
     2406                                             (list (file-namestring pathspec)))
     2407                          :name nil :type nil :version nil :defaults pathspec)
     2408         (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
    28212884           ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
    28222885           ;; a trailing directory separator, causes an error on some lisps.
    2823            #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
     2886           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))))))
    28252888  (defun safe-file-write-date (pathname)
    32963359            #+abcl extensions:*lisp-home*
    32973360            #+(or allegro clasp ecl mkcl) #p"SYS:"
    3298             ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
     3361            #+clisp custom:*lib-directory*
    32993362            #+clozure #p"ccl:"
    33003363            #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
    33723435    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
    33733436    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
    3374     (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
     3437    (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
    33763439  (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
    34523515   #:eval-input #:eval-thunk #:standard-eval-thunk
    34533516   #:println #:writeln
     3517   #:file-stream-p #:file-or-synonym-stream-p
    34543518   ;; Temporary files
    34553519   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
    38013865    #+allegro
    38023866    (excl.osi:copy-file input output)
    3803     #-allegro
     3867    #+ecl
     3868    (ext:copy-file input output)
     3869    #-(or allegro ecl)
    38043870    (concatenate-files (list input) output))
    41344200    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
    41354201    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
     4203(with-upgradability ()
     4204  (defun file-stream-p (stream)
     4205    (typep stream 'file-stream))
     4206  (defun file-or-synonym-stream-p (stream)
     4207    (or (file-stream-p stream)
     4208        (and (typep stream 'synonym-stream)
     4209             (file-or-synonym-stream-p
     4210              (symbol-value (synonym-stream-symbol stream)))))))
    41364211;;;; -------------------------------------------------------------------------
    41374212;;;; Starting, Stopping, Dumping a Lisp image
    43684443    #+xcl system:*argv*
    43694444    #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    4370     (error "raw-command-line-arguments not implemented yet"))
     4445    (not-implemented-error 'raw-command-line-arguments))
    43724447  (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
    45584633    ;; only if we also track the object files that constitute the "current" image,
    45594634    ;; and otherwise simulate dump-image, including quitting at the end.
    4560     #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
     4635    #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
    45614636    #+(or clasp ecl mkcl)
    45624637    (let ((epilogue-code
    46184693   ;;; run-program
    46194694   #:slurp-input-stream #:vomit-output-stream
    4620    #:run-program
     4695   #:close-streams #:launch-program #:process-alive-p #:run-program
     4696   #:terminate-process #:wait-process
     4697   #:process-info-error-output #:process-info-input #:process-info-output
     4698   #:process-info-pid
    46214699   #:subprocess-error
    46224700   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
    49815059    (not (typep specifier '(or null string pathname (member :interactive :output)
    49825060                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
    4983                             #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
     5061                            #+lispworks file-stream))))
    49855063  (defun %normalize-io-specifier (specifier &optional role)
    49975075       #+clisp :terminal
    49985076       #+(or clozure cmucl ecl mkcl sbcl scl) t)
    4999       #+(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5077      #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    50005078      ((eql :output)
    50015079       (if (eq role :error-output)
    50115089    (member :interactive (list input output error-output)))
    5013   #+clisp
    5014   (defun clisp-exit-code (raw-exit-code)
    5015     (typecase raw-exit-code
    5016       (null 0) ; no error
    5017       (integer raw-exit-code) ; negative: signal
    5018       (t -1)))
     5091  (defun %signal-to-exit-code (signum)
     5092    (+ 128 signum))
     5094  #+mkcl
     5095  (defun %mkcl-signal-to-number (signal)
     5096    (require :mk-unix)
     5097    (symbol-value (find-symbol signal :mk-unix)))
    50205099  (defclass process-info ()
    50245103     (bidir-stream :initform nil)
    50255104     (error-output-stream :initform nil)
    5026      (exit-code :initform nil)))
     5105     ;; For backward-compatibility, to maintain the property (zerop
     5106     ;; exit-code) <-> success, an exit in response to a signal is
     5107     ;; encoded as 128+signum.
     5108     (exit-code :initform nil)
     5109     ;; If the platform allows it, distinguish exiting with a code
     5110     ;; >128 from exiting in response to a signal by setting this code
     5111     (signal-code :initform nil)))
    50285113  (defun %run-program (command
    50415126    ;; NB: these implementations have Unix vs Windows set at compile-time.
    50425127    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
    5043     #-(or cmucl ecl mkcl sbcl)
    5044     (assert (not (and wait (member :stream (list input output error-output)))))
    5045     #-(or allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    5046     (progn command keys directory
    5047            (error "run-program not available"))
    5048     #+(or allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
     5128    #-(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
     5129    (progn command keys input output error-output directory wait ;; ignore
     5130           (not-implemented-error '%run-program))
     5131    #-(or abcl cmucl ecl mkcl sbcl)
     5132    (when (and wait (member :stream (list input output error-output)))
     5133      (parameter-error "~S: I/O parameters cannot be ~S when ~S is ~S on this lisp"
     5134                       '%run-program :stream :wait t))
     5135    #+allegro
     5136    (when (some #'(lambda (stream)
     5137                    (and (streamp stream)
     5138                         (not (file-stream-p stream))))
     5139                (list input output error-output))
     5140      (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
     5141                       '%run-program))
     5142    #+(or abcl clisp lispworks)
     5143    (when (some #'streamp (list input output error-output))
     5144      (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
     5145                       '%run-program))
     5146    #+clisp
     5147    (unless (eq error-output :interactive)
     5148      (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
     5149                       '%run-program :error-output :interactive))
     5150    #+clisp
     5151    (when (or (stringp input) (pathnamep input))
     5152      (unless (file-exists-p input)
     5153        (parameter-error "~S: Files passed as arguments to ~S need to exist on this lisp"
     5154                         '%run-program :input)))
     5155    #+ecl
     5156    (when (some #'(lambda (stream)
     5157                    (and (streamp stream)
     5158                         (not (file-or-synonym-stream-p stream))))
     5159                (list input output error-output))
     5160      (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
     5161                       '%run-program))
     5162    #+(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    50495163    (let* ((%command (%normalize-command command))
    50505164           (%if-output-exists (%normalize-if-exists if-output-exists))
    50565170           (process*
    50575171             (nest
    5058               #+clisp (progn
    5059                         ;; clisp cannot redirect stderr, so check we don't.
    5060                         ;; Also, since we now always return a code, we cannot use this code path
    5061                         ;; if any of the input, output or error-output is :stream.
    5062                         (assert (eq %error-output :terminal)))
    50635172              #-(or allegro mkcl sbcl) (with-current-directory (directory))
    50645173              #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list)
    50655174              (apply
     5175               #+abcl #'sys:run-program
    50665176               #+allegro 'excl:run-shell-command
    50675177               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
    50805190               #+sbcl 'sb-ext:run-program
    50815191               (append
    5082                 #+(or clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
     5192                #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
    50835193                `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t)
    50845194                #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
    50865196                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
    50875197                #+clisp `(:if-output-exists ,%if-output-exists)
    5088                 #+(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5198                #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    50895199                `(:if-input-does-not-exist ,if-input-does-not-exist
    50905200                  :if-output-exists ,%if-output-exists
    50985208                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
    50995209           (process-info (make-instance 'process-info)))
    5100       (flet ((prop (key value)
    5101                (setf (slot-value process-info key) value)))
     5210      #+clisp (declare (ignore %error-output))
     5211      (labels ((prop (key value) (setf (slot-value process-info key) value))
     5212               #+(or allegro clisp ecl lispworks mkcl)
     5213               (store-codes (exit-code &optional signal-code)
     5214                 (if signal-code
     5215                     (progn (prop 'exit-code (%signal-to-exit-code signal-code))
     5216                            (prop 'signal-code signal-code))
     5217                     (prop 'exit-code exit-code))))
    51025218        #+allegro
    51035219        (cond
    5104           (wait (prop 'exit-code (first process*)))
     5220          (wait (store-codes (first process*)))
    51055221          (separate-streams
    51065222           (destructuring-bind (in out err pid) process*
    51205236             (prop 'error-stream (second process*)))))
    51215237        #+clisp
    5122         (cond
    5123           (wait (prop 'exit-code (clisp-exit-code (first process*))))
    5124           (t
    5125            (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
    5126              (0)
    5127              (1 (prop 'input-stream (first process*)))
    5128              (2 (prop 'output-stream (first process*)))
    5129              (3 (prop 'bidir-stream (pop process*))
    5130               (prop 'input-stream (pop process*))
    5131               (prop 'output-stream (pop process*))))))
    5132         #+(or clozure cmucl sbcl scl)
     5238        (if wait
     5239            (let ((raw-exit-code (or (first process*) 0)))
     5240              (if (minusp raw-exit-code)
     5241                  (store-codes 0 (- raw-exit-code))
     5242                  (store-codes raw-exit-code)))
     5243            (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
     5244              (0)
     5245              (1 (prop 'input-stream (first process*)))
     5246              (2 (prop 'output-stream (first process*)))
     5247              (3 (prop 'bidir-stream (pop process*))
     5248                 (prop 'input-stream (pop process*))
     5249                 (prop 'output-stream (pop process*)))))
     5250        #+(or abcl clozure cmucl sbcl scl)
    51335251        (progn
    51345252          (prop 'process process*)
    51355253          (when (eq input :stream)
    51365254            (prop 'input-stream
     5255                  #+abcl (symbol-call :sys :process-input process*)
    51375256                  #+clozure (ccl:external-process-input-stream process*)
    51385257                  #+(or cmucl scl) (ext:process-input process*)
    51405259          (when (eq output :stream)
    51415260            (prop 'output-stream
     5261                  #+abcl (symbol-call :sys :process-output process*)
    51425262                  #+clozure (ccl:external-process-output-stream process*)
    51435263                  #+(or cmucl scl) (ext:process-output process*)
    51455265          (when (eq error-output :stream)
    51465266            (prop 'error-output-stream
     5267                  #+abcl (symbol-call :sys :process-error process*)
    51475268                  #+clozure (ccl:external-process-error-stream process*)
    51485269                  #+(or cmucl scl) (ext:process-error process*)
    51535274            (cond
    51545275              ((zerop mode))
    5155               ((null process*) (prop 'exit-code -1))
     5276              ((null process*) (store-codes -1))
    51565277              (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
    5157           (when code (prop 'exit-code code))
     5278          (when code
     5279            (let ((signum #+mkcl (and (stringp code) (%mkcl-signal-to-number code))
     5280                          #-mkcl (and (eq (ext:external-process-wait process)
     5281                                          :signaled)
     5282                                      code)))
     5283              (store-codes code signum)))
    51585284          (when process (prop 'process process)))
    51595285        #+lispworks
    51605286        (if wait
    5161             (prop 'exit-code (or (second process*) (first process*)))
     5287            (store-codes (first process*) (second process*))
    51625288            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    51635289              (if (or (plusp mode) (eq error-output :stream))
    51765302        process-info)))
    5178   (defun %process-info-pid (process-info)
     5304  (defun process-info-error-output (process-info)
     5305    (slot-value process-info 'error-output-stream))
     5306  (defun process-info-input (process-info)
     5307    (or (slot-value process-info 'bidir-stream)
     5308        (slot-value process-info 'input-stream)))
     5309  (defun process-info-output (process-info)
     5310    (or (slot-value process-info 'bidir-stream)
     5311        (slot-value process-info 'output-stream)))
     5313  (defun process-info-pid (process-info)
    51795314    (let ((process (slot-value process-info 'process)))
    51805315      (declare (ignorable process))
     5316      #+abcl (symbol-call :sys :process-pid process)
    51815317      #+allegro process
    51825318      #+clozure (ccl:external-process-id process)
    51875323      #+mkcl (mkcl:process-id process)
    51885324      #+sbcl (sb-ext:process-pid process)
    5189       #-(or allegro clozure cmucl ecl mkcl lispworks sbcl scl)
    5190       (error "~S not implemented" '%process-info-pid)))
    5192   (defun %wait-process-result (process-info)
    5193     (or (slot-value process-info 'exit-code)
    5194         (let ((process (slot-value process-info 'process)))
    5195           #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    5196           (error "~S not implemented" '%wait-process)
    5197           (when process
    5198             ;; 1- wait
    5199             #+clozure (ccl::external-process-wait process)
    5200             #+(or cmucl scl) (ext:process-wait process)
    5201             #+sbcl (sb-ext:process-wait process)
    5202             ;; 2- extract result
    5203             (let ((exit-code
    5204                    #+allegro (multiple-value-bind (exit-code pid signal)
    5205                                  (sys:reap-os-subprocess :pid process :wait t)
    5206                                (assert pid)
    5207                                (or signal exit-code))
    5208                    #+clozure (nth-value 1 (ccl:external-process-status process))
    5209                    #+(or cmucl scl) (ext:process-exit-code process)
    5210                    #+ecl (nth-value 1 (ext:external-process-wait process t))
    5211                    #+lispworks
    5212                    ;; a signal is only returned on LispWorks 7+
    5213                    (multiple-value-bind (exit-code signal)
    5214                        (funcall #+lispworks7+ #'sys:pipe-exit-status
    5215                                 #-lispworks7+ #'sys:pid-exit-status
    5216                                 process :wait t)
    5217                      (or signal exit-code))
    5218                    #+mkcl (mkcl:join-process process)
    5219                    #+sbcl (sb-ext:process-exit-code process)))
    5220               (setf (slot-value process-info 'exit-code) exit-code)
    5221               exit-code)))))
     5325      #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
     5326      (not-implemented-error 'process-info-pid)))
     5328  (defun %process-status (process-info)
     5329    (if-let (exit-code (slot-value process-info 'exit-code))
     5330      (return-from %process-status
     5331        (if-let (signal-code (slot-value process-info 'signal-code))
     5332          (values :signaled signal-code)
     5333          (values :exited exit-code))))
     5334    #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5335    (not-implemented-error '%process-status)
     5336    (if-let (process (slot-value process-info 'process))
     5337      (multiple-value-bind (status code)
     5338          (progn
     5339            #+allegro (multiple-value-bind (exit-code pid signal)
     5340                          (sys:reap-os-subprocess :pid process :wait nil)
     5341                        (assert pid)
     5342                        (cond ((null exit-code) :running)
     5343                              ((null signal) (values :exited exit-code))
     5344                              (t (values :signaled signal))))
     5345            #+clozure (ccl:external-process-status process)
     5346            #+(or cmucl scl) (let ((status (ext:process-status process)))
     5347                               (values status (if (member status '(:exited :signaled))
     5348                                                  (ext:process-exit-code process))))
     5349            #+ecl (ext:external-process-status process)
     5350            #+lispworks
     5351            ;; a signal is only returned on LispWorks 7+
     5352            (multiple-value-bind (exit-code signal)
     5353                (funcall #+lispworks7+ #'sys:pipe-exit-status
     5354                         #-lispworks7+ #'sys:pid-exit-status
     5355                         process :wait nil)
     5356              (cond ((null exit-code) :running)
     5357                    ((null signal) (values :exited exit-code))
     5358                    (t (values :signaled signal))))
     5359            #+mkcl (let ((status (mk-ext:process-status process))
     5360                         (code (mk-ext:process-exit-code process)))
     5361                     (if (stringp code)
     5362                         (values :signaled (%mkcl-signal-to-number code))
     5363                         (values status code)))
     5364            #+sbcl (let ((status (sb-ext:process-status process)))
     5365                     (values status (if (member status '(:exited :signaled))
     5366                                        (sb-ext:process-exit-code process)))))
     5367        (case status
     5368          (:exited (setf (slot-value process-info 'exit-code) code))
     5369          (:signaled (let ((%code (%signal-to-exit-code code)))
     5370                       (setf (slot-value process-info 'exit-code) %code
     5371                             (slot-value process-info 'signal-code) code))))
     5372        (values status code))))
     5374  (defun process-alive-p (process-info)
     5375    "Check if a process has yet to exit."
     5376    (unless (slot-value process-info 'exit-code)
     5377      #+abcl (sys:process-alive-p (slot-value process-info 'process))
     5378      #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
     5379      #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
     5380      #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
     5381                                         '(:running :sleeping))))
     5383  (defun wait-process (process-info)
     5384    "Wait for the process to terminate, if it is still running.
     5385Otherwise, return immediately. An exit code (a number) will be
     5386returned, with 0 indicating success, and anything else indicating
     5387failure. If the process exits after receiving a signal, the exit code
     5388will be the sum of 128 and the (positive) numeric signal code. A second
     5389value may be returned in this case: the numeric signal code itself.
     5390Any asynchronously spawned process requires this function to be run
     5391before it is garbage-collected in order to free up resources that
     5392might otherwise be irrevocably lost."
     5393    (if-let (exit-code (slot-value process-info 'exit-code))
     5394      (if-let (signal-code (slot-value process-info 'signal-code))
     5395        (values exit-code signal-code)
     5396        exit-code)
     5397      (let ((process (slot-value process-info 'process)))
     5398        #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
     5399        (not-implemented-error 'wait-process)
     5400        (when process
     5401          ;; 1- wait
     5402          #+clozure (ccl::external-process-wait process)
     5403          #+(or cmucl scl) (ext:process-wait process)
     5404          #+sbcl (sb-ext:process-wait process)
     5405          ;; 2- extract result
     5406          (multiple-value-bind (exit-code signal-code)
     5407              (progn
     5408                #+abcl (sys:process-wait process)
     5409                #+allegro (multiple-value-bind (exit-code pid signal)
     5410                              (sys:reap-os-subprocess :pid process :wait t)
     5411                            (assert pid)
     5412                            (values exit-code signal))
     5413                #+clozure (multiple-value-bind (status code)
     5414                              (ccl:external-process-status process)
     5415                            (if (eq status :signaled)
     5416                                (values nil code)
     5417                                code))
     5418                #+(or cmucl scl) (let ((status (ext:process-status process))
     5419                                       (code (ext:process-exit-code process)))
     5420                                   (if (eq status :signaled)
     5421                                       (values nil code)
     5422                                       code))
     5423                #+ecl (multiple-value-bind (status code)
     5424                          (ext:external-process-wait process t)
     5425                        (if (eq status :signaled)
     5426                            (values nil code)
     5427                            code))
     5428                #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
     5429                                     #-lispworks7+ #'sys:pid-exit-status
     5430                                     process :wait t)
     5431                #+mkcl (let ((code (mkcl:join-process process)))
     5432                         (if (stringp code)
     5433                             (values nil (%mkcl-signal-to-number code))
     5434                             code))
     5435                #+sbcl (let ((status (sb-ext:process-status process))
     5436                             (code (sb-ext:process-exit-code process)))
     5437                         (if (eq status :signaled)
     5438                             (values nil code)
     5439                             code)))
     5440            (if signal-code
     5441                (let ((%exit-code (%signal-to-exit-code signal-code)))
     5442                  (setf (slot-value process-info 'exit-code) %exit-code
     5443                        (slot-value process-info 'signal-code) signal-code)
     5444                  (values %exit-code signal-code))
     5445                (progn (setf (slot-value process-info 'exit-code) exit-code)
     5446                       exit-code)))))))
    52235448  (defun %check-result (exit-code &key command process ignore-error-status)
    52275452                'subprocess-error :command command :code exit-code :process process)))
    52285453    exit-code)
     5455  (defun close-streams (process-info)
     5456    "Close any stream that the process might own. Needs to be run
     5457whenever streams were requested by passing :stream to :input, :output,
     5458or :error-output."
     5459    (dolist (stream
     5460              (cons (slot-value process-info 'error-output-stream)
     5461                    (if-let (bidir-stream (slot-value process-info 'bidir-stream))
     5462                      (list bidir-stream)
     5463                      (list (slot-value process-info 'input-stream)
     5464                            (slot-value process-info 'output-stream)))))
     5465      (when stream (close stream))))
     5467  ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
     5468  ;; do what you expect it to. Sending SIGSTOP to a process spawned
     5469  ;; via %run-program, e.g., will stop the shell /bin/sh that is used
     5470  ;; to run the command (via `sh -c command`) but not the actual
     5471  ;; command.
     5472  #+os-unix
     5473  (defun %posix-send-signal (process-info signal)
     5474    #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
     5475    #+clozure (ccl:signal-external-process (slot-value process-info 'process)
     5476                                           signal :error-if-exited nil)
     5477    #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
     5478    #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
     5479    #-(or allegro clozure cmucl sbcl scl)
     5480    (if-let (pid (process-info-pid process-info))
     5481      (%run-program (format nil "kill -~a ~a" signal pid) :wait t)))
     5483  ;;; this function never gets called on Windows, but the compiler cannot tell
     5484  ;;; that. [2016/09/25:rpg]
     5485  #+os-windows
     5486  (defun %posix-send-signal (process-info signal)
     5487    (declare (ignore process-info signal))
     5488    (values))
     5490  (defun terminate-process (process-info &key urgent)
     5491    "Cause the process to exit. To that end, the process may or may
     5492not be sent a signal, which it will find harder (or even impossible)
     5493to ignore if URGENT is T. On some platforms, it may also be subject to
     5494race conditions."
     5495    (declare (ignorable urgent))
     5496    #+abcl (sys:process-kill (slot-value process-info 'process))
     5497    #+ecl (symbol-call :ext :terminate-process
     5498                       (slot-value process-info 'process) urgent)
     5499    #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
     5500    #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
     5501                                     :force urgent)
     5502    #-(or abcl ecl lispworks7+ mkcl)
     5503    (os-cond
     5504     ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
     5505     ((os-windows-p) (if-let (pid (process-info-pid process-info))
     5506                       (%run-program (format nil "taskkill ~a /pid ~a"
     5507                                             (if urgent "/f" "") pid))))
     5508     (t (not-implemented-error 'terminate-process))))
    52305510  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
    53195599                           &key input output error-output ignore-error-status &allow-other-keys)
    53205600    ;; helper for RUN-PROGRAM when using %run-program
    5321     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
     5601    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
    53225602    (progn
    53235603      command keys input output error-output ignore-error-status ;; ignore
    5324       (error "Not implemented on this platform"))
     5604      (not-implemented-error '%use-run-program))
    53255605    (assert (not (member :stream (list input output error-output))))
    53265606    (let* ((active-input-p (%active-io-specifier-p input))
    53345614               (t nil)))
    53355615           (wait (not activity))
    5336            output-result error-output-result exit-code)
     5616           output-result error-output-result exit-code process-info)
    53375617      (with-program-output ((reduced-output output-activity)
    53385618                            output :keys keys :setf output-result
    53445624                               input :keys keys
    53455625                               :stream-easy-p t :active (eq activity :input))
    5346             (let ((process-info
    5347                     (apply '%run-program command
    5348                            :wait wait :input reduced-input :output reduced-output
    5349                            :error-output (if (eq error-output :output) :output reduced-error-output)
    5350                            keys)))
    5351               (labels ((get-stream (stream-name &optional fallbackp)
    5352                          (or (slot-value process-info stream-name)
    5353                              (when fallbackp
    5354                                (slot-value process-info 'bidir-stream))))
    5355                        (run-activity (activity stream-name &optional fallbackp)
    5356                          (if-let (stream (get-stream stream-name fallbackp))
    5357                            (funcall activity stream)
    5358                            (error 'subprocess-error
    5359                                   :code `(:missing ,stream-name)
    5360                                   :command command :process process-info))))
    5361                 (unwind-protect
    5362                      (ecase activity
    5363                        ((nil))
    5364                        (:input (run-activity input-activity 'input-stream t))
    5365                        (:output (run-activity output-activity 'output-stream t))
    5366                        (:error-output (run-activity error-output-activity 'error-output-stream)))
    5367                   (dolist (stream
    5368                             (cons (slot-value process-info 'error-output-stream)
    5369                                   (if-let (bidir-stream (slot-value process-info 'bidir-stream))
    5370                                           (list bidir-stream)
    5371                                           (list (slot-value process-info 'input-stream)
    5372                                                 (slot-value process-info 'output-stream)))))
    5373                     (when stream (close stream)))
    5374                   (setf exit-code
    5375                         (%check-result (%wait-process-result process-info)
    5376                                        :command command :process process-info
    5377                                        :ignore-error-status ignore-error-status))))))))
     5626            (setf process-info
     5627                  (apply '%run-program command
     5628                         :wait wait :input reduced-input :output reduced-output
     5629                         :error-output (if (eq error-output :output) :output reduced-error-output)
     5630                         keys))
     5631            (labels ((get-stream (stream-name &optional fallbackp)
     5632                       (or (slot-value process-info stream-name)
     5633                           (when fallbackp
     5634                             (slot-value process-info 'bidir-stream))))
     5635                     (run-activity (activity stream-name &optional fallbackp)
     5636                       (if-let (stream (get-stream stream-name fallbackp))
     5637                         (funcall activity stream)
     5638                         (error 'subprocess-error
     5639                                :code `(:missing ,stream-name)
     5640                                :command command :process process-info))))
     5641              (unwind-protect
     5642                   (ecase activity
     5643                     ((nil))
     5644                     (:input (run-activity input-activity 'input-stream t))
     5645                     (:output (run-activity output-activity 'output-stream t))
     5646                     (:error-output (run-activity error-output-activity 'error-output-stream)))
     5647                (close-streams process-info)
     5648                (setf exit-code (wait-process process-info)))))))
     5649      (%check-result exit-code
     5650                     :command command :process process-info
     5651                     :ignore-error-status ignore-error-status)
    53785652      (values output-result error-output-result exit-code)))
    54275701    (declare (ignorable input output error-output directory keys))
    54285702    #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
    5429     (%wait-process-result
     5703    (wait-process
    54305704     (apply '%run-program (%normalize-system-command command) :wait t keys))
    54315705    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
    54345708      (system:call-system %command :current-directory directory :wait t)
    54355709      #+clisp
    5436       (%wait-process-result
     5710      (wait-process
    54375711       (apply '%run-program %command :wait t
    54385712              :input :interactive :output :interactive :error-output :interactive keys))
    54395713      #-(or clisp (and lispworks os-windows))
    54405714      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
    5441         #+abcl (ext:run-shell-command %command)
     5715        #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated
    54425716        #+cormanlisp (win32:system %command)
    54435717        #+(or clasp ecl) (let ((*standard-input* *stdin*)
    54465720                (ext:system %command))
    54475721        #+gcl (system:system %command)
    5448         #+genera (error "~S not supported on Genera, cannot run ~S"
    5449                         '%system %command)
     5722        #+genera (not-implemented-error '%system)
    54505723        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
    54515724        #+mkcl (mkcl:system %command)
    54615734                                    error-output :keys keys :setf error-output-result)
    54625735          (with-program-input ((reduced-input) input :keys keys)
    5463             (setf exit-code
    5464                   (%check-result (apply '%system command
    5465                                         :input reduced-input :output reduced-output
    5466                                         :error-output reduced-error-output keys)
    5467                                  :command command
    5468                                  :ignore-error-status ignore-error-status)))))
     5736            (setf exit-code (apply '%system command
     5737                                   :input reduced-input :output reduced-output
     5738                                   :error-output reduced-error-output keys)))))
     5739      (%check-result exit-code
     5740                     :command command
     5741                     :ignore-error-status ignore-error-status)
    54695742      (values output-result error-output-result exit-code)))
     5744  (defun launch-program (command &rest keys &key
     5745                                              input (if-input-does-not-exist :error)
     5746                                              output (if-output-exists :supersede)
     5747                                              error-output (if-error-output-exists :supersede)
     5748                                              (element-type #-clozure *default-stream-element-type*
     5749                                                            #+clozure 'character)
     5750                                              (external-format *utf-8-external-format*)
     5751                                              &allow-other-keys)
     5752    "Launch program specified by COMMAND,
     5753either a list of strings specifying a program and list of arguments,
     5754or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
     5755Windows) _asynchronously_.
     5757If OUTPUT is a pathname, a string designating a pathname, or NIL
     5758designating the null device, the file at that path is used as output.
     5759If it's :INTERACTIVE, output is inherited from the current process;
     5760beware that this may be different from your *STANDARD-OUTPUT*, and
     5761under SLIME will be on your *inferior-lisp* buffer.  If it's T, output
     5762goes to your current *STANDARD-OUTPUT* stream.  If it's :STREAM, a new
     5763stream will be made available that can be accessed via
     5764PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
     5765that the underlying lisp implementation knows how to handle.
     5767ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
     5768:OUTPUT means redirecting the error output to the output stream,
     5769and :STREAM causes a stream to be made available via
     5772INPUT is similar to OUTPUT, except that T designates the
     5773*STANDARD-INPUT* and a stream requested through the :STREAM keyword
     5774would be available through PROCESS-INFO-INPUT.
     5776ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
     5777implementation, when applicable, for creation of the output stream.
     5779LAUNCH-PROGRAM returns a process-info object."
     5780    (apply '%run-program command
     5781           :wait nil
     5782           :input input :if-input-does-not-exist if-input-does-not-exist
     5783           :output output :if-output-exists if-output-exists
     5784           :error-output error-output :if-error-output-exists if-error-output-exists
     5785           :element-type element-type :external-format external-format
     5786           keys))
    54715788  (defun run-program (command &rest keys
    55155832no value is returned, and T designates the *STANDARD-INPUT*.
    5517 Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
     5834ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
    55185835to your Lisp implementation, when applicable, for creation of the output stream.
    55325849    (declare (ignorable ignore-error-status))
    55335850    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    5534     (error "RUN-PROGRAM not implemented for this Lisp")
     5851    (not-implemented-error 'run-program)
    55355852    ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
    55365853    ;; don't override user's specified preference. [2015/06/29:rpg]
    55415858    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
    55425859      (apply (if (or force-shell
    5543                      #+(or clasp clisp) (or (not ignore-error-status) t)
    5544                      #+clisp (member error-output '(:interactive :output))
     5860                     #+(or clasp clisp) t
    55455861                     ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
    55465862                     #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
    55475863                               (lexicographic<= '< ver '(16 0 1)))
    55485864                     #+(and lispworks os-unix) (%interactivep input output error-output)
    5549                      #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
     5865                     #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
    55505866                 '%use-system '%use-run-program)
    55515867             command
    68687184              (cons (format nil "~{~D~^.~}" rev))
    68697185              (null "1.0"))))))
    6870   ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly.
     7186  ;; This (private) variable contains a list of versions of previously loaded variants of ASDF,
     7187  ;; from which ASDF was upgraded.
     7188  ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly.
    68717189  (defvar *previous-asdf-versions*
    68727190    (let ((previous (asdf-version)))
    68787196            (when *load-verbose*
    68797197              (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))
    6880         (list previous)))
     7198      (list previous)))
     7199  ;; This public variable will be bound shortly to the currently loaded version of ASDF.
    68817200  (defvar *asdf-version* nil)
    6882   ;; We need to clear systems from versions yet older than the below:
     7201  ;; We need to clear systems from versions older than the one in this (private) parameter:
    68837202  (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component.
     7203  ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages
    68847204  (defvar *verbose-out* nil)
     7205  ;; Private function by which ASDF outputs progress messages and warning messages:
    68857206  (defun asdf-message (format-string &rest format-args)
    68867207    (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
     7208  ;; Private hook for functions to run after ASDF has upgraded itself from an older variant:
    68877209  (defvar *post-upgrade-cleanup-hook* ())
     7210  ;; Private hook for functions to run after ASDF is restarted, whether by starting a process
     7211  ;; from a dumped image or after upgrading from an older variant:
     7212  ;; TODO: understand what happened with that hook, why functions are registered on it but it is
     7213  ;; never called anymore. This is a bug that should be fixed before next release (3.1.8)!
    68887214  (defvar *post-upgrade-restart-hook* ())
     7215  ;; Private function to detect whether the current upgrade counts as an incompatible
     7216  ;; data schema upgrade implying the need to drop data.
    68897217  (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
    68907218    (and *previous-asdf-versions*
    68917219         (version< (first *previous-asdf-versions*) oldest-compatible-version)))
     7220  ;; Private variant of defparameter that works in presence of incompatible upgrades:
     7221  ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change),
     7222  ;; but behaves like defparameter if in presence of an incompatible upgrade.
    68927223  (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
    68937224    (let* ((name (string-trim "*" var))
    68987229         (when (upgrading-p ,version)
    68997230           (setf ,var (,valfun))))))
     7231  ;; Private macro to declare sections of code that are only compiled and run when upgrading.
     7232  ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects,
     7233  ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs.
    69007234  (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
    69017235                               (upgrading-p `(upgrading-p ,version)) when) &body body)
    69067240         (handler-bind ((style-warning #'muffle-warning))
    69077241           (eval '(progn ,@body))))))
     7242  ;; Only now can we safely update the version.
    69087243  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    69097244         ;; Please also modify asdf.asd to reflect this change. make bump-version v=
    69157250         ;; "" would be your eighth local modification of official release 3.4.5
    69167251         ;; "" would be your eighth local modification of development version
    6917          (asdf-version "")
     7252         (asdf-version "")
    69187253         (existing-version (asdf-version)))
    69197254    (setf *asdf-version* asdf-version)
    69257260                existing-version asdf-version)))))
     7262;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
    69277263(when-upgrading ()
    69287264  (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
    69377273          :for sym = (find-symbol* name :asdf nil) :do
    69387274            (when sym
    6939               ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
     7275              ;; CLISP seemingly can't fmakunbound and define a function in the same fasl. Sigh.
    69407276              #-clisp (fmakunbound sym)))
    69417277    (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
    69507286;;; Self-upgrade functions
    6952 (with-upgradability ()
     7287(with-upgradability ()
     7288  ;; This private function is called at the end of asdf/footer and ensures that,
     7289  ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called.
    69537290  (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
    69547291    (let ((new-version (asdf-version)))
    69777314        (symbol-call :asdf :load-system :asdf :verbose nil))))
     7316  ;; Register the upgrade-configuration function from UIOP,
     7317  ;; to ensure configuration is upgraded as needed.
    69797318  (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
    70277366    (:documentation "Name of the COMPONENT, unique relative to its parent"))
    70287367  (defgeneric component-system (component)
    7029     (:documentation "Find the top-level system containing COMPONENT"))
     7368    (:documentation "Top-level system containing the COMPONENT"))
    70307369  (defgeneric component-pathname (component)
    7031     (:documentation "Extracts the pathname applicable for a particular component."))
     7370    (:documentation "Pathname of the COMPONENT if any, or NIL."))
    70327371  (defgeneric (component-relative-pathname) (component)
    7033     (:documentation "Returns a pathname for the component argument intended to be
    7034 interpreted relative to the pathname of that component's parent.
    7035 Despite the function's name, the return value may be an absolute
    7036 pathname, because an absolute pathname may be interpreted relative to
    7037 another pathname in a degenerate way."))
    7038   (defgeneric component-external-format (component))
    7039   (defgeneric component-encoding (component))
    7040   (defgeneric version-satisfies (component version))
    7041   (defgeneric component-version (component))
    7042   (defgeneric (setf component-version) (new-version component))
    7043   (defgeneric component-parent (component))
     7372    ;; in ASDF4, rename that to component-specified-pathname ?
     7373    (:documentation "Specified pathname of the COMPONENT,
     7374intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
     7375Despite the function's name, the return value can be an absolute pathname, in which case the merge
     7376will leave it unmodified."))
     7377  (defgeneric component-external-format (component)
     7378    (:documentation "The external-format of the COMPONENT.
     7379By default, deduced from the COMPONENT-ENCODING."))
     7380  (defgeneric component-encoding (component)
     7381    (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported.
     7382Use asdf-encodings to support more encodings."))
     7383  (defgeneric version-satisfies (component version)
     7384    (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent
     7385as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL."))
     7386  (defgeneric component-version (component)
     7387    (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated
     7388natural numbers, or NIL."))
     7389  (defgeneric (setf component-version) (new-version component)
     7390    (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated
     7391natural numbers, or NIL."))
     7392  (defgeneric component-parent (component)
     7393    (:documentation "The parent of a child COMPONENT,
     7394or NIL for top-level components (a.k.a. systems)"))
     7395  ;; NIL is a designator for the absence of a component, in which case the parent is also absent.
    70447396  (defmethod component-parent ((component null)) nil)
    7046   ;; Backward compatible way of computing the FILE-TYPE of a component.
     7398  ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
    70477399  ;; TODO: find users, have them stop using that, remove it for ASDF4.
    7048   (defgeneric (source-file-type) (component system))
     7400  (defgeneric (source-file-type) (component system)
     7401    (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
    70507403  (define-condition system-definition-error (error) ()
    71147467     (parent :initarg :parent :initform nil :reader component-parent)
    71157468     (build-operation
    7116       :initarg :build-operation :initform nil :reader component-build-operation)))
     7469      :initarg :build-operation :initform nil :reader component-build-operation))
     7470    (:documentation "Base class for all components of a build"))
    71187472  (defun component-find-path (component)
    71387492(with-upgradability ()
    71397493  (defclass child-component (component) ()
    7140     (:documentation "A CHILD-COMPONENT is a component that may be part of
     7494    (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of
    71417495a PARENT-COMPONENT."))
    71437497  (defclass file-component (child-component)
    7144     ((type :accessor file-type :initarg :type))) ; no default
     7498    ((type :accessor file-type :initarg :type)) ; no default
     7499    (:documentation "a COMPONENT that represents a file"))
    71457500  (defclass source-file (file-component)
    71467501    ((type :accessor source-file-explicit-type ;; backward-compatibility
    71517506    ((type :initform "java")))
    71527507  (defclass static-file (source-file)
    7153     ((type :initform nil)))
     7508    ((type :initform nil))
     7509    (:documentation "Component for a file to be included as is in the build output"))
    71547510  (defclass doc-file (static-file) ())
    71557511  (defclass html-file (doc-file)
    71697525      :initarg :default-component-class
    71707526      :accessor module-default-component-class))
    7171   (:documentation "A PARENT-COMPONENT is a component that may have
    7172 children.")))
    7174 (with-upgradability ()
     7527  (:documentation "A PARENT-COMPONENT is a component that may have children.")))
     7529(with-upgradability ()
     7530  ;; (Private) Function that given a PARENT component,
     7531  ;; the list of children of which has been initialized,
     7532  ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name.
     7533  ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated.
    71757534  (defun compute-children-by-name (parent &key only-if-needed-p)
    71767535    (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
    71867545(with-upgradability ()
    71877546  (defclass module (child-component parent-component)
    7188     (#+clisp (components)))) ;; backward compatibility during upgrade only
     7547    (#+clisp (components)) ;; backward compatibility during upgrade only
     7548    (:documentation "A module is a intermediate component with both a parent and children,
     7549typically but not necessarily representing the files in a subdirectory of the build source.")))
    71917552;;;; component pathnames
    71927553(with-upgradability ()
    7193   (defgeneric* (component-parent-pathname) (component))
     7554  (defgeneric* (component-parent-pathname) (component)
     7555    (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
    71947556  (defmethod component-parent-pathname (component)
    71957557    (component-pathname (component-parent component)))
     7559  ;; The default method for component-pathname tries to extract a cached precomputed
     7560  ;; absolute-pathname from the relevant slot, and if not, computes it by merging the
     7561  ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute)
     7562  ;; with the directory of the component-parent-pathname.
    71977563  (defmethod component-pathname ((component component))
    71987564    (if (slot-boundp component 'absolute-pathname)
    72087574          pathname)))
     7576  ;; Default method for component-relative-pathname:
     7577  ;; combine the contents of slot relative-pathname (from specified initarg :pathname)
     7578  ;; with the appropriate source-file-type, which defaults to the file-type of the component.
    72107579  (defmethod component-relative-pathname ((component component))
    72117580    ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
    72417610;;;; around-compile-hook
    72427611(with-upgradability ()
    7243   (defgeneric around-compile-hook (component))
     7612  (defgeneric around-compile-hook (component)
     7613    (:documentation "An optional hook function that will be called with one argument, a thunk.
     7614The hook function must call the thunk, that will compile code from the component, and may or may not
     7615also evaluate the compiled results. The hook function may establish dynamic variable bindings around
     7616this compilation, or check its results, etc."))
    72447617  (defmethod around-compile-hook ((c component))
    72457618    (cond
    72707643(with-upgradability ()
    72717644  (defun sub-components (component &key (type t))
     7645    "Compute the transitive sub-components of given COMPONENT that are of given TYPE"
    72727646    (while-collecting (c)
    72737647      (labels ((recurse (x)
    73047678(with-upgradability ()
    7305   (defgeneric* (find-system) (system &optional error-p))
     7679  ;; The method is actually defined in asdf/find-system,
     7680  ;; but we declare the function here to avoid a forward reference.
     7681  (defgeneric* (find-system) (system &optional error-p)
     7682    (:documentation "Given a system designator, find the actual corresponding system object.
     7683If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
     7684A system designator is usually a string (conventionally all lowercase) or a symbol, designating
     7685the same system as its downcased name; it can also be a system object (designating itself)."))
    73067686  (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
    73077687    (:documentation "Return the source file in which system is defined."))
    7308   (defgeneric component-build-pathname (component))
    7310   (defgeneric component-entry-point (component))
     7688  ;; This is bad design, but was the easiest kluge I found to let the user specify that
     7689  ;; some special actions create outputs at locations controled by the user that are not affected
     7690  ;; by the usual output-translations.
     7691  ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't
     7692  ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert
     7693  ;; *there* the ability of specifying special output paths, not in the system definition.
     7694  (defgeneric component-build-pathname (component)
     7695    (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the
     7696output pathname for the action using the COMPONENT-BUILD-OPERATION.
     7698NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
     7700  ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead?
     7701  (defgeneric component-entry-point (component)
     7702    (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call
     7703(with no argument) when running an image dumped from the COMPONENT.
     7705NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
    73117706  (defmethod component-entry-point ((c component))
    73127707    nil))
    73197714    ;; To preserve identity for all objects, we'd need keep the components slots
    73207715    ;; but also to modify parse-component-form to reset the recycled objects.
    7321     ((name) (source-file) #|(children) (children-by-names)|#))
     7716    ((name) (source-file) #|(children) (children-by-names)|#)
     7717    (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
     7718a SYSTEM is redefined and its class is modified."))
    73237720  (defclass system (module proto-system)
    73477744     ;; these two are specially set in parse-component-form, so have no :INITARGs.
    73487745     (depends-on :reader system-depends-on :initform nil)
    7349      (weakly-depends-on :reader system-weakly-depends-on :initform nil)))
     7746     (weakly-depends-on :reader system-weakly-depends-on :initform nil))
     7747    (:documentation "SYSTEM is the base class for top-level components that users may request
     7748ASDF to build."))
    73517751  (defun reset-system (system &rest keys &key &allow-other-keys)
     7752    "Erase any data from a SYSTEM except its basic identity, then reinitialize it
     7753based on supplied KEYS."
    73527754    (change-class (change-class system 'proto-system) 'system)
    73537755    (apply 'reinitialize-instance system keys)))
    73587760(with-upgradability ()
     7761  ;; Resolve a system designator to a system before extracting its system-source-file
    73597762  (defmethod system-source-file ((system-name string))
    73607763    (system-source-file (find-system system-name)))
    73697772  (defun (system-relative-pathname) (system name &key type)
     7773    "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
     7774return the absolute pathname of a corresponding file under that system's source code pathname."
    73707775    (subpathname (system-source-directory system) name :type type))
    73727777  (defmethod component-pathname ((system system))
     7778    "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
     7779return the absolute pathname of a corresponding file under that system's source code pathname."
    73737780    (let ((pathname (or (call-next-method) (system-source-directory system))))
    73747781      (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
    73777784      pathname))
     7786  ;; The default method of component-relative-pathname for a system:
     7787  ;; if a pathname was specified in the .asd file, it must be relative to the .asd file
     7788  ;; (actually, to its truename* if *resolve-symlinks* it true, the default).
     7789  ;; The method will return an *absolute* pathname, once again showing that the historical name
     7790  ;; component-relative-pathname is misleading and should have been component-specified-pathname.
    73797791  (defmethod component-relative-pathname ((system system))
    73807792    (parse-unix-namestring
    73867798     :defaults (system-source-directory system)))
     7800  ;; A system has no parent; if some method wants to make a path "relative to its parent",
     7801  ;; it will instead be relative to the system itself.
    73887802  (defmethod component-parent-pathname ((system system))
    73897803    (system-source-directory system))
     7805  ;; Most components don't have a specified component-build-pathname, and therefore
     7806  ;; no magic redirection of their output that disregards the output-translations.
    73917807  (defmethod component-build-pathname ((c component))
    73927808    nil))
    73947810;;;; -------------------------------------------------------------------------
    7395 ;;;; Stamp cache
     7811;;;; Session cache
    73977813(uiop/package:define-package :asdf/cache
    74047820(in-package :asdf/cache)
    7406 ;;; This stamp cache is useful for:
    7407 ;; * consistency of stamps used within a single run
    7408 ;; * fewer accesses to the filesystem
    7409 ;; * the ability to test with fake timestamps, without touching files
    7411 (with-upgradability ()
     7822;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
     7823;; * Consistency in the view of the world relied on by ASDF within a given session.
     7824;;   Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
     7825;;   (a.k.a. stack overflows) and other erratic behavior.
     7826;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
     7827;;   no expensive recomputations of transitive dependencies for some input-files or output-files.
     7828;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
     7830(with-upgradability ()
     7831  ;; The session cache variable.
     7832  ;; NIL when outside a session, an equal hash-table when inside a session.
    74127833  (defvar *asdf-cache* nil)
     7835  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
     7836  ;; Return those values.
    74147837  (defun set-asdf-cache-entry (key value-list)
    7415     (apply 'values
    7416            (if *asdf-cache*
    7417                (setf (gethash key *asdf-cache*) value-list)
    7418                value-list)))
     7838    (values-list (if *asdf-cache*
     7839                     (setf (gethash key *asdf-cache*) value-list)
     7840                     value-list)))
     7842  ;; Unset the session cache entry for KEY, when inside a session.
    74207843  (defun unset-asdf-cache-entry (key)
    74217844    (when *asdf-cache*
    74227845      (remhash key *asdf-cache*)))
     7847  ;; Consult the session cache entry for KEY if present and in a session;
     7848  ;; if not present, compute it by calling the THUNK,
     7849  ;; and set the session cache entry accordingly, if in a session.
     7850  ;; Return the values from the cache and/or the thunk computation.
    74247851  (defun consult-asdf-cache (key &optional thunk)
    74257852    (if *asdf-cache*
    74267853        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
    74277854          (if foundp
    7428               (apply 'values results)
     7855              (values-list results)
    74297856              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
    74307857        (call-function thunk)))
     7859  ;; Syntactic sugar for consult-asdf-cache
    74327860  (defmacro do-asdf-cache (key &body body)
    74337861    `(consult-asdf-cache ,key #'(lambda () ,@body)))
     7863  ;; Compute inside a ASDF session with a cache.
     7864  ;; First, make sure an ASDF session is underway, by binding the session cache variable
     7865  ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
     7866  ;; Second, if a new session was started, establish restarts for retrying the overall computation.
     7867  ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
     7868  ;; entry isn't found, or just call the THUNK if no KEY was specified.
    74357869  (defun call-with-asdf-cache (thunk &key override key)
    74367870    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
    74497883                (clear-configuration)))))))
     7885  ;; Syntactic sugar for call-with-asdf-cache
    74517886  (defmacro with-asdf-cache ((&key key override) &body body)
    74527887    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
     7890  ;;; Define specific accessor for file (date) stamp.
     7892  ;; Normalize a namestring for use as a key in the session cache.
    74547893  (defun normalize-namestring (pathname)
    74557894    (let ((resolved (resolve-symlinks*
    74597898      (with-pathname-defaults () (namestring resolved))))
     7900  ;; Compute the file stamp for a normalized namestring
    74617901  (defun compute-file-stamp (normalized-namestring)
    74627902    (with-pathname-defaults ()
    74637903      (safe-file-write-date normalized-namestring)))
     7905  ;; Override the time STAMP associated to a given FILE in the session cache.
     7906  ;; If no STAMP is specified, recompute a new one from the filesystem.
    74657907  (defun register-file-stamp (file &optional (stamp nil stampp))
    74667908    (let* ((namestring (normalize-namestring file))
    74687910      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
     7912  ;; Get or compute a memoized stamp for given FILE from the session cache.
    74707913  (defun get-file-stamp (file)
    74717914    (when file
    74847927   #:coerce-name #:primary-system-name #:coerce-filename
    74857928   #:find-system #:locate-system #:load-asd
    7486    #:system-registered-p #:register-system #:registered-systems* #:registered-systems
     7929   #:system-registered-p #:registered-system #:register-system
     7930   #:registered-systems* #:registered-systems
    74877931   #:clear-system #:map-systems
    74887932   #:missing-component #:missing-requires #:missing-parent
    74947938   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    74957939   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
     7940   #:mark-component-preloaded ;; forward reference to asdf/operate
    74967941   #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
    74977942   #:*defined-systems* #:clear-defined-systems
    75257970           format :format-arguments arguments))
     7973  ;;; Canonicalizing system names
    75277975  (defun coerce-name (name)
     7976    "Given a designator for a component NAME, return the name as a string.
     7977The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
     7978a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
    75287979    (typecase name
    75297980      (component (component-name name))
    7530       (symbol (string-downcase (symbol-name name)))
     7981      (symbol (string-downcase name))
    75317982      (string name)
    75327983      (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
    75347985  (defun primary-system-name (name)
    7535     ;; When a system name has slashes, the file with defsystem is named by
    7536     ;; the first of the slash-separated components.
     7986    "Given a system designator NAME, return the name of the corresponding primary system,
     7987after which the .asd file is named. That's the first component when dividing the name
     7988as a string by / slashes."
    75377989    (first (split-string (coerce-name name) :separator "/")))
    75397991  (defun coerce-filename (name)
     7992    "Coerce a system designator NAME into a string suitable as a filename component.
     7993The (current) transformation is to replace characters /:\\ each by --,
     7994the former being forbidden in a filename component.
     7995NB: The onus is unhappily on the user to avoid clashes."
    75407996    (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
     7999  ;;; Registry of Defined Systems
    75428001  (defvar *defined-systems* (make-hash-table :test 'equal)
    7543     "This is a hash table whose keys are strings, being the
    7544 names of the systems, and whose values are pairs, the first
     8002    "This is a hash table whose keys are strings -- the
     8003names of systems -- and whose values are pairs, the first
    75458004element of which is a universal-time indicating when the
    75468005system definition was last updated, and the second element
    7547 of which is a system object.")
     8006of which is a system object.
     8007  A system is referred to as \"registered\" if it is present
     8008in this table.")
    75498010  (defun system-registered-p (name)
     8011    "Return a generalized boolean that is true if a system of given NAME was registered already.
     8012NAME is a system designator, to be normalized by COERCE-NAME.
     8013The value returned if true is a pair of a timestamp and a system object."
    75508014    (gethash (coerce-name name) *defined-systems*))
     8016  (defun registered-system (name)
     8017    "Return a system of given NAME that was registered already,
     8018if such a system exists.  NAME is a system designator, to be
     8019normalized by COERCE-NAME. The value returned is a system object,
     8020or NIL if not found."
     8021    (cdr (system-registered-p name)))
    75528023  (defun registered-systems* ()
     8024    "Return a list containing every registered system (as a system object)."
    75538025    (loop :for registered :being :the :hash-values :of *defined-systems*
    75548026          :collect (cdr registered)))
    75568028  (defun registered-systems ()
     8029    "Return a list of the names of every registered system."
    75578030    (mapcar 'coerce-name (registered-systems*)))
    75598032  (defun register-system (system)
     8033    "Given a SYSTEM object, register it."
    75608034    (check-type system system)
    75618035    (let ((name (component-name system)))
    75628036      (check-type name string)
    75638037      (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
    7564       (unless (eq system (cdr (gethash name *defined-systems*)))
     8038      (unless (eq system (registered-system name))
    75658039        (setf (gethash name *defined-systems*)
    7566               (cons (if-let (file (ignore-errors (system-source-file system)))
    7567                       (get-file-stamp file))
     8040              (cons (ignore-errors (get-file-stamp (system-source-file system)))
    75688041                    system)))))
    7570   (defvar *preloaded-systems* (make-hash-table :test 'equal))
     8044  ;;; Preloaded systems: in the image even if you can't find source files backing them.
     8046  (defvar *preloaded-systems* (make-hash-table :test 'equal)
     8047    "Registration table for preloaded systems.")
     8049  (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate
    75728051  (defun make-preloaded-system (name keys)
    7573     (apply 'make-instance (getf keys :class 'system)
    7574            :name name :source-file (getf keys :source-file)
    7575            (remove-plist-keys '(:class :name :source-file) keys)))
     8052    "Make a preloaded system of given NAME with build information from KEYS"
     8053    (let ((system (apply 'make-instance (getf keys :class 'system)
     8054                         :name name :source-file (getf keys :source-file)
     8055                         (remove-plist-keys '(:class :name :source-file) keys))))
     8056      (mark-component-preloaded system)
     8057      system))
    75778059  (defun sysdef-preloaded-system-search (requested)
     8060    "If REQUESTED names a system registered as preloaded, return a new system
     8061with its registration information."
    75788062    (let ((name (coerce-name requested)))
    75798063      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
    75818065          (make-preloaded-system name keys)))))
    7583   (defun register-preloaded-system (system-name &rest keys)
    7584     (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    7586   (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
    7587     ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
    7588     (register-preloaded-system s :version *asdf-version*))
     8067  (defun ensure-preloaded-system-registered (name)
     8068    "If there isn't a registered _defined_ system of given NAME,
     8069and a there is a registered _preloaded_ system of given NAME,
     8070then define and register said preloaded system."
     8071    (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name)))
     8072      (register-system system)))
     8074  (defun ensure-all-preloaded-systems-registered ()
     8075    "Make sure all registered preloaded systems are defined.
     8076This function is run whenever ASDF is upgraded."
     8077    (loop :for name :being :the :hash-keys :of *preloaded-systems*
     8078          :do (ensure-preloaded-system-registered name)))
     8079  (register-hook-function '*post-upgrade-restart-hook* 'ensure-all-preloaded-systems-registered)
     8081  (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys)
     8082    "Register a system as being preloaded. If the system has not been loaded from the filesystem
     8083yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be
     8084registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION).
     8085If VERSION is the default T, and a system was already loaded, then its version will be preserved."
     8086    (let ((name (coerce-name system-name)))
     8087      (when (eql version t)
     8088        (if-let (system (registered-system name))
     8089          (setf (getf keys :version) (component-version system))))
     8090      (setf (gethash name *preloaded-systems*) keys)
     8091      (ensure-preloaded-system-registered system-name)))
     8094  ;;; Immutable systems: in the image and can't be reloaded from source.
    75908096  (defvar *immutable-systems* nil
    7591     "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
     8097    "A hash-set (equal hash-table mapping keys to T) of systems that are immutable,
    75928098i.e. already loaded in memory and not to be refreshed from the filesystem.
    75938099They will be treated specially by find-system, and passed as :force-not argument to make-plan.
    7595 If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
    7596 for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
    7597 downgrade, before you dump an image, use:
    7598    (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
     8101For instance, to can deliver an image with many systems precompiled, that *will not* check the
     8102filesystem for them every time a user loads an extension, what more risk a problematic upgrade
     8103 or catastrophic downgrade, before you dump an image, you may use:
     8104   (map () 'asdf:register-immutable-system (asdf:already-loaded-systems))
     8106Note that direct access to this variable from outside ASDF is not supported.
     8107Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and
     8108contact maintainers if you need a stable API to do more than that.")
    76008110  (defun sysdef-immutable-system-search (requested)
    76018111    (let ((name (coerce-name requested)))
    76028112      (when (and *immutable-systems* (gethash name *immutable-systems*))
    7603         (or (cdr (system-registered-p requested))
    7604             (sysdef-preloaded-system-search name)
     8113        (or (registered-system requested)
    76058114            (error 'formatted-system-definition-error
    7606                    :format-control "Requested system ~A is in the *immutable-systems* set, ~
    7607 but not loaded in memory"
     8115                   :format-control "Requested system ~A registered as an immutable-system, ~
     8116but not even registered as defined"
    76088117                   :format-arguments (list name))))))
    7610   (defun register-immutable-system (system-name &key (version t))
    7611     (let* ((system-name (coerce-name system-name))
    7612            (registered-system (cdr (system-registered-p system-name)))
    7613            (default-version? (eql version t))
    7614            (version (cond ((and default-version? registered-system)
    7615                            (component-version registered-system))
    7616                           (default-version? nil)
    7617                           (t version))))
    7618       (unless registered-system
    7619         (register-system (make-preloaded-system system-name (list :version version))))
    7620       (register-preloaded-system system-name :version version)
     8119(defun register-immutable-system (system-name &rest keys)
     8120  "Register SYSTEM-NAME as preloaded and immutable.
     8121It will automatically be considered as passed to FORCE-NOT in a plan."
     8122    (let ((system-name (coerce-name system-name)))
     8123      (apply 'register-preloaded-system system-name keys)
    76218124      (unless *immutable-systems*
    76228125        (setf *immutable-systems* (list-to-hash-set nil)))
    7623       (setf (gethash (coerce-name system-name) *immutable-systems*) t)))
     8126      (setf (gethash system-name *immutable-systems*) t)))
     8129  ;;; Making systems undefined.
    76258131  (defun clear-system (system)
    7626     "Clear the entry for a SYSTEM in the database of systems previously loaded,
    7627 unless the system appears in the table of *IMMUTABLE-SYSTEMS*.
    7628 Note that this does NOT in any way cause the code of the system to be unloaded.
    7629 Returns T if cleared or already cleared,
    7630 NIL if not cleared because the system was found to be immutable."
     8132    "Clear the entry for a SYSTEM in the database of systems previously defined.
     8133However if the system was registered as PRELOADED (which it is if it is IMMUTABLE),
     8134then a new system with the same name will be defined and registered in its place
     8135from which build details will have been cleared.
     8136Note that this does NOT in any way cause any of the code of the system to be unloaded.
     8137Returns T if system was or is now undefined, NIL if a new preloaded system was redefined."
    76318138    ;; There is no "unload" operation in Common Lisp, and
    76328139    ;; a general such operation cannot be portably written,
    76338140    ;; considering how much CL relies on side-effects to global data structures.
    76348141    (let ((name (coerce-name system)))
    7635       (unless (and *immutable-systems* (gethash name *immutable-systems*))
    7636         (remhash (coerce-name name) *defined-systems*)
    7637         (unset-asdf-cache-entry `(locate-system ,name))
    7638         (unset-asdf-cache-entry `(find-system ,name))
    7639         t)))
     8142      (remhash name *defined-systems*)
     8143      (unset-asdf-cache-entry `(find-system ,name))
     8144      (not (ensure-preloaded-system-registered name))))
    76418146  (defun clear-defined-systems ()
    7642     ;; Invalidate all systems but ASDF itself, if registered.
     8147    "Clear all currently registered defined systems.
     8148Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
    76438149    (loop :for name :being :the :hash-keys :of *defined-systems*
    76448150          :unless (equal name "asdf") :do (clear-system name)))
    76528158called with an object of type asdf:system."
    76538159    (loop :for registered :being :the :hash-values :of *defined-systems*
    7654           :do (funcall fn (cdr registered)))))
    7656 ;;; for the sake of keeping things reasonably neat, we adopt a
    7657 ;;; convention that functions in this list are prefixed SYSDEF-
    7658 (with-upgradability ()
    7659   (defvar *system-definition-search-functions* '())
     8160          :do (funcall fn (cdr registered))))
     8163  ;;; Searching for system definitions
     8165  ;; For the sake of keeping things reasonably neat, we adopt a convention that
     8166  ;; only symbols are to be pushed to this list (rather than e.g. function objects),
     8167  ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF-
     8168  (defvar *system-definition-search-functions* '()
     8169    "A list that controls the ways that ASDF looks for system definitions.
     8170It contains symbols to be funcalled in order, with a requested system name as argument,
     8171until one returns a non-NIL result (if any), which must then be a fully initialized system object
     8172with that name.")
     8174  ;; Initialize and/or upgrade the *system-definition-search-functions*
     8175  ;; so it doesn't contain obsolete symbols, and does contain the current ones.
    76618176  (defun cleanup-system-definition-search-functions ()
    76628177    (setf *system-definition-search-functions*
    76638178          (append
    76648179           ;; Remove known-incompatible sysdef functions from old versions of asdf.
    7665            (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
    7666                       *system-definition-search-functions*)
     8180           ;; Order matters, so we can't just use set-difference.
     8181           (let ((obsolete
     8182                  '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
     8183             (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*))
    76678184           ;; Tuck our defaults at the end of the list if they were absent.
    76688185           ;; This is imperfect, in case they were removed on purpose,
    7669            ;; but then it will be the responsibility of whoever does that
     8186           ;; but then it will be the responsibility of whoever removes these symmbols
    76708187           ;; to upgrade asdf before he does such a thing rather than after.
    76718188           (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
    76748191  (cleanup-system-definition-search-functions)
     8193  ;; This (private) function does the search for a system definition using *s-d-s-f*;
     8194  ;; it is to be called by locate-system.
    76768195  (defun search-for-system-definition (system)
     8196    ;; Search for valid definitions of the system available in the current session.
     8197    ;; Previous definitions as registered in *defined-systems* MUST NOT be considered;
     8198    ;; they will be reconciled by locate-system then find-system.
     8199    ;; There are two special treatments: first, specially search for objects being defined
     8200    ;; in the current session, to avoid definition races between several files;
     8201    ;; second, specially search for immutable systems, so they cannot be redefined.
     8202    ;; Finally, use the search functions specified in *system-definition-search-functions*.
    76778203    (let ((name (coerce-name system)))
    76788204      (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
    76798205        (try 'find-system-if-being-defined)
    76808206        (try 'sysdef-immutable-system-search)
    7681         (map () #'try *system-definition-search-functions*)
    7682         (try 'sysdef-preloaded-system-search))))
     8207        (map () #'try *system-definition-search-functions*))))
     8210  ;;; The legacy way of finding a system: the *central-registry*
     8212  ;; This variable contains a list of directories to be lazily searched for the requested asd
     8213  ;; by sysdef-central-registry-search.
    76848214  (defvar *central-registry* nil
    76858215    "A list of 'system directory designators' ASDF uses to find systems.
    76938223                #p\"/usr/share/common-lisp/systems/\"))
    7695 This is for backward compatibility.
    7696 Going forward, we recommend new users should be using the source-registry.
    7697 ")
     8225This variable is for backward compatibility.
     8226Going forward, we recommend new users should be using the source-registry.")
     8228  ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS.
     8229  ;; Return the truename of that file if it is found and TRUENAME is true.
     8230  ;; Return NIL if the file is not found.
     8231  ;; On Windows, follow shortcuts to .asd files.
    76998232  (defun probe-asd (name defaults &key truename)
    77008233    (block nil
    77198252                (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
     8254  ;; Function to push onto *s-d-s-f* to use the *central-registry*
    77218255  (defun sysdef-central-registry-search (system)
    77228256    (let ((name (primary-system-name system))
    77668300                            (subseq *central-registry* (1+ position))))))))))
     8303  ;;; Methods for find-system
     8305  ;; Reject NIL as a system designator.
    77688306  (defmethod find-system ((name null) &optional (error-p t))
    77698307    (when error-p
    77708308      (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
     8310  ;; Default method for find-system: resolve the argument using COERCE-NAME.
    77728311  (defmethod find-system (name &optional (error-p t))
    77738312    (find-system (coerce-name name) error-p))
    77758314  (defun find-system-if-being-defined (name)
    7776     ;; NB: this depends on a corresponding side-effect in parse-defsystem;
    7777     ;; this protocol may change somewhat in the future.
     8315    ;; This function finds systems being defined *in the current ASDF session*, as embodied by
     8316    ;; its session cache, even before they are fully defined and registered in *defined-systems*.
     8317    ;; The purpose of this function is to prevent races between two files that might otherwise
     8318    ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
     8319    ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
     8320    ;; NB: this function depends on a corresponding side-effect in parse-defsystem;
     8321    ;; the precise protocol between the two functions may change in the future (or not).
    77788322    (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
    77818325                   &key name (external-format (encoding-external-format (detect-encoding pathname)))
    77828326                   &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    7783     ;; Tries to load system definition with canonical NAME from PATHNAME.
     8327    "Load system definitions from PATHNAME.
     8328NAME if supplied is the name of a system expected to be defined in that file.
     8330Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
    77848331    (with-asdf-cache ()
    77858332      (with-standard-io-syntax
    78068353  (defvar *old-asdf-systems* (make-hash-table :test 'equal))
     8355  ;; (Private) function to check that a system that was found isn't an asdf downgrade.
     8356  ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version,
     8357  ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF.
    78088358  (defun check-not-old-asdf-system (name pathname)
    78098359    (or (not (equal name "asdf"))
    78588408PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    78598409PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    7860     (let* ((name (coerce-name name))
    7861            (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    7862            (previous (cdr in-memory))
    7863            (previous (and (typep previous 'system) previous))
    7864            (previous-time (car in-memory))
    7865            (found (search-for-system-definition name))
    7866            (found-system (and (typep found 'system) found))
    7867            (pathname (ensure-pathname
    7868                       (or (and (typep found '(or pathname string)) (pathname found))
    7869                           (and found-system (system-source-file found-system))
    7870                           (and previous (system-source-file previous)))
    7871                       :want-absolute t :resolve-symlinks *resolve-symlinks*))
    7872            (foundp (and (or found-system pathname previous) t)))
    7873       (check-type found (or null pathname system))
    7874       (unless (check-not-old-asdf-system name pathname)
    7875         (cond
    7876           (previous (setf found nil pathname nil))
    7877           (t
    7878            (setf found (sysdef-preloaded-system-search "asdf"))
    7879            (assert (typep found 'system))
    7880            (setf found-system found pathname nil))))
    7881       (values foundp found-system pathname previous previous-time)))
     8410    (with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
     8411      ;; and keeping a negative cache was a bug (see lp#1335323), which required
     8412      ;; explicit invalidation in clear-system and find-system (when unsucccessful).
     8413      (let* ((name (coerce-name name))
     8414             (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     8415             (previous (cdr in-memory))
     8416             (previous (and (typep previous 'system) previous))
     8417             (previous-time (car in-memory))
     8418             (found (search-for-system-definition name))
     8419             (found-system (and (typep found 'system) found))
     8420             (pathname (ensure-pathname
     8421                        (or (and (typep found '(or pathname string)) (pathname found))
     8422                            (and found-system (system-source-file found-system))
     8423                            (and previous (system-source-file previous)))
     8424                        :want-absolute t :resolve-symlinks *resolve-symlinks*))
     8425             (foundp (and (or found-system pathname previous) t)))
     8426        (check-type found (or null pathname system))
     8427        (unless (check-not-old-asdf-system name pathname)
     8428          (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
     8429          (setf found-system nil pathname nil))
     8430        (values foundp found-system pathname previous previous-time))))
     8432  ;; Main method for find-system: first, make sure the computation is memoized in a session cache.
     8433  ;; unless the system is immutable, use locate-system to find the primary system;
     8434  ;; reconcile the finding (if any) with any previous definition (in a previous session,
     8435  ;; preloaded, with a previous configuration, or before filesystem changes), and
     8436  ;; load a found .asd if appropriate. Finally, update registration table and return results.
    78838437  (defmethod find-system ((name string) &optional (error-p t))
    78848438    (with-asdf-cache (:key `(find-system ,name))
    78868440        (unless (equal name primary-name)
    78878441          (find-system primary-name nil)))
    7888       (or (and *immutable-systems* (gethash name *immutable-systems*)
    7889                (or (cdr (system-registered-p name))
    7890                    (sysdef-preloaded-system-search name)))
     8442      (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))
    78918443          (multiple-value-bind (foundp found-system pathname previous previous-time)
    78928444              (locate-system name)
    79088460                                                    (physicalize-pathname previous-pathname))))
    79098461                                          (stamp<= stamp previous-time))))))
    7910                 ;; only load when it's a pathname that is different or has newer content, and not an old asdf
     8462                ;; Only load when it's a pathname that is different or has newer content.
    79118463                (load-asd pathname :name name)))
    7912             (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     8464            ;; Try again after having loaded from disk if needed
     8465            (let ((in-memory (system-registered-p name)))
    79138466              (cond
    79148467                (in-memory
    79188471                (error-p
    79198472                 (error 'missing-component :requires name))
    7920                 (t ;; not found: don't keep negative cache, see lp#1335323
    7921                  (unset-asdf-cache-entry `(locate-system ,name))
     8473                (t
    79228474                 (return-from find-system nil)))))))))
    79238475;;;; -------------------------------------------------------------------------
    79748526(with-upgradability ()
    7975   (defgeneric* (find-component) (base path)
    7976     (:documentation "Find a component by resolving the PATH starting from BASE parent"))
    7977   (defgeneric resolve-dependency-combination (component combinator arguments))
    7979   (defmethod find-component ((base string) path)
    7980     (let ((s (find-system base nil)))
    7981       (and s (find-component s path))))
    7983   (defmethod find-component ((base symbol) path)
     8527  (defgeneric* (find-component) (base path &key registered)
     8528    (:documentation "Find a component by resolving the PATH starting from BASE parent.
     8529If REGISTERED is true, only search currently registered systems."))
     8530  (defgeneric resolve-dependency-combination (component combinator arguments)
     8531    (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
     8532in the context of COMPONENT"))
     8534  ;; Methods for find-component
     8536  ;; If the base component is a string, resolve it as a system, then if not nil follow the path.
     8537  (defmethod find-component ((base string) path &key registered)
     8538    (if-let ((s (if registered
     8539                    (registered-system base)
     8540                    (find-system base nil))))
     8541      (find-component s path :registered registered)))
     8543  ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that.
     8544  ;; If nil, use the path as base if not nil, or else return nil.
     8545  (defmethod find-component ((base symbol) path &key registered)
    79848546    (cond
    7985       (base (find-component (coerce-name base) path))
    7986       (path (find-component path nil))
     8547      (base (find-component (coerce-name base) path :registered registered))
     8548      (path (find-component path nil :registered registered))
    79878549      (t    nil)))
    7989   (defmethod find-component ((base cons) path)
    7990     (find-component (car base) (cons (cdr base) path)))
    7992   (defmethod find-component ((parent parent-component) (name string))
    7993     (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!!
     8551  ;; If the base component is a cons cell, resolve its car, and add its cdr to the path.
     8552  (defmethod find-component ((base cons) path &key registered)
     8553    (find-component (car base) (cons (cdr base) path) :registered registered))
     8555  ;; If the base component is a parent-component and the path a string, find the named child.
     8556  (defmethod find-component ((parent parent-component) (name string) &key registered)
     8557    (declare (ignorable registered))
     8558    (compute-children-by-name parent :only-if-needed-p t)
    79948559    (values (gethash name (component-children-by-name parent))))
    7996   (defmethod find-component (base (name symbol))
     8561  ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base.
     8562  (defmethod find-component (base (name symbol) &key registered)
    79978563    (if name
    7998         (find-component base (coerce-name name))
     8564        (find-component base (coerce-name name) :registered registered)
    79998565        base))
    8001   (defmethod find-component ((c component) (name cons))
    8002     (find-component (find-component c (car name)) (cdr name)))
    8004   (defmethod find-component ((base t) (actual component))
     8567  ;; If the path is a cons, first resolve its car as path, then its cdr.
     8568  (defmethod find-component ((c component) (name cons) &key registered)
     8569    (find-component (find-component c (car name) :registered registered)
     8570                    (cdr name) :registered registered))
     8572  ;; If the path is a component, return it, disregarding the base.
     8573  (defmethod find-component ((base t) (actual component) &key registered)
     8574    (declare (ignorable registered))
    80058575    actual)
     8577  ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint.
     8578  ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec.
    80078579  (defun resolve-dependency-name (component name &optional version)
    80088580    (loop
    80358607              (unset-asdf-cache-entry `(locate-system ,name))))))))
     8609  ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
     8610  ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
     8611  ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON.
    80388612  (defun resolve-dependency-spec (component dep-spec)
    80398613    (let ((component (find-component () component)))
    80428616          (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
     8618  ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications.
    80448619  (defmethod resolve-dependency-combination (component combinator arguments)
    8045     (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
    8046            (cons combinator arguments) component))
     8620    (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
     8621                     'resolve-dependency-combination (cons combinator arguments) component))
    80488623  (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
    80758650(with-upgradability ()
    80768651  (defclass operation ()
    8077     ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
    8078       :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
    8080   ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not
    8081   ;; already bound.
     8652    ((original-initargs ;; for backward-compat -- used by GBBopen, and swank (via operation-forced)
     8653      :initform nil :initarg :original-initargs :accessor operation-original-initargs))
     8654    (:documentation "The base class for all ASDF operations.
     8656ASDF does NOT, never did and never will distinguish between multiple operations of the same class.
     8657Therefore, all slots of all operations must have (:allocation class) and no initargs.
     8659Any exceptions currently maintained for backward-compatibility are deprecated,
     8660and support for them may be discontinued at any moment.
     8663  ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not already bound.
     8664  ;; This is a deprecated feature temporarily maintained for backward compatibility.
     8665  ;; It will be removed at some point in the future.
    80828666  (defmethod initialize-instance :after ((o operation) &rest initargs
    80838667                                         &key force force-not system verbose &allow-other-keys)
    80958679(with-upgradability ()
     8680  ;; A table to memoize instances of a given operation. There shall be only one.
    80968681  (defparameter* *operations* (make-hash-table :test 'equal))
     8683  ;; A memoizing way of creating instances of operation.
    80988684  (defun make-operation (operation-class &rest initargs)
     8685    "This function creates and memoizes an instance of OPERATION-CLASS.
     8686All operation instances MUST be created through this function.
     8688Use of INITARGS is for backward compatibility and may be discontinued at any time."
    80998689    (let ((class (coerce-class operation-class
    81008690                               :package :asdf/interface :super 'operation :error 'sysdef-error)))
    81028692                      (list* 'make-instance class initargs))))
     8694  ;; We preserve the operation-original-initargs of the context,
     8695  ;; but only as an unsupported feature.
     8696  ;; This is all done purely for the temporary sake of backwards compatibility.
    81048697  (defgeneric find-operation (context spec)
    81058698    (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
    81408733(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
    8141   (deftype action () '(cons operation component)) ;; a step to be performed while building
     8735  (deftype action ()
     8736    "A pair of operation and component uniquely identifies a node in the dependency graph
     8737of steps to be performed while building a system."
     8738    '(cons operation component))
    81438740  (deftype operation-designator ()
    8144     ;; an operation designates itself,
    8145     ;; nil designates a context-dependent current operation, and
    8146     ;; class-name or class designates an instance of the designated class.
     8741    "An operation designates itself. NIL designates a context-dependent current operation,
     8742and a class-name or class designates the canonical instance of the designated class."
    81478743    '(or operation null symbol class)))
     8746;;; TODO: These should be moved to asdf/plan and be made simple defuns.
    81498747(with-upgradability ()
    81508748  (defgeneric traverse-actions (actions &key &allow-other-keys))
    81528750  (defgeneric required-components (component &key &allow-other-keys)))
    8154 ;;;; Reified representation for storage or debugging. Note: dropping original-initargs
     8753;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
    81558754(with-upgradability ()
    81568755  (defun action-path (action)
     8756    "A readable data structure that identifies the action."
    81578757    (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
    81588758  (defun find-action (path)
     8759    "Reconstitute an action from its action-path"
    81598760    (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
    81628763;;;; Convenience methods
    81638764(with-upgradability ()
     8765  ;; A macro that defines convenience methods for a generic function (gf) that
     8766  ;; dispatches on operation and component.  The convenience methods allow users
     8767  ;; to call the gf with operation and/or component designators, that the
     8768  ;; methods will resolve into actual operation and component objects, so that
     8769  ;; the users can interact using readable designators, but developers only have
     8770  ;; to write methods that handle operation and component objects.
     8771  ;; FUNCTION is the generic function name
     8772  ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
     8773  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
     8774  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
     8775  ;; If OPERATION-INITARGS is true, then for backward compatibility the function has
     8776  ;; a &rest argument that is passed into the operation's initargs if and when it is created.
    81648777  (defmacro define-convenience-action-methods
    81658778      (function formals &key if-no-operation if-no-component operation-initargs)
    82118824    (format nil (compatfmt "~@<~A on ~A~@:>")
    82128825            (type-of operation) component))
    8213   (defgeneric* (explain) (operation component))
     8827  ;; This is for compatibility with ASDF 1, and is deprecated.
     8828  ;; TODO: move it to backward-interface
     8829  (defgeneric* (explain) (operation component)
     8830    (:documentation "Display a message describing an action"))
    82148831  (defmethod explain ((o operation) (c component))
    82158832    (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
    82188835  (defun format-action (stream action &optional colon-p at-sign-p)
     8836    "FORMAT helper to display an action's action-description.
     8837Use it in FORMAT control strings as ~/asdf-action:format-action/"
    82198838    (assert (null colon-p)) (assert (null at-sign-p))
    82208839    (destructuring-bind (operation . component) action
    83778996;;;; Inputs, Outputs, and invisible dependencies
    83788997(with-upgradability ()
    8379   (defgeneric* (output-files) (operation component))
    8380   (defgeneric* (input-files) (operation component))
     8998  (defgeneric* (output-files) (operation component)
     8999    (:documentation "Methods for this function return two values: a list of output files
     9000corresponding to this action, and a boolean indicating if they have already been subjected
     9001to relevant output translations and should not be further translated.
     9003Methods on PERFORM *must* call this function to determine where their outputs are to be located.
     9004They may rely on the order of the files to discriminate between outputs.
     9006  (defgeneric* (input-files) (operation component)
     9007    (:documentation "A list of input files corresponding to this action.
     9009Methods on PERFORM *must* call this function to determine where their inputs are located.
     9010They may rely on the order of the files to discriminate between inputs.
    83819012  (defgeneric* (operation-done-p) (operation component)
    8382     (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
     9013    (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
    83839014  (define-convenience-action-methods output-files (operation component))
    83849015  (define-convenience-action-methods input-files (operation component))
    83889019    t)
     9021  ;; Translate output files, unless asked not to. Memoize the result.
    83909022  (defmethod output-files :around (operation component)
    8391     "Translate output files, unless asked not to. Memoize the result."
    83929023    operation component ;; hush genera, not convinced by declare ignorable(!)
    83939024    (do-asdf-cache `(output-files ,operation ,component)
    84149045      (first files)))
     9047  ;; Memoize input files.
    84169048  (defmethod input-files :around (operation component)
    8417     "memoize input files."
    84189049    (do-asdf-cache `(input-files ,operation ,component)
    84199050      (call-next-method)))
     9052  ;; By default an action has no input-files.
    84219053  (defmethod input-files ((o operation) (c component))
    84229054    nil)
     9056  ;; An action with a selfward-operation by default gets its input-files from the output-files of
     9057  ;; the actions using selfward-operations it depends on (and the same component),
     9058  ;; or if there are none, on the component-pathname of the component if it's a file
     9059  ;; -- and then on the results of the next-method.
    84249060  (defmethod input-files ((o selfward-operation) (c component))
    84259061    `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
    84329068;;;; Done performing
    84339069(with-upgradability ()
    8434   (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
    8435   (defgeneric (setf component-operation-time) (time operation component))
     9070  ;; ASDF4: hide it behind plan-action-stamp
     9071  (defgeneric component-operation-time (operation component)
     9072    (:documentation "Return the timestamp for when an action was last performed"))
     9073  (defgeneric (setf component-operation-time) (time operation component)
     9074    (:documentation "Update the timestamp for when an action was last performed"))
    84369075  (define-convenience-action-methods component-operation-time (operation component))
    8438   (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
     9077  ;; ASDF4: hide it behind (setf plan-action-stamp)
     9078  (defgeneric mark-operation-done (operation component)
     9079    (:documentation "Mark a action as having been just done.
     9081Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
     9082using the JUST-DONE flag."))
    84399083  (defgeneric compute-action-stamp (plan operation component &key just-done)
    84409084    (:documentation "Has this action been successfully done already,
    84419085and at what known timestamp has it been done at or will it be done at?
    84429086Takes two keywords JUST-DONE and PLAN:
    8443 JUST-DONE is a boolean that is true if the action was just successfully performed,
    8444 at which point we want compute the actual stamp and warn if files are missing;
    8445 otherwise we are making plans, anticipating the effects of the action.
    8446 PLAN is a plan object modelling future effects of actions,
    8447 or NIL to denote what actually happened.
     9087* JUST-DONE is a boolean that is true if the action was just successfully performed,
     9088  at which point we want compute the actual stamp and warn if files are missing;
     9089  otherwise we are making plans, anticipating the effects of the action.
     9090* PLAN is a plan object modelling future effects of actions,
     9091  or NIL to denote what actually happened.
    84489092Returns two values:
    84499093* a STAMP saying when it was done or will be done,
    8450   or T if the action has involves files that need to be recomputed.
     9094  or T if the action involves files that need to be recomputed.
    84519095* a boolean DONE-P that indicates whether the action has actually been done,
    84529096  and both its output-files and its in-image side-effects are up to date."))
    84799123;;;; Perform
    84809124(with-upgradability ()
    8481   (defgeneric* (perform-with-restarts) (operation component))
    8482   (defgeneric* (perform) (operation component))
     9125  (defgeneric* (perform) (operation component)
     9126    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
    84839127  (define-convenience-action-methods perform (operation component))
    84979141       'perform (cons o c))))
     9143  ;; The restarts of the perform-with-restarts variant matter in an interactive context.
     9144  ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
     9145  ;; may call perform directly rather than call p-w-r.
     9146  (defgeneric* (perform-with-restarts) (operation component)
     9147    (:documentation "PERFORM an action in a context where suitable restarts are in place."))
    84999148  (defmethod perform-with-restarts (operation component)
    8500     ;; TOO verbose, especially as the default. Add your own :before method
    8501     ;; to perform-with-restart or perform if you want that:
    8502     #|(explain operation component)|#
    85039149    (perform operation component))
    85049150  (defmethod perform-with-restarts :around (operation component)
    85419187(with-upgradability ()
    85429188  (defclass cl-source-file (source-file)
    8543     ((type :initform "lisp")))
     9189    ((type :initform "lisp"))
     9190    (:documentation "Component class for a Common Lisp source file (using type \"lisp\")"))
    85449191  (defclass (cl-source-file)
    8545     ((type :initform "cl")))
     9192    ((type :initform "cl"))
     9193    (:documentation "Component class for a Common Lisp source file using type \"cl\""))
    85469194  (defclass cl-source-file.lsp (cl-source-file)
    8547     ((type :initform "lsp"))))
     9195    ((type :initform "lsp"))
     9196    (:documentation "Component class for a Common Lisp source file using type \"lsp\"")))
    85509199;;;; Operation classes
    85519200(with-upgradability ()
    8552   (defclass basic-load-op (operation) ())
     9201  (defclass basic-load-op (operation) ()
     9202    (:documentation "Base class for operations that apply the load-time effects of a file"))
    85539203  (defclass basic-compile-op (operation)
     9204    ;; NB: These slots are deprecated. They are for backward compatibility only,
     9205    ;; and will be removed at some point in the future.
    85549206    ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    8555      (flags :initarg :flags :accessor compile-op-flags :initform nil))))
     9207     (flags :initarg :flags :accessor compile-op-flags :initform nil))
     9208    (:documentation "Base class for operations that apply the compile-time effects of a file")))
    85579211;;; Our default operations: loading into the current lisp image
    85599213  (defclass prepare-op (upward-operation sideway-operation)
    85609214    ((sideway-operation :initform 'load-op :allocation :class))
    8561     (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT."))
     9215    (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT."))
    85629216  (defclass load-op (basic-load-op downward-operation selfward-operation)
    85639217    ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
    85649218    ;; so we need to directly depend on prepare-op for its side-effects in the current image.
    8565     ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
     9219    ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))
     9220    (:documentation "Operation for loading the compiled FASL for a Lisp file"))
    85669221  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
    8567     ((selfward-operation :initform 'prepare-op :allocation :class)))
     9222    ((selfward-operation :initform 'prepare-op :allocation :class))
     9223    (:documentation "Operation for compiling a Lisp file to a FASL"))
    85699226  (defclass prepare-source-op (upward-operation sideway-operation)
    8570     ((sideway-operation :initform 'load-source-op :allocation :class)))
     9227    ((sideway-operation :initform 'load-source-op :allocation :class))
     9228    (:documentation "Operation for loading the dependencies of a Lisp file as source."))
    85719229  (defclass load-source-op (basic-load-op downward-operation selfward-operation)
    8572     ((selfward-operation :initform 'prepare-source-op :allocation :class)))
     9230    ((selfward-operation :initform 'prepare-source-op :allocation :class))
     9231    (:documentation "Operation for loading a Lisp file as source."))
    85749233  (defclass test-op (selfward-operation)
    8575     ((selfward-operation :initform 'load-op :allocation :class))))
    8578 ;;;; prepare-op, compile-op and load-op
     9234    ((selfward-operation :initform 'load-op :allocation :class))
     9235    (:documentation "Operation for running the tests for system.
     9236If the tests fail, an error will be signaled.")))
     9239;;;; Methods for prepare-op, compile-op and load-op
    85809241;;; prepare-op
    85939254  (defmethod action-description ((o compile-op) (c parent-component))
    85949255    (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
    8595   (defgeneric call-with-around-compile-hook (component thunk))
     9256  (defgeneric call-with-around-compile-hook (component thunk)
     9257    (:documentation "A method to be called around the PERFORM'ing of actions that apply the
     9258compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used
     9259to setup readtables and other variables that control reading, macroexpanding, and compiling, etc.
     9260Note that it will NOT be called around the performing of LOAD-OP."))
    85969261  (defmethod call-with-around-compile-hook ((c component) function)
    85979262    (call-around-hook (around-compile-hook c) function))
    85989263  (defun perform-lisp-compilation (o c)
     9264    "Perform the compilation of the Lisp file associated to the specified action (O . C)."
    85999265    (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
    86009266          ;; we consult input-files, the first of which should be the one to compile-file
    86019267          (input-file (first (input-files o c)))
    8602           ;; on some implementations, there are more than one output-file,
     9268          ;; On some implementations, there are more than one output-file,
    86039269          ;; but the first one should always be the primary fasl that gets loaded.
    86049270          (outputs (output-files o c)))
    86289294        (check-lisp-compile-results output warnings-p failure-p
    86299295                                    "~/asdf-action::format-action/" (list (cons o c))))))
    86319296  (defun report-file-p (f)
     9297    "Is F a build report file containing, e.g., warnings to check?"
    86329298    (equalp (pathname-type f) "build-report"))
    86339299  (defun perform-lisp-warnings-check (o c)
     9300    "Check the warnings associated with the dependencies of an action."
    86349301    (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
    86359302           (actual-warnings-files (loop :for w :in expected-warnings-files
    86479314    (perform-lisp-compilation o c))
    86489315  (defun lisp-compilation-output-files (o c)
     9316    "Compute the output-files for compiling the Lisp file for the specified action (O . C),
     9317an OPERATION and a COMPONENT."
    86499318    (let* ((i (first (input-files o c)))
    86509319           (f (compile-file-pathname
    86689337  (defmethod perform ((o compile-op) (c static-file))
    86699338    nil)
     9340  ;; Performing compile-op on a system will check the deferred warnings for the system
    86709341  (defmethod perform ((o compile-op) (c system))
    86719342    (when (and *warnings-file-type* (not (builtin-system-p c)))
    87019372          (perform (find-operation o 'compile-op) c)))))
    87029373  (defun perform-lisp-load-fasl (o c)
     9374    "Perform the loading of a FASL associated to specified action (O . C),
     9375an OPERATION and a COMPONENT."
    87039376    (if-let (fasl (first (input-files o c)))
    87049377      (load* fasl)))
    87279400    (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
    87289401  (defun perform-lisp-load-source (o c)
     9402    "Perform the loading of a Lisp file as associated to specified action (O . C)"
    87299403    (call-with-around-compile-hook
    87309404     c #'(lambda ()
    87459419    "Testing a system is _never_ done."
    87469420    nil))
    87489421;;;; -------------------------------------------------------------------------
    87499422;;;; Plan
    87569429   :asdf/operation :asdf/action :asdf/lisp-action)
    87579430  (:export
    8758    #:component-operation-time #:mark-operation-done
     9431   #:component-operation-time
    87599432   #:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
    87609433   #:planned-action-status #:plan-action-status #:action-already-done-p
    87809453;;;; Generic plan traversal class
    87819454(with-upgradability ()
    8782   (defclass plan () ())
     9455  (defclass plan () ()
     9456    (:documentation "Base class for a plan based on which ASDF can build a system"))
    87839457  (defclass plan-traversal (plan)
    8784     ((system :initform nil :initarg :system :accessor plan-system)
     9458    (;; The system for which the plan is computed
     9459     (system :initform nil :initarg :system :accessor plan-system)
     9460     ;; Table of systems specified via :force arguments
    87859461     (forced :initform nil :initarg :force :accessor plan-forced)
     9462     ;; Table of systems specified via :force-not argument (and/or immutable)
    87869463     (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
     9464     ;; Counts of total actions in plan
    87879465     (total-action-count :initform 0 :accessor plan-total-action-count)
     9466     ;; Count of actions that need to be performed
    87889467     (planned-action-count :initform 0 :accessor plan-planned-action-count)
     9468     ;; Count of actions that need to be performed that have a non-empty list of output-files.
    87899469     (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
     9470     ;; Table that to actions already visited while walking the dependencies associates status
    87909471     (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
    8791      (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)
    8792      (visiting-action-list :initform () :accessor plan-visiting-action-list))))
     9472     ;; Actions that depend on those being currently walked through, to detect circularities
     9473     (visiting-action-set ;; as a set
     9474      :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)
     9475     (visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list
     9476    (:documentation "Base class for plans that simply traverse dependencies")))
    88209504    t) ; default method for non planned-action-status objects
    8822   ;; TODO: eliminate NODE-FOR, use CONS.
    8823   ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION.
     9506  ;; TODO: either confirm there are no operation-original-initargs, eliminate NODE-FOR,
     9507  ;; and use (CONS O C); or keep the operation initargs, and here use MAKE-OPERATION.
    88249508  ;; However, see also component-operation-time and mark-operation-done
    8825   (defun node-for (o c) (cons (type-of o) c))
     9509  (defun node-for (o c)
     9510    "Given operation O and component C, return an object to use as key in action-indexed tables."
     9511    (cons (type-of o) c))
    88279513  (defun action-already-done-p (plan operation component)
     9514    "According to this plan, is this action already done and up to date?"
    88289515    (action-done-p (plan-action-status plan operation component)))
    88439530;;;; forcing
    88449531(with-upgradability ()
    8845   (defgeneric action-forced-p (plan operation component))
    8846   (defgeneric action-forced-not-p (plan operation component))
    8848   (defun normalize-forced-systems (x system)
    8849     (etypecase x
    8850       ((or (member nil :all) hash-table function) x)
    8851       (cons (list-to-hash-set (mapcar #'coerce-name x)))
     9532  (defgeneric action-forced-p (plan operation component)
     9533    (:documentation "Is this action forced to happen in this plan?"))
     9534  (defgeneric action-forced-not-p (plan operation component)
     9535    (:documentation "Is this action forced to not happen in this plan?
     9536Takes precedence over action-forced-p."))
     9538  (defun normalize-forced-systems (force system)
     9539    "Given a SYSTEM on which operate is called and the specified FORCE argument,
     9540extract a hash-set of systems that are forced, or a predicate on system names,
     9541or NIL if none are forced, or :ALL if all are."
     9542    (etypecase force
     9543      ((or (member nil :all) hash-table function) force)
     9544      (cons (list-to-hash-set (mapcar #'coerce-name force)))
    88529545      ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
    8854   (defun normalize-forced-not-systems (x system)
     9547  (defun normalize-forced-not-systems (force-not system)
     9548    "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
     9549and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
     9550or predicate on system names, or NIL if none are forced, or :ALL if all are."
    88559551    (let ((requested
    8856             (etypecase x
    8857               ((or (member nil :all) hash-table function) x)
    8858               (cons (list-to-hash-set (mapcar #'coerce-name x)))
     9552            (etypecase force-not
     9553              ((or (member nil :all) hash-table function) force-not)
     9554              (cons (list-to-hash-set (mapcar #'coerce-name force-not)))
    88599555              ((eql t) (if system (let ((name (coerce-name system)))
    88609556                                    #'(lambda (x) (not (equal x name))))
    8861                            t)))))
     9557                           :all)))))
    88629558      (if (and *immutable-systems* requested)
    8863           #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x)))
     9559          #'(lambda (x) (or (call-function requested x)
     9560                            (call-function *immutable-systems* x)))
    88649561          (or *immutable-systems* requested))))
     9563  ;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
    88669564  (defun action-override-p (plan operation component override-accessor)
     9565    "Given a plan, an action, and a function that given the plan accesses a set of overrides
     9566(i.e. force or force-not), see if the override applies to the current action."
    88679567    (declare (ignore operation))
    88689568    (call-function (funcall override-accessor plan)
    88749574     (action-override-p plan operation component 'plan-forced)
    88759575     ;; You really can't force a builtin system and :all doesn't apply to it,
    8876      ;; except it it's the specifically the system currently being built.
     9576     ;; except if it's the specifically the system currently being built.
    88779577     (not (let ((system (component-system component)))
    88789578            (and (builtin-system-p system)
    88959595  (defgeneric action-valid-p (plan operation component)
    88969596    (:documentation "Is this action valid to include amongst dependencies?"))
     9597  ;; :if-feature will invalidate actions on components for which the features don't apply.
    88979598  (defmethod action-valid-p ((plan t) (o operation) (c component))
    88989599    (if-let (it (component-if-feature c)) (featurep it) t))
     9600  ;; If either the operation or component was resolved to nil, the action is invalid.
    88999601  (defmethod action-valid-p ((plan t) (o null) (c t)) nil)
    89009602  (defmethod action-valid-p ((plan t) (o t) (c null)) nil)
     9603  ;; If the plan is null, i.e., we're looking at reality,
     9604  ;; then any action with actual operation and component objects is valid.
    89019605  (defmethod action-valid-p ((plan null) (o operation) (c component)) t))
    89049608(with-upgradability ()
    89059609  (defgeneric needed-in-image-p (operation component)
    8906     (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful,
    8907     or could it just as well have been done in another Lisp image?"))
     9610    (:documentation "Is the action of OPERATION on COMPONENT needed in the current image
     9611to be meaningful, or could it just as well have been done in another Lisp image?"))
    89099613  (defmethod needed-in-image-p ((o operation) (c component))
    89189622(with-upgradability ()
    89199623  (defun (map-direct-dependencies) (plan operation component fun)
     9624    "Call FUN on all the valid dependencies of the given action in the given plan"
    89209625    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
    89219626           :for dep-o = (find-operation operation dep-o-spec)
    89289633  (defun (reduce-direct-dependencies) (plan operation component combinator seed)
     9634    "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
     9635for each dependency action on the dependency's operation and component and an accumulator
     9636initialized with SEED."
    89299637    (map-direct-dependencies
    89309638     plan operation component
    89359643  (defun (direct-dependencies) (plan operation component)
     9644    "Compute a list of the direct dependencies of the action within the plan"
    89369645    (reduce-direct-dependencies plan operation component #'acons nil))
    89529661    ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
    89539662    ;; hasn't been done in the current image yet, then it can have a non-T timestamp,
    8954     ;; yet a NIL done-in-image-p flag.
     9663    ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
     9664    ;; i.e. that of the input-files.
    89559665    (nest
    89569666     (block ())
    90139723;;;; Generic support for plan-traversal
    90149724(with-upgradability ()
    9015   (defgeneric plan-record-dependency (plan operation component))
    9017   (defgeneric call-while-visiting-action (plan operation component function)
    9018     (:documentation "Detect circular dependencies"))
    90209725  (defmethod initialize-instance :after ((plan plan-traversal)
    90219726                                         &key force force-not system
    90259730      (setf forced-not (normalize-forced-not-systems force-not system))))
    9027   (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
    9028     (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
    9030   (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component))
    9031     (or (and (action-forced-not-p plan o c) (plan-action-status nil o c))
    9032         (values (gethash (node-for o c) (plan-visited-actions plan)))))
    9034   (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system))
    9035     (and (not (action-forced-not-p plan o s)) (call-next-method)))
     9732  (defgeneric plan-actions (plan)
     9733    (:documentation "Extract from a plan a list of actions to perform in sequence"))
     9734  (defmethod plan-actions ((plan list))
     9735    plan)
     9737  (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component))
     9738    (setf (gethash (node-for o c) (plan-visited-actions p)) new-status))
     9740  (defmethod plan-action-status ((p plan-traversal) (o operation) (c component))
     9741    (or (and (action-forced-not-p p o c) (plan-action-status nil o c))
     9742        (values (gethash (node-for o c) (plan-visited-actions p)))))
     9744  (defmethod action-valid-p ((p plan-traversal) (o operation) (s system))
     9745    (and (not (action-forced-not-p p o s)) (call-next-method)))
     9747  (defgeneric plan-record-dependency (plan operation component)
     9748    (:documentation "Record an action as a dependency in the current plan")))
     9751;;;; Detection of circular dependencies
     9752(with-upgradability ()
     9753  (define-condition circular-dependency (system-definition-error)
     9754    ((actions :initarg :actions :reader circular-dependency-actions))
     9755    (:report (lambda (c s)
     9756               (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
     9757                       (circular-dependency-actions c)))))
     9759  (defgeneric call-while-visiting-action (plan operation component function)
     9760    (:documentation "Detect circular dependencies"))
    90379762  (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
    90479772             (funcall fun)
    90489773          (pop action-list)
    9049           (setf (gethash action action-set) nil))))))
     9774          (setf (gethash action action-set) nil)))))
     9776  ;; Syntactic sugar for call-while-visiting-action
     9777  (defmacro while-visiting-action ((p o c) &body body)
     9778    `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))))
    90529781;;;; Actual traversal: traverse-action
    90539782(with-upgradability ()
    9054   (define-condition circular-dependency (system-definition-error)
    9055     ((actions :initarg :actions :reader circular-dependency-actions))
    9056     (:report (lambda (c s)
    9057                (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    9058                        (circular-dependency-actions c)))))
    9060   (defmacro while-visiting-action ((p o c) &body body)
    9061     `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))
    90639783  (defgeneric traverse-action (plan operation component needed-in-image-p))
    91279847(with-upgradability ()
    91289848  (defclass sequential-plan (plan-traversal)
    9129     ((actions-r :initform nil :accessor plan-actions-r)))
    9131   (defgeneric plan-actions (plan))
    9132   (defmethod plan-actions ((plan list))
    9133     plan)
     9849    ((actions-r :initform nil :accessor plan-actions-r))
     9850    (:documentation "Simplest, default plan class, accumulating a sequence of actions"))
    91349852  (defmethod plan-actions ((plan sequential-plan))
    91359853    (reverse (plan-actions-r plan)))
     9855  ;; No need to record a dependency to build a full graph, just accumulate nodes in order.
    91379856  (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component))
    91389857    (values))
    91439862      (push (cons o c) (plan-actions-r p)))))
    91459865;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
    91469866(with-upgradability ()
    91479867  (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
    9148     (:documentation
    9149      "Generate and return a plan for performing OPERATION on COMPONENT."))
     9868    (:documentation "Generate and return a plan for performing OPERATION on COMPONENT."))
    91509869  (define-convenience-action-methods make-plan (plan-class operation component &key))
    9152   (defgeneric perform-plan (plan &key))
    9153   (defgeneric plan-operates-on-p (plan component))
    9155   (defvar *default-plan-class* 'sequential-plan)
     9871  (defgeneric perform-plan (plan &key)
     9872    (:documentation "Actually perform a plan and build the requested actions"))
     9873  (defgeneric plan-operates-on-p (plan component)
     9874    (:documentation "Does this PLAN include any operation on given COMPONENT?"))
     9876  (defvar *default-plan-class* 'sequential-plan
     9877    "The default plan class to use when building with ASDF")
    91579879  (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
    91939915     (component-type :initform t :initarg :component-type :reader plan-component-type)
    91949916     (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
    9195      (keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
     9917     (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
     9918    (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
    91979920  (defmethod initialize-instance :after ((plan filtered-sequential-plan)
    91989921                                         &key force force-not
    9199                                            other-systems)
     9922                                         other-systems)
    92009923    (declare (ignore force force-not))
     9924    ;; Ignore force and force-not, rely on other-systems:
     9925    ;; force traversal of what we're interested in, i.e. current system or also others;
     9926    ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
    92019927    (with-slots (forced forced-not action-filter system) plan
    92029928      (setf forced (normalize-forced-systems (if other-systems :all t) system))
    92119937  (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
     9938    "Given a list of actions, build a plan with these actions as roots."
    92129939    (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
    92139940      (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
    92289955  (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
     9956    "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
     9957return a list of the components involved in building the desired action."
    92299958    (remove-duplicates
    92309959     (mapcar 'cdr (plan-actions
    92549983  (defgeneric* (operate) (operation component &key &allow-other-keys)
    92559984    (:documentation
    9256      "Operate does three things:
    9258 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
    9259 2. It finds the  asdf-system specified by SYSTEM (possibly loading it from disk).
    9260 3. It then calls MAKE-PLAN with the operation and system as arguments
    9262 The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error
    9263 handling code.  If a VERSION argument is supplied, then operate also ensures
    9264 that the system found satisfies it using the VERSION-SATISFIES method.
    9266 Note that dependencies may cause the operation to invoke other operations on the system
    9267 or its components: the new operations will be created with the same initargs as the original one.
     9985     "Operate does mainly four things for the user:
     99871. Resolves the OPERATION designator into an operation object.
     9988   OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION.
     99892. Resolves the COMPONENT designator into a component object.
     9990   COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM.
     99913. It then calls MAKE-PLAN with the operation and system as arguments.
     99924. Finally calls PERFORM-PLAN on the resulting plan to actually build the system.
     9994The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code.
     9995If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
     9996using the VERSION-SATISFIES method.
     9997If a PLAN-CLASS argument is supplied, that class is used for the plan.
    92699999The :FORCE or :FORCE-NOT argument to OPERATE can be:
    927210002  :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
    927310003  (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
    9274 :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
    9276   (define-convenience-action-methods
    9277       operate (operation component &key)
    9278       ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
    9279       ;; but swank.asd relies on :force (!).
    9280       :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
    9281       :if-no-component (error 'missing-component :requires component))
     10004:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.
     10006For backward compatibility, all keyword arguments are passed to MAKE-OPERATION
     10007when instantiating a new operation, that will in turn be inherited by new operations.
     10008But do NOT depend on it, for this is deprecated behavior."))
     10010  (define-convenience-action-methods operate (operation component &key)
     10011    ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
     10012    ;; but swank.asd relies on :force (!).
     10013    :operation-initargs t ;; backward-compatibility with ASDF1. Deprecated.
     10014    :if-no-component (error 'missing-component :requires component))
     10016  ;; TODO: actually, the use as a hash-set is write-only, so it can be reduced to a boolean,
     10017  ;; and then possibly replaced by checking for say *asdf-cache*.
    928310018  (defvar *systems-being-operated* nil
    9284     "A boolean indicating that some systems are being operated on")
     10019    "A hash-set of names of systems being operated on, or NIL")
     10021  ;; This method ensures that an ASDF upgrade is attempted as the very first thing,
     10022  ;; with suitable state preservation in case in case it actually happens,
     10023  ;; and that a few suitable dynamic bindings are established.
    928610024  (defmethod operate :around (operation component &rest keys
    928710025                              &key verbose
    933910077  (defvar *load-system-operation* 'load-op
    934010078    "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
    9341 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle
     10079You may override it with e.g. ASDF:LOAD-BUNDLE-OP from asdf/bundle
    934210080or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
    934510083component-directed strategy for how to load or compile systems.")
     10085  ;; In prepare-op for a system, propagate *load-system-operation* rather than load-op
    934710086  (defmethod component-depends-on ((o prepare-op) (s system))
    9348     (loop :for (o . cs) :in (call-next-method)
    9349           :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
     10087    (loop :for (do . dc) :in (call-next-method)
     10088          :collect (cons (if (eq do 'load-op) *load-system-operation* do) dc)))
    935110090  (defclass build-op (non-propagating-operation) ()
    940010139(with-upgradability ()
    940110140  (defun component-loaded-p (component)
    9402     "has given COMPONENT been successfully loaded in the current image (yet)?"
    9403     (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
     10141    "Has the given COMPONENT been successfully loaded in the current image (yet)?
     10142Note that this returns true even if the component is not up to date."
     10143    (if-let ((component (find-component component () :registered t)))
     10144      (action-already-done-p nil (make-instance 'load-op) component)))
    940510146  (defun already-loaded-systems ()
    940910150  (defun require-system (system &rest keys &key &allow-other-keys)
    9410     "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
     10151    "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
    941110152system or its dependencies if they have already been loaded."
    9412     (apply 'load-system system :force-not (already-loaded-systems) keys)))
     10153    (unless (component-loaded-p system)
     10154      (apply 'load-system system :force-not (already-loaded-systems) keys))))
    941510157;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
    941610158;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
     10159;; Note that despite the two being homonyms, the _function_ require-system
     10160;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes.
    941710161(with-upgradability ()
    941810162  (defvar *modules-being-required* nil)
    943010174           (*modules-being-required* (cons module *modules-being-required*)))
    943110175      (assert (null (component-children s)))
    9432       (require module)))
     10176      ;; CMUCL likes its module names to be all upcase.
     10177      (require #-cmucl module #+cmucl (string-upcase module))))
    943410179  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
    9435     (unless (length=n-p arguments 1)
    9436       (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
    9437              (cons combinator arguments) component combinator))
    9438     (let* ((module (car arguments))
     10180    (unless (and (length=n-p arguments 1)
     10181                 (typep (car arguments) '(or string (and symbol (not null)))))
     10182      (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
     10183                       'resolve-dependency-combination
     10184                       (cons combinator arguments) component combinator))
     10185    ;; :require must be prepared for some implementations providing modules using ASDF,
     10186    ;; as SBCL used to do, and others may might do. Thus, the system provided in the end
     10187    ;; would be a downcased name as per module-provide-asdf above. For the same reason,
     10188    ;; we cannot assume that the system in the end will be of type require-system,
     10189    ;; but must check whether we can use find-system and short-circuit cl:require.
     10190    ;; Otherwise, calling cl:require could result in nasty reentrant calls between
     10191    ;; cl:require and asdf:operate that could potentially blow up the stack,
     10192    ;; all the while defeating the consistency of the dependency graph.
     10193    (let* ((module (car arguments)) ;; NB: we already checked that it was not null
    943910194           (name (string-downcase module))
    944010195           (system (find-system name nil)))
    9441       (assert module)
    9442       ;;(unless (typep system '(or null require-system))
    9443       ;;  (warn "~S depends on ~S but ~S is registered as a ~S"
    9444       ;;        component (cons combinator arguments) module (type-of system)))
    944510196      (or system (let ((system (make-instance 'require-system :name name)))
    944610197                   (register-system system)
    944910200  (defun module-provide-asdf (name)
     10201    ;; We must use string-downcase, because modules are traditionally specified as symbols,
     10202    ;; that implementations traditionally normalize as uppercase, for which we seek a system
     10203    ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine.
     10204    ;; We could make complex, non-portable rules to try to preserve case, and just documenting
     10205    ;; them would be a hell that it would be a disservice to inflict on users.
    945010206    (let ((module (string-downcase name)))
    945110207      (unless (member module *modules-being-required* :test 'equal)
    945510211              ((style-warning #'muffle-warning)
    945610212               (missing-component (constantly nil))
    9457                (uiop:fatal-condition #'(lambda (e)
    9458                           (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
    9459                                   name e))))
     10213               (fatal-condition
     10214                #'(lambda (e)
     10215                    (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
     10216                            name e))))
    946010217            (let ((*verbose-out* (make-broadcast-stream)))
    946110218              (let ((system (find-system module nil)))
    947410231        (clrhash *asdf-cache*)
    947510232        (dolist (s l) (find-system s nil)))))
    9476   (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
     10233  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)
     10235  ;; The following function's symbol is from asdf/find-system.
     10236  ;; It is defined here to resolve what would otherwise be forward package references.
     10237  (defun mark-component-preloaded (component)
     10238    "Mark a component as preloaded."
     10239    (let ((component (find-component component nil :registered t)))
     10240      ;; Recurse to children, so asdf/plan will hopefully be happy.
     10241      (map () 'mark-component-preloaded (component-children component))
     10242      ;; Mark the timestamps of the common lisp-action operations as 0.
     10243      (let ((times (component-operation-times component)))
     10244        (dolist (o '(load-op compile-op prepare-op))
     10245          (setf (gethash o times) 0))))))
    947910247;;;; ---------------------------------------------------------------------------
    950110269(in-package :asdf/output-translations)
     10271;; (setf output-translations) at some point used to be a macro for the sake of
     10272;; obsolete versions of GCL. Make sure that macro doesn't come to haunt us.
    950310273(when-upgrading () (undefine-function '(setf output-translations)))
    951510285  (defun output-translations ()
     10286    "Return the configured output-translations, if any"
    951610287    (car *output-translations*))
     10289  ;; Set the output-translations, by sorting the provided new-value.
    951810290  (defun set-output-translations (new-value)
    951910291    (setf *output-translations*
    953110303  (defun output-translations-initialized-p ()
     10304    "Have the output-translations been initialized yet?"
    953210305    (and *output-translations* t))
    953710310    (values))
    953810311  (register-clear-configuration-hook 'clear-output-translations)
     10314  ;;; Validation of the configuration directives...
    954010316  (defun validate-output-translations-directive (directive)
    956610342               :invalid-form-reporter 'invalid-output-translation))
     10345  ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
    956810346  (defun parse-output-translations-string (string &key location)
    956910347    (cond
    960710385               (return `(:output-translations ,@(nreverse directives)))))))))
     10388  ;; The default sources of configuration for output-translations
    960910389  (defparameter* *default-output-translations*
    961010390    '(environment-output-translations
    961410394      system-output-translations-directory-pathname))
     10396  ;; Compulsory implementation-dependent wrapping for the translations:
     10397  ;; handle implementation-provided systems.
    961610398  (defun wrapping-output-translations ()
    961710399    `(:output-translations
    963010412      :enable-user-cache))
     10414  ;; Relative pathnames of output-translations configuration to XDG configuration directory
    963210415  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
    963310416  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
     10418  ;; Locating various configuration pathnames, depending on input or output intent.
    963510419  (defun user-output-translations-pathname (&key (direction :input))
    963610420    (xdg-config-pathname *output-translations-file* direction))
    964510429  (defun environment-output-translations ()
    964610430    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     10433  ;;; Processing the configuration.
    964810435  (defgeneric process-output-translations (spec &key inherit collect))
    970610493      (process-output-translations-directive directive :inherit inherit :collect collect)))
     10496  ;;; Top-level entry-points to configure output-translations
    970810498  (defun compute-output-translations (&optional parameter)
    970910499    "read the configuration, return it"
    971410504     :test 'equal :from-end t))
     10506  ;; Saving the user-provided parameter to output-translations, if any,
     10507  ;; so we can recompute the translations after code upgrade.
    971610508  (defvar *output-translations-parameter* nil)
     10510  ;; Main entry-point for users.
    971810511  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
    971910512    "read the configuration, initialize the internal configuration variable,
    973710530        (initialize-output-translations)))
     10533  ;; Top-level entry-point to _use_ output-translations
    973910534  (defun* (apply-output-translations) (path)
    974010535    (etypecase path
    975710552              :finally (return p)))))
    975910555  ;; Hook into uiop's output-translation mechanism
    976010556  #-cormanlisp
    976110557  (setf *output-translation-function* 'apply-output-translations)
    9763   #+abcl
     10560  ;;; Implementation-dependent hacks
     10561  #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
    976410562  (defun translate-jar-pathname (source wildcard)
    976510563    (declare (ignore wildcard))
    981910617    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9821   ;; Using ack 1.2 exclusions
     10619  ;; Default list of directories under which the source-registry tree search won't recurse
    982210620  (defvar *default-source-registry-exclusions*
    9823     '(".bzr" ".cdv"
     10621    '(;;-- Using ack 1.2 exclusions
     10622      ".bzr" ".cdv"
    982410623      ;; "~.dep" "" "~.nib" "~.plst" ; we don't support ack wildcards
    982510624      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    982610625      "_sgbak" "autom4te.cache" "cover_db" "_build"
    9827       "debian")) ;; debian often builds stuff under the debian directory... BAD.
     10626      ;;-- debian often builds stuff under the debian directory... BAD.
     10627      "debian"))
     10629  ;; Actual list of directories under which the source-registry tree search won't recurse
    982910630  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     10632  ;; The state of the source-registry after search in configured locations
    983110633  (defvar *source-registry* nil
    983210634    "Either NIL (for uninitialized), or an equal hash-table, mapping
    983310635system names to pathnames of .asd files")
     10637  ;; Saving the user-provided parameter to the source-registry, if any,
     10638  ;; so we can recompute the source-registry after code upgrade.
    983510639  (defvar *source-registry-parameter* nil)
    985910663after having found a .asd file? True by default.")
     10665  ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
     10666  ;; read its contents instead of further recursively querying the filesystem.
    986110667  (defun process-source-registry-cache (directory collect)
    986210668    (let ((cache (ignore-errors
    988410690      (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
     10693  ;;; Validate the configuration forms
    988610695  (defun validate-source-registry-directive (directive)
    988710696    (or (member directive '(:default-registry))
    991010719     directory :source-registry 'validate-source-registry-directive
    991110720               :invalid-form-reporter 'invalid-source-registry))
     10723  ;;; Parse the configuration string
    991310725  (defun parse-source-registry-string (string &key location)
    997410786      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    997510787      :inherit-configuration
    9976       #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     10788      #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
    997710789      #+cmucl (:tree #p"modules:")
    997810790      #+scl (:tree #p"file://modules/")))
    1000310815    (getenv "CL_SOURCE_REGISTRY"))
     10818  ;;; Process the source-registry configuration
    1000510820  (defgeneric* (process-source-registry) (spec &key inherit register))
    1006110876        (process-source-registry-directive directive :inherit inherit :register register))))
     10879  ;; Flatten the user-provided configuration into an ordered list of directories and trees
    1006310880  (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
    1006410881    (remove-duplicates
    1007510892  ;; Will read the configuration and initialize all internal variables.
    10076   (defun compute-source-registry (&optional (parameter *source-registry-parameter*) (registry *source-registry*))
     10893  (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
     10894                                    (registry *source-registry*))
    1007710895    (dolist (entry (flatten-source-registry parameter))
    1007810896      (destructuring-bind (directory &key recurse exclude) entry
    1015110969(with-upgradability ()
    1015210970  (defun determine-system-directory (pathname)
    10153     ;; The defsystem macro calls this function to determine
    10154     ;; the pathname of a system as follows:
    10155     ;; 1. if the pathname argument is an pathname object (NOT a namestring),
     10971    ;; The defsystem macro calls this function to determine the pathname of a system as follows:
     10972    ;; 1. If the pathname argument is an pathname object (NOT a namestring),
    1015610973    ;;    that is already an absolute pathname, return it.
    10157     ;; 2. otherwise, the directory containing the LOAD-PATHNAME
     10974    ;; 2. Otherwise, the directory containing the LOAD-PATHNAME
    1015810975    ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
    1015910976    ;;    if it is indeed available and an absolute pathname, then
    1016110978    ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
    1016210979    ;;    and merged into that DIRECTORY as per SUBPATHNAME.
    10163     ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
    10164     ;;    and may be from within the EVAL-WHEN of a file compilation.
     10980    ;;    Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source,
     10981    ;;    but may be from within the EVAL-WHEN of a file compilation.
    1016510982    ;; If no absolute pathname was found, we return NIL.
    1016610983    (check-type pathname (or null string pathname))
    1017610993;;; Component class
    1017710994(with-upgradability ()
     10995  ;; What :file gets interpreted as, unless overridden by a :default-component-class
    1017810996  (defvar *default-component-class* 'cl-source-file)
    1018311001               (coerce-class
    1018411002                (or (loop :for p = parent :then (component-parent p) :while p
    10185                             :thereis (module-default-component-class p))
     11003                      :thereis (module-default-component-class p))
    1018611004                    *default-component-class*)
    1018711005                :package :asdf/interface :super 'component :error nil))
    1022211040                              type name components)))
     11042  ;; Given a form used as :version specification, in the context of a system definition
     11043  ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
     11044  ;; to an acceptable ASDF-format version.
    1022411045  (defun* (normalize-version) (form &key pathname component parent)
    1022511046    (labels ((invalid (&optional (continuation "using NIL instead"))
    1043011251               (when checked-defsystem-depends-on
    1043111252                 `(:defsystem-depends-on ,checked-defsystem-depends-on)))))
     11253        ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
    1043211254        (set-asdf-cache-entry `(find-system ,name) (list system))
    1043311255        ;; We change-class AFTER we loaded the defsystem-depends-on
    1047111293(with-upgradability ()
    1047211294  (defclass bundle-op (basic-compile-op)
     11295    ;; NB: use of instance-allocated slots for operations is DEPRECATED
     11296    ;; and only supported in a temporary fashion for backward compatibility.
     11297    ;; Supported replacement: Define slots on program-system instead.
    1047311298    ((build-args :initarg :args :initform nil :accessor extra-build-args)
    1047411299     (name-suffix :initarg :name-suffix :initform nil)
    1047511300     (bundle-type :initform :no-output-file :reader bundle-type)
    10476      #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
     11301     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))
     11302    (:documentation "base class for operations that bundle outputs from multiple components"))
    1047811304  (defclass monolithic-op (operation) ()
    1048111307concatenate together a system's components and all of its dependencies, but a
    1048211308simple concatenate operation will concatenate only the components of the system
    10483 itself.")) ;; operation on a system and its dependencies
    1048511311  (defclass monolithic-bundle-op (monolithic-op bundle-op)
    10486     ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
     11312    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
     11313    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
    1048711314    ((prologue-code :initform nil :accessor prologue-code)
    10488      (epilogue-code :initform nil :accessor epilogue-code)))
     11315     (epilogue-code :initform nil :accessor epilogue-code))
     11316    (:documentation "operations that are both monolithic-op and bundle-op"))
    1049011318  (defclass program-system (system)
    1051511343  (defclass gather-op (bundle-op)
     11344    ;; TODO: rename the slot and reader gather-op to gather-operation
    1051611345    ((gather-op :initform nil :allocation :class :reader gather-op)
    1051711346     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
    1052111350    (typep op 'monolithic-op))
     11352  ;; Dependencies of a gather-op are the actions of the dependent operation
     11353  ;; for all the (sorted) required components for loading the system.
     11354  ;; Monolithic operations typically use lib-op as the dependent operation,
     11355  ;; and all system-level dependencies as required components.
     11356  ;; Non-monolithic operations typically use compile-op as the dependent operation,
     11357  ;; and all transitive sub-components as required components (excluding other systems).
    1052311358  (defmethod component-depends-on ((o gather-op) (s system))
    1052411359    (let* ((mono (operation-monolithic-p o))
    1053311368        ,@(call-next-method))))
    10535   ;; create a single fasl for the entire library
     11370  ;; Create a single fasl for the entire library
    1053611371  (defclass basic-compile-bundle-op (bundle-op)
    1053711372    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
    1053811373                  :allocation :class)
    10539      (bundle-type :initform :fasl :allocation :class)))
     11374     (bundle-type :initform :fasl :allocation :class))
     11375    (:documentation "Base class for compiling into a bundle"))
     11377  ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
    1054111378  (defclass prepare-bundle-op (sideway-operation)
    1054211379    ((sideway-operation
    1054311380      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
    10544       :allocation :class)))
     11381      :allocation :class))
     11382    (:documentation "Operation class for loading the bundles of a system's dependencies"))
    1054611384  (defclass lib-op (link-op gather-op non-propagating-operation)
    1055211390On most implementations, these object files only include extensions to the runtime
    1055311391written in C or another language with a compiler producing linkable object files.
    10554 On CLASP, ECL, MKCL, these object files also include the contents of Lisp files
     11392On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
    1055511393themselves. In any case, this operation will produce what you need to further build
    1055611394a static runtime for your system, or a dynamic library to load in an existing runtime."))
    1063411472    (:documentation "create an executable file from the system and its dependencies"))
     11474  ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
    1063611475  (defun bundle-pathname-type (bundle-type)
    1063711476    (etypecase bundle-type
    1066011499       (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
     11501  ;; Compute the output-files for a given bundle action
    1066211502  (defun bundle-output-files (o c)
    1066311503    (let ((bundle-type (bundle-type o)))
    1068511525  (defclass compiled-file (file-component)
    10686     ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
     11526    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
     11527    (:documentation "Class for a file that is already compiled,
     11528e.g. as part of the implementation, of an outer build system that calls into ASDF,
     11529or of opaque libraries shipped along the source code."))
    1068811531  (defclass precompiled-system (system)
    10689     ((build-pathname :initarg :fasl)))
     11532    ((build-pathname :initarg :fasl))
     11533    (:documentation "Class For a system that is delivered as a precompiled fasl"))
    1069111535  (defclass prebuilt-system (system)
    1069211536    ((build-pathname :initarg :static-library :initarg :lib
    10693                      :accessor prebuilt-system-static-library))))
     11537                     :accessor prebuilt-system-static-library))
     11538    (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
    1070711552                                         &allow-other-keys)
    1070811553    (declare (ignore initargs name-suffix))
     11554    ;; TODO: make that class slots or methods, not instance slots
    1070911555    (unless name-suffix-p
    1071011556      (setf (slot-value instance 'name-suffix)
    1074611592(with-upgradability ()
    1074711593  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
    10748     ;; This file selects output files from direct dependencies;
    10749     ;; your component-depends-on method better gathered the correct dependencies in the correct order.
     11594    ;; This function selects output files from direct dependencies;
     11595    ;; your component-depends-on method must gather the correct dependencies in the correct order.
    1075011596    (while-collecting (collect)
    1075111597      (map-direct-dependencies
    1075611602  (defun pathname-type-equal-function (type)
    10757     #'(lambda (p) (equal (pathname-type p) type)))
     11603    #'(lambda (p) (equalp (pathname-type p) type)))
    1075911605  (defmethod input-files ((o gather-op) (c system))
    1076311609           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
     11611  ;; Find the operation that produces a given bundle-type
    1076511612  (defun select-bundle-operation (type &optional monolithic)
    1076611613    (ecase type
    1077611623       'program-op)))
    10778   ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
     11625  ;; DEPRECATED. This is originally from asdf-ecl.lisp.
     11626  ;; It must die, and so must any use of initargs in operation,
     11627  ;; unless keys to the asdf-cache are substantially modified to accommodate for them.
     11628  ;; Coordinate with the ECL maintainers to get them to stop using it.
     11629  ;; SUPPORTED REPLACEMENT: Use program-op and program-system
    1077911630  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
    1078011631                             (move-here nil move-here-p)
    1078511636                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
    1078611637                               (system-relative-pathname system "asdf-output/")))
    10787            (operation (apply #'operate operation-name
     11638           (operation (apply 'operate operation-name
    1078811639                             system
    1078911640                             (remove-plist-keys '(:monolithic :type :move-here) args)))
    1079711648                                            :type (pathname-type f)
    1079811649                                            :defaults dest-path)
    10799                 :do (rename-file-overwriting-target f new-f)
     11650                :do (handler-case (rename-file-overwriting-target f new-f)
     11651                      (file-error (c)
     11652                        (declare (ignore c))
     11653                        (copy-file f new-f)
     11654                        (delete-file-if-exists f)))
    1080011655                :collect new-f)
    1080111656          files)))
    10803   ;; DEPRECATED. Does anyone use this?
     11658  ;; DEPRECATED. Apparently, some users of ECL, MKCL and ABCL may still be using it;
     11659  ;; but at the very least, this function should be renamed, and/or
     11660  ;; some way of specifying the output directory should be provided.
     11661  ;; As is, it is not such a useful interface.
    1080411662  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    1080511663    (declare (ignore force verbose version))
    10806     (apply #'operate 'deliver-asd-op system args)))
     11664    (apply 'operate 'deliver-asd-op system args)))
    1096011818#+(or clasp ecl mkcl)
    1096111819(with-upgradability ()
    10962   ;; I think that Juanjo intended for this to be, but it was disabled before 3.1
    10963   ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since
    10964   ;; -- see for ECL test-xach-update-bug.script and test-bundle.script,
    10965   ;; and for MKCL test-logical-pathname.script.
    10966   ;; We should probably reenable these after consulting with ECL and MKCL maintainers.
    10967   ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
    10968   ;;  (setf *load-system-operation* 'load-bundle-op))
    10970   (defun uiop-library-pathname ()
    10971     #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
    10972     #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
    10973               (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
    10974     #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))
    10976   (defun asdf-library-pathname ()
    10977     #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
    10978     #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
    10979               (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
    10980     #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
    10982   (defun compiler-library-pathname ()
    10983     #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
    10984     #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    10985     #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
    10987   (defun make-library-system (name pathname)
    10988     (make-instance 'prebuilt-system
    10989                    :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
     11821  #+ecl ;; doesn't work on clasp or mkcl (yet?).
     11822  (unless (use-ecl-byte-compiler-p)
     11823    (setf *load-system-operation* 'load-bundle-op))
     11825  (defun system-module-pathname (module)
     11826    (let ((name (coerce-name module)))
     11827      (some
     11828       'file-exists-p
     11829       (list
     11830        #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
     11831        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
     11832        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
     11833        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
     11834        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
     11836  (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
     11837    "Creates a prebuilt-system if PATHNAME isn't NIL."
     11838    (when pathname
     11839      (make-instance 'prebuilt-system
     11840                     :name (coerce-name name)
     11841                     :static-library (resolve-symlinks* pathname))))
    1099111843  (defmethod component-depends-on :around ((o image-op) (c system))
    1099211844    (destructuring-bind ((lib-op . deps)) (call-next-method)
    10993       (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
     11845      (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))
     11846               (ensure-linkable-system (x)
     11847     (unless (has-it-p x)
     11848                   (or (if-let (s (find-system x))
     11849                         (and (system-source-directory x)
     11850                              (list s)))
     11851                       (if-let (p (system-module-pathname x))
     11852                         (list (make-prebuilt-system x p)))))))
    1099411853        `((,lib-op
    10995            ,@(unless (or (no-uiop c) (has-it-p "cmp"))
    10996                `(,(make-library-system
    10997                    "cmp" (compiler-library-pathname))))
    10998            ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
    10999                (cond
    11000                  ((system-source-directory :uiop) `(,(find-system :uiop)))
    11001                  ((system-source-directory :asdf) `(,(find-system :asdf)))
    11002                  (t `(,@(if-let (uiop (uiop-library-pathname))
    11003                           `(,(make-library-system "uiop" uiop)))
    11004                       ,(make-library-system "asdf" (asdf-library-pathname))))))
     11854           ,@(unless (no-uiop c)
     11855               (append (ensure-linkable-system "cmp")
     11856                       (or (ensure-linkable-system "uiop")
     11857                           (ensure-linkable-system "asdf"))))
    1100511858           ,@deps)))))
    1104911902(with-upgradability ()
     11903  ;; Base classes for both regular and monolithic concatenate-source operations
    1105011904  (defclass basic-concatenate-source-op (bundle-op)
    1105111905    ((bundle-type :initform "lisp")))
    1105411908  (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
    11056   (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ())
     11910  ;; Regular concatenate-source operations
     11911  (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()
     11912    (:documentation "Operation to concatenate all sources in a system into a single file"))
    1105711913  (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
    11058     ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
     11914    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
     11915    (:documentation "Operation to load the result of concatenate-source-op as source"))
    1105911916  (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
    11060     ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
     11917    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
     11918    (:documentation "Operation to compile the result of concatenate-source-op"))
    1106111919  (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
    11062     ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)))
    11064   (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ())
     11920    ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))
     11921    (:documentation "Operation to load the result of compile-concatenated-source-op"))
     11923  (defclass monolithic-concatenate-source-op
     11924      (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()
     11925    (:documentation "Operation to concatenate all sources in a system and its dependencies
     11926into a single file"))
    1106511927  (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
    11066     ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
     11928    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
     11929    (:documentation "Operation to load the result of monolithic-concatenate-source-op as source"))
    1106711930  (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
    11068     ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
    11069   (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
    11070     ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)))
     11931    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
     11932    (:documentation "Operation to compile the result of monolithic-concatenate-source-op"))
     11933  (defclass monolithic-load-compiled-concatenated-source-op
     11934      (basic-load-compiled-concatenated-source-op)
     11935    ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))
     11936    (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op"))
    1107211938  (defmethod input-files ((operation basic-concatenate-source-op) (s system))
    1113211998(with-upgradability ()
     11999  ;; The names of the recognized defpackage forms.
    1113312000  (defparameter *defpackage-forms* '(defpackage define-package))
    1113512002  (defun initial-package-inferred-systems-table ()
     12003    ;; Mark all existing packages are preloaded.
    1113612004    (let ((h (make-hash-table :test 'equal)))
    1113712005      (dolist (p (list-all-packages))
    1114012008      h))
     12010  ;; Mapping from package names to systems that provide them.
    1114212011  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
    1114412013  (defclass package-inferred-system (system)
    11145     ())
    11147   ;; For backward compatibility only. To be removed in an upcoming release:
     12014    ()
     12015    (:documentation "Class for primary systems for which secondary systems are automatically
     12016in the one-file, one-file, one-system style: system names are mapped to files under the primary
     12017system's system-source-directory, dependencies are inferred from the first defpackage form in
     12018every such file"))
     12020  ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
    1114812021  (defclass package-system (package-inferred-system) ())
     12023  ;; Is a given form recognizable as a defpackage form?
    1115012024  (defun defpackage-form-p (form)
    1115112025    (and (consp form)
    1115212026         (member (car form) *defpackage-forms*)))
     12028  ;; Find the first defpackage form in a stream, if any
    1115412029  (defun stream-defpackage-form (stream)
    1115512030    (loop :for form = (read stream nil nil) :while form
    1118712062  (defun package-designator-name (package)
     12063    "Normalize a package designator to a string"
    1118812064    (etypecase package
    1118912065      (package (package-name package))
    1120512081      (string-downcase package-name)))
     12083  ;; Given a file in package-inferred-system style, find its dependencies
    1120712084  (defun package-inferred-system-file-dependencies (file &optional system)
    1120812085    (if-let (defpackage-form (file-defpackage-form file))
    1121012087      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
     12089  ;; Given package-inferred-system object, check whether its specification matches
     12090  ;; the provided parameters
    1121212091  (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
    1121312092    (and (eq (type-of system) 'package-inferred-system)
    1122412103                            (equal (slot-value child 'relative-pathname) subpath))))))))
     12105  ;; sysdef search function to push into *system-definition-search-functions*
    1122612106  (defun sysdef-package-inferred-system-search (system)
    1122712107    (let ((primary (primary-system-name system)))
    1123512115                (when (file-pathname-p f)
    1123612116                  (let ((dependencies (package-inferred-system-file-dependencies f system))
    11237                         (previous (cdr (system-registered-p system)))
     12117                        (previous (registered-system system))
    1123812118                        (around-compile (around-compile-hook top)))
    1123912119                    (if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
    1128912169(with-upgradability ()
     12170  ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
     12171  ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
     12172  ;; that do not involve ASDF actions.
     12173  ;; TODO: find the offenders and stop them.
    1129012174  (define-condition operation-error (error) ;; Bad, backward-compatible name
    1129112175    ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
    1130112185  (defun component-load-dependencies (component)
     12186    "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead."
    1130212187    ;; Old deprecated name for the same thing. Please update your software.
    1130312188    (component-sideway-dependencies component))
    11305   (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
     12190  (defgeneric operation-forced (operation)
     12191    (:documentation "DEPRECATED. Assume it's (constantly t) instead."))
     12192  ;; This method exists for backward compatibility with swank.asd, its only user,
     12193  ;; that still uses it as of 2016-09-21.
     12194  ;;
     12195  ;; The magic PERFORM method in swank.asd only actually loads swank if it sees that
     12196  ;; the operation was forced. But except for the first time, the only reason the action
     12197  ;; would be performed to begin with is because it was forced; and the first time over,
     12198  ;; it doesn't hurt that :reload t :delete t should be used. So the check is redundant.
     12199  ;; More generally, if you have to do something when the operation was forced,
     12200  ;; you should also do it when not, and vice-versa, because it really shouldn't matter.
     12201  ;; Thus, the backward-compatible thing to do is to always return T.
     12202  ;;
     12203  ;; TODO: change this function to a defun that always returns T.
    1130612204  (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
    11308   (defgeneric operation-on-warnings (operation))
    11309   (defgeneric operation-on-failure (operation))
    11310   (defgeneric (setf operation-on-warnings) (x operation))
    11311   (defgeneric (setf operation-on-failure) (x operation))
     12207  ;; These old interfaces from ASDF1 have never been very meaningful
     12208  ;; but are still used in obscure places.
     12209  (defgeneric operation-on-warnings (operation)
     12210    (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
     12211  (defgeneric operation-on-failure (operation)
     12212    (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
     12213  (defgeneric (setf operation-on-warnings) (x operation)
     12214    (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
     12215  (defgeneric (setf operation-on-failure) (x operation)
     12216    (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
    1131212217  (defmethod operation-on-warnings ((o operation))
    1131312218    *compile-file-warnings-behaviour*)
    1132312228    ;; but that won't happen until all clients have been updated.
    1132412229    ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
    11325     "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
    11326 It used to expose ASDF internals with subtle differences with respect to
    11327 user expectations, that have been refactored away since.
    11328 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
    11329 for a mostly compatible replacement that we're supporting,
     12230    "DEPRECATED. This function used to expose ASDF internals with subtle
     12231differences with respect to user expectations, that have been refactored
     12232away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a
     12233mostly compatible replacement that we're supporting, or even
    1133112235if that's whay you mean." ;;)
    1133212236    (system-source-file x))
     12239  ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
     12240  ;; It was never officially exposed but some people still used it.
    1133412241  (defgeneric* (traverse) (operation component &key &allow-other-keys)
    1133512242    (:documentation
    1134712254;;;; ASDF-Binary-Locations compatibility
    1134812255;; This remains supported for legacy user, but not recommended for new users.
     12256;; We suspect there are no more legacy users in 2016.
    1134912257(with-upgradability ()
    1135012258  (defun enable-asdf-binary-locations-compatibility
    1135812266       (file-types `(,(compile-file-type)
    1135912267                     "build-report"
    11360                      #+(or clasp ecl) (compile-file-type :type :object)
     12268                     #+clasp (compile-file-type :output-type :object)
     12269                     #+ecl (compile-file-type :type :object)
    1136112270                     #+mkcl (compile-file-type :fasl-p nil)
    1136212271                     #+clisp "lib" #+sbcl "cfasl"
    1163112540  (:recycle :asdf/footer :asdf)
    1163212541  (:use :uiop/common-lisp :uiop
    11633         :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle))
     12542        :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle)
     12543  ;; Happily, all those implementations all have the same module-provider hook interface.
     12544  #+(or abcl clasp cmucl clozure ecl mkcl sbcl)
     12545  (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext
     12546    #:*module-provider-functions*
     12547    #+ecl #:*load-hooks*)
     12548  #+(or clasp mkcl) (:import-from :si #:*load-hooks*))
    1163412550(in-package :asdf/footer)
     12552;;;; Register ASDF itself and all its subsystems as preloaded.
     12553(with-upgradability ()
     12554  (dolist (s '("asdf" "uiop" "asdf-defsystem" "asdf-package-system"))
     12555    ;; Don't bother with these system names, no one relies on them anymore:
     12556    ;; "asdf-utils" "asdf-bundle" "asdf-driver"
     12557    (register-preloaded-system s :version *asdf-version*)))
    1163612560;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
    1163712561#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl)
    1163812562(with-upgradability ()
    11639   (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
    11640     (eval `(pushnew 'module-provide-asdf
    11641                     #+abcl sys::*module-provider-functions*
    11642                     #+(or clasp cmucl ecl) ext:*module-provider-functions*
    11643                     #+clisp ,x
    11644                     #+clozure ccl:*module-provider-functions*
    11645                     #+mkcl mk-ext:*module-provider-functions*
    11646                     #+sbcl sb-ext:*module-provider-functions*)))
     12563  ;; Hook into CL:REQUIRE.
     12564  #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
     12565  #+clisp (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
     12566            (eval `(pushnew 'module-provide-asdf ,x)))
    1164812568  #+(or clasp ecl mkcl)
    1164912569  (progn
    11650     (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
    11652     #+(or (and clasp windows) (and ecl win32) (and mkcl windows))
    11653     (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
    11654       (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
    11656     (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
    11657           (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions*
    11658                 #+mkcl mk-ext::*module-provider-functions*
    11659                 :collect
    11660                 (if (eq f 'module-provide-asdf) f
    11661                     #'(lambda (name)
    11662                         (let ((l (multiple-value-list (funcall f name))))
    11663                           (and (first l) (register-preloaded-system (coerce-name name)))
    11664                           (values-list l))))))))
     12570    (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car)
     12572    #+os-windows
     12573    (unless (assoc "asd" *load-hooks* :test 'equal)
     12574      (appendf *load-hooks* '(("asd" . si::load-source))))
     12576    ;; Wrap module provider functions in an idempotent, upgrade friendly way
     12577    (defvar *wrapped-module-provider* (make-hash-table))
     12578    (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf)
     12579    (defun wrap-module-provider (provider name)
     12580      (let ((results (multiple-value-list (funcall provider name))))
     12581  (when (first results) (register-preloaded-system (coerce-name name)))
     12582  (values-list results)))
     12583    (defun wrap-module-provider-function (provider)
     12584      (ensure-gethash provider *wrapped-module-provider*
     12585          (constantly
     12586           #'(lambda (module-name)
     12587         (wrap-module-provider provider module-name)))))
     12588    (setf *module-provider-functions*
     12589    (mapcar #'wrap-module-provider-function *module-provider-functions*))))
    1166612591#+cmucl ;; Hook into the CMUCL herald.
    1166812593  (defun herald-asdf (stream)
    1166912594    (format stream "    ASDF ~A" (asdf-version)))
    11670   (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
     12595  (setf (getf ext:*herald-items* :asdf) '(herald-asdf)))
    1167312598;;;; Done!
    1167412599(with-upgradability ()
    11675   #+allegro
     12600  #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp
    1167612601  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    1167712602    (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*))
     12604  ;; Advertise the features we provide.
    1167912605  (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*))
    1168212608  (provide "asdf") (provide "ASDF")
     12610  ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF.
    1168412611  (cleanup-upgraded-asdf))
Note: See TracChangeset for help on using the changeset viewer.