Changeset 14873


Ignore:
Timestamp:
09/26/16 21:26:36 (6 years ago)
Author:
Mark Evenson
Message:

asdf: update to 3.1.7.26

Location:
trunk/abcl
Files:
2 edited

Legend:

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

    r14856 r14873  
    6666@titlepage
    6767@title ASDF: Another System Definition Facility
    68 @subtitle Manual for Version 3.1.7.9
     68@subtitle Manual for Version 3.1.7.26
    6969@c The following two commands start the copyright page.
    7070@page
     
    8383@top ASDF: Another System Definition Facility
    8484@ifnottex
    85 Manual for Version 3.1.7.1
     85Manual for Version 3.1.7.10
    8686@end ifnottex
    8787
     
    42344234@section Shell-friendly syntax for configuration
    42354235
    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
     4237@code{ASDF_OUTPUT_TRANSLATIONS}:
     4238@itemize
     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
     4245
     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).
    42454251
    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.
     4259
     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.
     4265
    42574266
    42584267@node Semantics of Output Translations, Output Caching Results, Output Shell-friendly syntax for configuration, Controlling where ASDF saves compiled files
     
    47094718@end defun
    47104719
    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).
     4728
     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.
     4738
     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
    47264743
    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.
    4738 
    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.
     4754
     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.
     4760
     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 3.1.7.9: Another System Definition Facility.
     2;;; This is ASDF 3.1.7.26: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    4646;;; we can't use defsystem to compile it.  Hence, all in one file.
    4747
    48 #+xcvb (module ())
    4948;;;; ---------------------------------------------------------------------------
    5049;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    817816;;;; Early meta-level tweaks
    818817
    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)
    10431044
     
    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))
    15271528
    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)))
    15541555
    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)))))
    1561 
    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)))))
     1564
     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)))
    15641569
    15651570  (defun version< (version1 version2)
     1571    "Compare two version strings"
    15661572    (let ((v1 (parse-version version1 nil))
    15671573          (v2 (parse-version version2 nil)))
     
    15691575
    15701576  (defun version<= (version1 version2)
     1577    "Compare two version strings"
    15711578    (not (version< version2 version1)))
    15721579
     
    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)))
    16271634
     1635;;; Conditions
     1636
     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)))))
     1647
     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
     1652message."
     1653    (error 'not-implemented-error
     1654           :functionality functionality
     1655           :format-control format-control
     1656           :format-arguments format-arguments))
     1657
     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)))))
     1667
     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)))
     1679
    16281680;;;; ---------------------------------------------------------------------------
    16291681;;;; Access to the Operating System
     
    16831735    (featurep :mcl))
    16841736
     1737  (defun os-haiku-p ()
     1738    "Is the underlying operating system Haiku?"
     1739    (featurep :haiku))
     1740
    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))))
    18571918
     
    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)))))))
    23462409
    23472410
     
    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)))))))
    28242887
    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
    33753438
    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))
    38053871
     
    41344200    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
    41354201    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
     4202
     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))
    43714446
    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))))
    49845062
    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)))
    50125090
    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))
     5093
     5094  #+mkcl
     5095  (defun %mkcl-signal-to-number (signal)
     5096    (require :mk-unix)
     5097    (symbol-value (find-symbol signal :mk-unix)))
    50195098
    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)))
    50275112
    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)))
    51775303
    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)))
     5312
     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)))
    5191 
    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)))
     5327
     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))))
     5373
     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))))
     5382
     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)))))))
    52225447
    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)
     5454
     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))))
     5466
     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)))
     5482
     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))
     5489
     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))))
    52295509
    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)))
    53795653
     
    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)))
     5743
     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_.
     5756
     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.
     5766
     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
     5770PROCESS-INFO-ERROR-OUTPUT.
     5771
     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.
     5775
     5776ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
     5777implementation, when applicable, for creation of the output stream.
     5778
     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))
    54705787
    54715788  (defun run-program (command &rest keys
     
    55155832no value is returned, and T designates the *STANDARD-INPUT*.
    55165833
    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.
    55195836
     
    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=3.4.5.67.8
     
    69157250         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    69167251         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    6917          (asdf-version "3.1.7.9")
     7252         (asdf-version "3.1.7.26")
    69187253         (existing-version (asdf-version)))
    69197254    (setf *asdf-version* asdf-version)
     
    69257260                existing-version asdf-version)))))
    69267261
     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))
     
    69497285
    69507286;;; Self-upgrade functions
    6951 
    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))))
    69787315
     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))
    69807319
     
    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)
    70457397
    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."))
    70497402
    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"))
    71177471
    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."))
    71427496
    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.")))
    7173 
    7174 (with-upgradability ()
     7527  (:documentation "A PARENT-COMPONENT is a component that may have children.")))
     7528
     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.")))
    71897550
    71907551
    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)))
    71967558
     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)))
    72097575
     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)
     
    73037677
    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))
    7309 
    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.
     7697
     7698NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
     7699
     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.
     7704
     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."))
    73227719
    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."))
     7749
    73507750
    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)))
     
    73577759
    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)))
     
    73687771
    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))
    73717776
    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))
    73787785
     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)))
    73877799
     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))
    73907804
     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))
    73937809
    73947810;;;; -------------------------------------------------------------------------
    7395 ;;;; Stamp cache
     7811;;;; Session cache
    73967812
    73977813(uiop/package:define-package :asdf/cache
     
    74047820(in-package :asdf/cache)
    74057821
    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
    7410 
    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.
     7829
     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)
    74137834
     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)))
    7419 
     7838    (values-list (if *asdf-cache*
     7839                     (setf (gethash key *asdf-cache*) value-list)
     7840                     value-list)))
     7841
     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*)))
    74237846
     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)))
    74317858
     7859  ;; Syntactic sugar for consult-asdf-cache
    74327860  (defmacro do-asdf-cache (key &body body)
    74337861    `(consult-asdf-cache ,key #'(lambda () ,@body)))
    74347862
     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)))))))
    74507884
     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))
    74537888
     7889
     7890  ;;; Define specific accessor for file (date) stamp.
     7891
     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))))
    74607899
     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)))
    74647904
     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))))
    74697911
     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))
    75267971
     7972
     7973  ;;; Canonicalizing system names
     7974
    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))))
    75337984
    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 "/")))
    75387990
    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) '("/" ":" "\\") "--"))
    75417997
     7998
     7999  ;;; Registry of Defined Systems
     8000
    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.")
    75488009
    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*))
    75518015
     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)))
     8022
    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)))
    75558027
    75568028  (defun registered-systems ()
     8029    "Return a list of the names of every registered system."
    75578030    (mapcar 'coerce-name (registered-systems*)))
    75588031
    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)))))
    75698042
    7570   (defvar *preloaded-systems* (make-hash-table :test 'equal))
     8043
     8044  ;;; Preloaded systems: in the image even if you can't find source files backing them.
     8045
     8046  (defvar *preloaded-systems* (make-hash-table :test 'equal)
     8047    "Registration table for preloaded systems.")
     8048
     8049  (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate
    75718050
    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))
    75768058
    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)))))
    75828066
    7583   (defun register-preloaded-system (system-name &rest keys)
    7584     (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    7585 
    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)))
     8073
     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)
     8080
     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)))
     8092
     8093
     8094  ;;; Immutable systems: in the image and can't be reloaded from source.
    75898095
    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.
    75948100
    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))
     8105
     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.")
    75998109
    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))))))
    76098118
    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)))
     8127
     8128
     8129  ;;; Making systems undefined.
    76248130
    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))))
    76408145
    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)))))
    7655 
    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* '())
    7660 
     8160          :do (funcall fn (cdr registered))))
     8161
     8162
     8163  ;;; Searching for system definitions
     8164
     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.")
     8173
     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)
    76758192
     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))))
    7683 
     8207        (map () #'try *system-definition-search-functions*))))
     8208
     8209
     8210  ;;; The legacy way of finding a system: the *central-registry*
     8211
     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/\"))
    76948224
    7695 This is for backward compatibility.
    7696 Going forward, we recommend new users should be using the source-registry.
    7697 ")
    7698 
     8225This variable is for backward compatibility.
     8226Going forward, we recommend new users should be using the source-registry.")
     8227
     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)))))))))
    77208253
     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))))))))))
    77678301
     8302
     8303  ;;; Methods for find-system
     8304
     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~@:>"))))
    77718309
     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))
    77748313
    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*)))
    77798323
     
    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.
     8329
     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))
    78078354
     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)))
    7882 
     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))))
     8431
     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;;;; -------------------------------------------------------------------------
     
    79738525
    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))
    7978 
    7979   (defmethod find-component ((base string) path)
    7980     (let ((s (find-system base nil)))
    7981       (and s (find-component s path))))
    7982 
    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"))
     8533
     8534  ;; Methods for find-component
     8535
     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)))
     8542
     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)))
    79888550
    7989   (defmethod find-component ((base cons) path)
    7990     (find-component (car base) (cons (cdr base) path)))
    7991 
    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))
     8554
     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))))
    79958560
    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))
    80008566
    8001   (defmethod find-component ((c component) (name cons))
    8002     (find-component (find-component c (car name)) (cdr name)))
    8003 
    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))
     8571
     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)
    80068576
     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))))))))
    80368608
    8037 
     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)))))
    80438617
     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))
    80478622
    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)))
    8079 
    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.
     8655
     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.
     8658
     8659Any exceptions currently maintained for backward-compatibility are deprecated,
     8660and support for them may be discontinued at any moment.
     8661"))
     8662
     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)
     
    80948678
    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))
    80978682
     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.
     8687
     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))))
    81038693
     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"))
     
    81398732
    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
     8734
     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))
    81428739
    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)))
    81488744
     8745
     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)))
    81538751
    8154 ;;;; Reified representation for storage or debugging. Note: dropping original-initargs
     8752
     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)))))
    81608761
     
    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))
     8826
     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)))
     
    82178834
    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.
     9002
     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.
     9005"))
     9006  (defgeneric* (input-files) (operation component)
     9007    (:documentation "A list of input files corresponding to this action.
     9008
     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.
     9011"))
    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)
    83899020
     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)))
    84159046
     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)))
    84209051
     9052  ;; By default an action has no input-files.
    84219053  (defmethod input-files ((o operation) (c component))
    84229054    nil)
    84239055
     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))
    84379076
    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.
     9080
     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))
    84849128
     
    84979141       'perform (cons o c))))
    84989142
     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.cl (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\"")))
    85489197
    85499198
    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")))
     9209
    85569210
    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"))
     9224
    85689225
    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."))
    85739232
    85749233  (defclass test-op (selfward-operation)
    8575     ((selfward-operation :initform 'load-op :allocation :class))))
    8576 
    8577 
    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.")))
     9237
     9238
     9239;;;; Methods for prepare-op, compile-op and load-op
    85799240
    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))))))
    8630 
    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)
     9339
     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))
    8747 
    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")))
    87939477
    87949478
     
    88209504    t) ; default method for non planned-action-status objects
    88219505
    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))
    88269512
    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)))
    88299516
     
    88439530;;;; forcing
    88449531(with-upgradability ()
    8845   (defgeneric action-forced-p (plan operation component))
    8846   (defgeneric action-forced-not-p (plan operation component))
    8847 
    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."))
     9537
     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)))))))
    88539546
    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))))
    88659562
     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))
    89029606
     
    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?"))
    89089612
    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)
     
    89279632
    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
     
    89349642
    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))
    89379646
     
    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))
    9016 
    9017   (defgeneric call-while-visiting-action (plan operation component function)
    9018     (:documentation "Detect circular dependencies"))
    9019 
    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))))
    90269731
    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))
    9029 
    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)))))
    9033 
    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)
     9736
     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))
     9739
     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)))))
     9743
     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)))
     9746
     9747  (defgeneric plan-record-dependency (plan operation component)
     9748    (:documentation "Record an action as a dependency in the current plan")))
     9749
     9750
     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)))))
     9758
     9759  (defgeneric call-while-visiting-action (plan operation component function)
     9760    (:documentation "Detect circular dependencies"))
    90369761
    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)))))
     9775
     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))))
    90509779
    90519780
    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)))))
    9059 
    9060   (defmacro while-visiting-action ((p o c) &body body)
    9061     `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))
    9062 
    90639783  (defgeneric traverse-action (plan operation component needed-in-image-p))
    90649784
     
    91279847(with-upgradability ()
    91289848  (defclass sequential-plan (plan-traversal)
    9129     ((actions-r :initform nil :accessor plan-actions-r)))
    9130 
    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"))
     9851
    91349852  (defmethod plan-actions ((plan sequential-plan))
    91359853    (reverse (plan-actions-r plan)))
    91369854
     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)))))
    91449863
     9864
    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))
    91519870
    9152   (defgeneric perform-plan (plan &key))
    9153   (defgeneric plan-operates-on-p (plan component))
    9154 
    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?"))
     9875
     9876  (defvar *default-plan-class* 'sequential-plan
     9877    "The default plan class to use when building with ASDF")
    91569878
    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."))
    91969919
    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))
     
    92109936
    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))
     
    92279954
    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:
    9257 
    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
    9261 
    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.
    9265 
    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:
     9986
     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.
     9993
     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.
    92689998
    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."))
    9275 
    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))
    9282 
     10004:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.
     10005
     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."))
     10009
     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))
     10015
     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")
    9285 
     10019    "A hash-set of names of systems being operated on, or NIL")
     10020
     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.
    934310081
     
    934510083component-directed strategy for how to load or compile systems.")
    934610084
     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)))
    935010089
    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)))
    940410145
    940510146  (defun already-loaded-systems ()
     
    940810149
    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))))
    941310155
    941410156
    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))))
    943310178
    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)
     
    944810199
    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))
    9477 
     10233  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)
     10234
     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))))))
    947810246
    947910247;;;; ---------------------------------------------------------------------------
     
    950110269(in-package :asdf/output-translations)
    950210270
     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)))
    950410274
     
    951410284
    951510285  (defun output-translations ()
     10286    "Return the configured output-translations, if any"
    951610287    (car *output-translations*))
    951710288
     10289  ;; Set the output-translations, by sorting the provided new-value.
    951810290  (defun set-output-translations (new-value)
    951910291    (setf *output-translations*
     
    953010302
    953110303  (defun output-translations-initialized-p ()
     10304    "Have the output-translations been initialized yet?"
    953210305    (and *output-translations* t))
    953310306
     
    953710310    (values))
    953810311  (register-clear-configuration-hook 'clear-output-translations)
     10312
     10313
     10314  ;;; Validation of the configuration directives...
    953910315
    954010316  (defun validate-output-translations-directive (directive)
     
    956610342               :invalid-form-reporter 'invalid-output-translation))
    956710343
     10344
     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)))))))))
    960810386
     10387
     10388  ;; The default sources of configuration for output-translations
    960910389  (defparameter* *default-output-translations*
    961010390    '(environment-output-translations
     
    961410394      system-output-translations-directory-pathname))
    961510395
     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))
    963110413
     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/"))
    963410417
     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"))
     10431
     10432
     10433  ;;; Processing the configuration.
    964710434
    964810435  (defgeneric process-output-translations (spec &key inherit collect))
     
    970610493      (process-output-translations-directive directive :inherit inherit :collect collect)))
    970710494
     10495
     10496  ;;; Top-level entry-points to configure output-translations
     10497
    970810498  (defun compute-output-translations (&optional parameter)
    970910499    "read the configuration, return it"
     
    971410504     :test 'equal :from-end t))
    971510505
     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)
    971710509
     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)))
    973810531
     10532
     10533  ;; Top-level entry-point to _use_ output-translations
    973910534  (defun* (apply-output-translations) (path)
    974010535    (etypecase path
     
    975710552              :finally (return p)))))
    975810553
     10554
    975910555  ;; Hook into uiop's output-translation mechanism
    976010556  #-cormanlisp
    976110557  (setf *output-translation-function* 'apply-output-translations)
    976210558
    9763   #+abcl
     10559
     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~]~@{ ~@?~}~@:>"))))
    982010618
    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" "~.dot" "~.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.
    9828 
     10626      ;;-- debian often builds stuff under the debian directory... BAD.
     10627      "debian"))
     10628
     10629  ;; Actual list of directories under which the source-registry tree search won't recurse
    982910630  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    983010631
     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")
    983410636
     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)
    983610640
     
    985910663after having found a .asd file? True by default.")
    986010664
     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)))))
    988510691
     10692
     10693  ;;; Validate the configuration forms
     10694
    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))
     10721
     10722
     10723  ;;; Parse the configuration string
    991210724
    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"))
    1000410816
     10817
     10818  ;;; Process the source-registry configuration
     10819
    1000510820  (defgeneric* (process-source-registry) (spec &key inherit register))
    1000610821
     
    1006110876        (process-source-registry-directive directive :inherit inherit :register register))))
    1006210877
     10878
     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
     
    1007410891
    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)
    1017910997
     
    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)))
    1022311041
     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"))
    1047711303
    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
     11309itself."))
    1048411310
    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"))
    1048911317
    1049011318  (defclass program-system (system)
     
    1051411342
    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))
    1052211351
     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))))
    1053411369
    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)))
    10540 
     11374     (bundle-type :initform :fasl :allocation :class))
     11375    (:documentation "Base class for compiling into a bundle"))
     11376
     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"))
    1054511383
    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"))
    1063511473
     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")))))
    1066111500
     11501  ;; Compute the output-files for a given bundle action
    1066211502  (defun bundle-output-files (o c)
    1066311503    (let ((bundle-type (bundle-type o)))
     
    1068411524
    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."))
    1068711530
    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"))
    1069011534
    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)")))
    1069411539
    1069511540
     
    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
     
    1075511601
    1075611602  (defun pathname-type-equal-function (type)
    10757     #'(lambda (p) (equal (pathname-type p) type)))
     11603    #'(lambda (p) (equalp (pathname-type p) type)))
    1075811604
    1075911605  (defmethod input-files ((o gather-op) (c system))
     
    1076311609           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
    1076411610
     11611  ;; Find the operation that produces a given bundle-type
    1076511612  (defun select-bundle-operation (type &optional monolithic)
    1076611613    (ecase type
     
    1077611623       'program-op)))
    1077711624
    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)))
    1080211657
    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)))
    1080711665
    1080811666;;;
     
    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))
    10969 
    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"))
    10975 
    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"))
    10981 
    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"))
    10986 
    10987   (defun make-library-system (name pathname)
    10988     (make-instance 'prebuilt-system
    10989                    :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
     11820
     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))
     11824
     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;")))))
     11835
     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))))
    1099011842
    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)))))
    1100611859
     
    1104811901;;;
    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) ())
    1105511909
    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)))
    11063 
    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"))
     11922
     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"))
    1107111937
    1107211938  (defmethod input-files ((operation basic-concatenate-source-op) (s system))
     
    1113111997
    1113211998(with-upgradability ()
     11999  ;; The names of the recognized defpackage forms.
    1113312000  (defparameter *defpackage-forms* '(defpackage define-package))
    1113412001
    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))
    1114112009
     12010  ;; Mapping from package names to systems that provide them.
    1114212011  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
    1114312012
    1114412013  (defclass package-inferred-system (system)
    11145     ())
    11146 
    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"))
     12019
     12020  ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
    1114812021  (defclass package-system (package-inferred-system) ())
    1114912022
     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*)))
    1115312027
     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
     
    1118612061
    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)))
    1120612082
     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)))
    1121112088
     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))))))))
    1122512104
     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)
     
    1128812168
    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
     
    1130012184
    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))
    1130412189
    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))
    1130712205
    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))
     12206
     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,
    11330 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
     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
     12234ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
    1133112235if that's whay you mean." ;;)
    1133212236    (system-source-file x))
    1133312237
     12238
     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*))
     12549
    1163412550(in-package :asdf/footer)
     12551
     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*)))
     12558
    1163512559
    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)))
    1164712567
    1164812568  #+(or clasp ecl mkcl)
    1164912569  (progn
    11650     (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
    11651 
    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))))
    11655 
    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)
     12571
     12572    #+os-windows
     12573    (unless (assoc "asd" *load-hooks* :test 'equal)
     12574      (appendf *load-hooks* '(("asd" . si::load-source))))
     12575
     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*))))
    1166512590
    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)))
    1167112596
    1167212597
    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*))
    1167812603
     12604  ;; Advertise the features we provide.
    1167912605  (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*))
    1168012606
     
    1168212608  (provide "asdf") (provide "ASDF")
    1168312609
     12610  ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF.
    1168412611  (cleanup-upgraded-asdf))
    1168512612
Note: See TracChangeset for help on using the changeset viewer.