Changeset 14361

01/27/13 09:47:48 (11 years ago)
Mark Evenson

asdf- pre asdf-2.27 plus workaround for SETF autoloader problems.

2 edited


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

    r14277 r14361  
    2121@macro &body
     23@end macro
     24@macro &curly
     26@end macro
     27@macro &ylruc
    2329@end macro
    212218@section Loading a pre-installed ASDF
    214 Many Lisp implementations include a copy of ASDF.
     220Most recent Lisp implementations include a copy of ASDF 2.
    215221You can usually load this copy using Common Lisp's @code{require} function:
    222228the following implementations provide ASDF 2 this way:
    223229abcl allegro ccl clisp cmucl ecl lispworks mkcl sbcl xcl.
    224 The following implementation doesn't provide it yet but will in a future release:
     230The following implementation doesn't provide it yet but will in an upcoming release:
    226232The following implementations are obsolete, not actively maintained,
    264 (or #+asdf2 (asdf:asdf-version) #+asdf :old)
     270(when (find-package :asdf)
     271  (let ((ver (symbol-value (or (find-symbol (string :*asdf-version*) :asdf)
     272                               (find-symbol (string :*asdf-revision*) :asdf)))))
     273    (etypecase ver
     274      (string ver)
     275      (cons (with-output-to-string (s)
     276              (loop for (n . m) on ver do (princ n s) (when m (princ "." s)))))
     277      (null "1.0"))))
    265278@end lisp
    267 If it returns a version number, that's the version of ASDF installed.
    268 If it returns the keyword @code{:OLD},
    269 then you're using an old version of ASDF (from before 1.635).
    270280If it returns @code{NIL} then ASDF is not installed.
     281Otherwise it should return a string.
     282If it returns @code{"1.0"}, then it can actually be
     283any version before 1.77 or so, or some buggy variant of 1.x.
    272285If you are experiencing problems with ASDF,
    278291@section Upgrading ASDF
     293If your implementation provides ASDF 2.27 or later,
     294you only need to @code{(require "asdf")}:
     295ASDF will automatically look whether an updated version of itself is available
     296amongst the regularly configured systems, before it compiles anything else.
     297See @pxref{Configuring ASDF} below.
    280299If your implementation does provide ASDF 2 or later,
     300but not ASDF 2.27 or later,
    281301and you want to upgrade to a more recent version,
    282 just install ASDF like any other package
    283 (see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below),
    284 configure ASDF as usual (see @pxref{Configuring ASDF} below),
    285 and upgrade with:
     302you need to install and configure your ASDF as above,
     303and additionally, you need to explicitly tell ASDF to load itself,
     304right after you require your implementation's old ASDF 2:
    292311If on the other hand, your implementation only provides an old ASDF,
    293 you will require a special configuration step and an old-style loading:
     312you will require a special configuration step and an old-style loading.
     313Take special attention to not omit the trailing directory separator
     314@code{/} at the end of your pathname:
    299320@end lisp
    301 Don't forget the trailing @code{/} at the end of your pathname.
    303 Also, note that older versions of ASDF won't redirect their output,
     322Note that ASDF 1 won't redirect its output files,
    304323or at least won't do it according to your usual ASDF 2 configuration.
    305324You therefore need write access on the directory
    313332you may want to upgrade your implementation rather than go through that hoop.
    315 Finally, note that there are some limitations to upgrading ASDF:
     334Finally, if you are using an unmaintained implementation
     335that does not provide ASDF at all,
     336see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
     338Note that there are some limitations to upgrading ASDF:
    318 Any ASDF extension becomes invalid, and will need to be reloaded.
     341Previously loaded ASDF extension becomes invalid, and will need to be reloaded.
    319342This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc.
    320 Starting with ASDF 2.014.8 (as far as releases go, 2.015),
     343Since it isn't possible to automatically detect what extensions are present
     344that need to be invalidated,
    321345ASDF will actually invalidate all previously loaded systems
    322 when it is loaded on top of a different ASDF version.
    323 @item
    324 Until all implementations provide ASDF 2.015 or later,
     346when it is loaded on top of a different ASDF version,
     347starting with ASDF 2.014.8 (as far as releases go, 2.015);
     348and it will automatically attempt this self-upgrade as its very first step
     349starting with ASDF 2.27.
     352For this an many other reasons,
     353it important reason to load, configure and upgrade ASDF (if needed)
     354as one of the very first things done by your build and startup scripts.
     355Until all implementations provide ASDF 2.27 or later,
    325356it is safer if you upgrade ASDF and its extensions as a special step
    326357at the very beginning of whatever script you are running,
    327 before you start using ASDF to load anything else.
    328 @item
    329 Until all implementations provide ASDF 2.015 or later,
     358before you start using ASDF to load anything else;
     359even afterwards, it is still a good idea, to avoid having to
     360load and reload code twice as it gets invalidated.
     363Until all implementations provide ASDF 2.27 or later,
    330364it is unsafe to upgrade ASDF as part of loading a system
    331365that depends on a more recent version of ASDF,
    395429The default location for a user to install Common Lisp software is under
    397 If you install software there, you don't need further configuration.
     431If you install software there (it can be a symlink),
     432you don't need further configuration.
    398433If you're installing software yourself at a location that isn't standard,
    399434you have to tell ASDF where you installed it. See below.
    439474between the machine where you save it at the time you save it
    440475and the machine you resume it at the time you resume it.
     476Actually, you should use @code{(asdf:clear-configuration)}
     477before you dump your Lisp image, which includes the above.
    594631between the machine where you save it at the time you save it
    595632and the machine you resume it at the time you resume it.
     633(Once again, you should use @code{(asdf:clear-configuration)}
     634before you dump your Lisp image, which includes the above.)
    597636Finally note that before ASDF 2,
    722 Load a system with @code{(load-system :my-system)}
     761Load a system with @code{(asdf:load-system :my-system)}
    723762or use some other operation on some system of your choice.
    834873@code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
    835874even though the two are the same when interpreted as decimal fractions.
    836 @cindex version specifiers
     875Instead of a string representing the version,
     876the @code{:version} argument can be an expression that is resolved to
     877such a string using the following trivial domain-specific language:
     878in addition to being a literal string, it can be an expression of the form
     879@code{(:read-file-form <pathname-or-string> :at <access-at-specifier>)},
     880which will be resolved by reading a form
     881in the specified pathname
     882(read as a subpathname of the current system if relative or a unix-namestring).
     883You may use an access-at specifier with the (optional) :at keyword,
     884by default the specifier is 0, meaning the first form is returned.
    837886@cindex :version
    923972module-option := :components component-list
    924973                 | :serial [ t | nil ]
    925                  | :if-component-dep-fails component-dep-fail-option
    927975option :=
    932980        | :output-files method-form
    933981        | :operation-done-p method-form
     982        | :if-feature feature-expression
    934983        | :depends-on ( @var{dependency-def}* )
    935984        | :in-order-to ( @var{dependency}+ )
    9661015component-dep-fail-option := :fail | :try-next | :ignore
     1017feature-expression := keyword | (:and @var{feature-expression}*)
     1018                      | (:or @var{feature-expression}*) | (:not @var{feature-expression})
    9671019@end example
    10121064@cindex :weakly-depends-on
    1014 The @code{:weakly-depends-on} option to @code{defsystem} allows the
    1015 programmer to specify another ASDF-defined system or set of systems that
    1016 ASDF should @emph{try} to load, but need not load in order to be
    1017 successful.  Typically this is used if there are a number of systems
    1018 that, if present, could provide additional functionality, but which are
    1019 not necessary for basic function.
    1021 Currently, although it is specified to be an option only to
    1022 @code{defsystem}, this option is accepted at any component, but it probably
    1023 only makes sense at the @code{defsystem} level. Programmers are cautioned not
     1066We do @emph{NOT} recommend you use this feature.
     1067If you are tempted to write a system @var{foo}
     1068that weakly-depends-on a system @var{bar},
     1069we recommend that you should instead
     1070write system @var{foo} in a parametric way,
     1071and offer some special variable and/or some hook to specialize its behavior;
     1072then you should write a system @var{foo+bar}
     1073that does the hooking of things together.
     1075The (deprecated) @code{:weakly-depends-on} option to @code{defsystem}
     1076allows the programmer to specify another ASDF-defined system or set of systems
     1077that ASDF should @emph{try} to load,
     1078but need not load in order to be successful.
     1079Typically this is used if there are a number of systems
     1080that, if present, could provide additional functionality,
     1081but which are not necessary for basic function.
     1083Currently, although it is specified to be an option only to @code{defsystem},
     1084this option is accepted at any component, but it probably
     1085only makes sense at the @code{defsystem} level.
     1086Programmers are cautioned not
    10241087to use this component option except at the @code{defsystem} level, as
    10251088this anomalous behavior may be removed without warning.
    10931156parsing component names as strings specifying paths with directories,
    10941157and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
     1158An alternative to @code{#.} read-time evaluation is to use
     1159@code{(eval `(defsystem ... ,pathname ...))}.
    10961161Note that when specifying pathname objects,
    12101275will load a system from disk
    12111276and have its pathname default to the right place.
    12131279This pathname information will not be overwritten with
    12351301changed, if explicitly supplied or obtained from @code{*load-truename*}
    12361302(so that an updated source location is reflected in the system definition)
    12381305changed if it had previously been set from @code{*default-pathname-defaults*}
    12401308left as before, if it had previously been set from @code{*load-truename*}
    12441312@end itemize
     1314@subsection if-feature option
     1315This option allows you to specify a feature expression to be evaluated
     1316as if by @code{#+} to conditionally include a component in your build.
     1317If the expression is false, the component is dropped
     1318as well as any dependency pointing to it.
     1319As compared to using @code{#+} which is expanded at read-time,
     1320this allows you to have an object in your component hierarchy
     1321that can be used for manipulations beside building your project.
     1322This option was added in ASDF 2.27.
    12461324@subsection if-component-dep-fails option
    1248 This option is only appropriate for module components (including
    1249 systems), not individual source files.
    1251 For more information about this option, @pxref{Pre-defined subclasses of component}.
     1325This option was removed in ASDF 2.27.
     1326Its semantics was limited in purpose and dubious to explain,
     1327and its implementation was breaking a hole into the ASDF object model.
     1328Please use the @code{if-feature} option instead.
    12531330@node Other code in .asd files,  , The defsystem grammar, Defining systems with defsystem
    12801357ASDF is designed in an object-oriented way from the ground up.
    12811358Both a system's structure and the operations that can be performed on systems
    1282 follow a protocol.
    1283 ASDF is extensible to new operations and to new component types.
     1359follow a extensible protocol.
    12841361This allows the addition of behaviours:
    1285 for example, a new component could be added for Java JAR archives,
    1286 and methods specialised on @code{compile-op} added for it
    1287 that would accomplish the relevant actions.
    1289 This chapter deals with @emph{components}, the building blocks of a system,
    1290 and @emph{operations}, the actions that can be performed on a system.
     1362for example, @code{cffi} adds support of special FFI description files
     1363to interface with C libraries and of wrapper files to embed C code in Lisp;
     1364@code{abcl-jar} supports creating Java JAR archives in ABCL;
     1365and @code{poiu} supports for compiling code in parallel using background processes.
     1367This chapter deals with @code{component}s and @code{operation}s.
     1369A @code{component} represents an individual source file or a group of source files,
     1370and the things that get transformed into.
     1371A @code{system} is a component at the top level of the component hierarchy.
     1372A @code{source-file} is a component representing a single source-file
     1373and the successive output files into which it is transformed.
     1374A @code{module} is an intermediate component itself grouping several other components,
     1375themselves source-files or further modules.
     1377An @code{Operation} represents a transformation that can be performed on a component,
     1378turning them from source files to intermediate results to final outputs.
     1380A pair of an @code{operation} and a @code{component} is called an @code{action}.
     1381An @code{action} represents a particular build step to be @code{perform}ed,
     1382after all its dependencies have been fulfilled.
     1383In the ASDF model, actions depend on other actions.
     1384The term @emph{action} itself was used by Kent Pitman in his old article,
     1385but was only used by ASDF hackers starting with the ASDF 2;
     1386but the concept is ubiquitous since the very beginning of ASDF 1,
     1387though previously implicit.
     1389Then, there are many @emph{functions} available
     1390to users, extenders and implementers of ASDF
     1391to use, define or implement the activities
     1392that are part of building your software.
     1393Though they manipulate @code{action}s,
     1394most of these functions do not take as an argument
     1395a reified pair (a CONS cell) of an operation and a component;
     1396instead, they usually take two separate arguments,
     1397which allows to take advantage of the power CLOS-style multiple dispatch
     1398for fun and profit.
     1400There are many @emph{hooks} in which to add functionality,
     1401by customizing the behavior of existing @emph{functions}.
     1403Last but not least is the notion of @emph{dependency} between two actions.
     1404The structure of dependencies between actions is
     1405a directed @emph{dependency graph}.
     1406ASDF is invoked by being told to @emph{operate}
     1407with some @emph{operation} on some toplevel @emph{system};
     1408it will then @emph{traverse} the graph and build a @emph{plan}
     1409that follows its structure.
     1410To be successfully buildable, this graph of actions but be acyclic.
     1411If, as a user, extender or implementer of ASDF, you fail
     1412to keep the dependency graph without cycles,
     1413ASDF will fail loudly as it eventually finds one.
     1415To clearly distinguish the direction of dependencies,
     1416ASDF 2.27 introduces the words @emph{parent} and @emph{child}
     1417as applied to an action depending on the other:
     1418the parent action @code{depends-on} the completion of all children actions
     1419before it may itself be @code{perform}ed.
     1420ASDF has long had parent operations and children operations,
     1421whereby the ancestor holds some options valid for all the children (notably regarding forcing).
     1423Using the defsystem syntax, users may easily express
     1424direct dependencies along the graph of the object hierarchy:
     1425between a component and its parent, its children, and its siblings.
     1426By defining custom CLOS methods, you can express more elaborate dependencies as you wish.
     1427Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op}
     1428automatically ``descend'' the component hierarchy and are ``covariant'' with it:
     1429to act the operation on the parent module, you must first act it on all the children components,
     1430with the action on the parent being parent of the action on each child.
     1431Other operations, such as @code{parent-load-op} and @code{parent-load-source-op}
     1432(introduced in ASDF 2.27) ``ascend'' the component hierarchy and are ``contravariant'' with it:
     1433to act the operation on the child component, you must first act it on all its parent module, and so on,
     1434ensuring that all the module's dependencies are (compiled and) loaded
     1435before the child component may be compiled and loaded.
     1436Yet other operations, such as @code{test-op} or @code{load-fasl-op}
     1437remain at the system level, and do not descend the hierarchy,
     1438instead doing something global.
     1439Finally, some operations such a POIU's @code{parallel-load-op}
     1440are not even meant to be performed or to have dependencies,
     1441but are only ways to specialize @code{operate} into behaving differently
     1442(in this case, having it operate in parallel).
     1444Parent and child thus mean different things for components and for actions.
     1445They also mean two different things for operations.
     1446Each operation has a @code{parent} slot,
     1447which links it up all the way to an ancestor @emph{operation}
     1448that contains all configuration data related to the current run of @code{operate}
     1449(usually the links are made with @code{make-sub-operation}
     1450which ensures the chain or parents is of length zero or one).
     1451Each operation also has a notion of a @code{parent-operation},
     1452such that current operation acting on a current component
     1453is parent of the parent-operation acting on the parent.
     1454That's how @code{parent-load-op} is the @code{parent-operation}
     1455or both @code{load-op} and @code{compile-op} (see above).
     1457It isn't too confusing: parent and child are generic ways to denote a clear directional relationship,
     1458and whether we're discussing component structure, action structure, operation structure
     1459or contravariant operation prerequisites, it is usually very clear which relationship we're discussing.
    13141481Operations can be invoked directly, or examined
    13151482to see what their effects would be without performing them.
    1316 @emph{FIXME: document how!}
    13171483There are a bunch of methods specialised on operation and component type
    13181484that actually do the grunt work.
    13411507with the same @var{initargs} as the original one.
    1343 If @var{force} is @code{t}, then all systems
     1509If @var{force} is @code{:all}, then all systems
    13441510are forced to be recompiled even if not modified since last compilation.
     1511If @var{force} is @code{t}, then only the system being loaded
     1512is forced to be recompiled even if not modified since last compilation,
     1513but other systems are not affected.
    13451514If @var{force} is a list, then it specifies a list of systems that
    13461515are forced to be recompiled even if not modified since last compilation.
    1347 If @var{force-not} is @code{t}, then all systems
     1516If @var{force-not} is @code{:all}, then all systems
    13481517are forced not to be recompiled even if modified since last compilation.
     1518If @var{force-not} is @code{t}, then only the system being loaded
     1519is forced not to be recompiled even if modified since last compilation,
     1520but other systems are not affected.
    13491521If @var{force-not} is a list, then it specifies a list of systems that
    13501522are forced not to be recompiled even if modified since last compilation.
    13511523@var{force} takes precedences over @var{force-not};
    13521524both of them apply to systems that are dependencies and were already compiled.
     1526To see what @code{operate} would do, you can use:
     1528(asdf::traverse (make-instance operation-class initargs ...) (find-system system-name))
     1529@end example
    13531531@end deffn
    13901568This operation loads a system.
     1570The default methods for @code{load-op} compile files before loading them.
     1571For parity, your own methods on new component types should probably do so too.
     1572@end deffn
     1574@deffn Operation @code{parent-load-op} @&key @code{proclamations}
     1576This operation ensures that the dependencies
     1577of a module, and its parent, and so on, are loaded (as per @code{load-op})
     1578before the components within that module may be operated upon.
     1580By default, all operations depend on this @code{parent-operation}
     1581for actions on components to depend on this ``parent operation'' being acted on the parent.
    13921583The default methods for @code{load-op} compile files before loading them.
    14241615in a way that is compatible with all of the various test libraries
    14251616and test techniques in use in the community.
     1618People typically define @code{test-op} methods like thus:
     1620(defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system @var{:mysystem}))))
     1621  (asdf:load-system @var{:mysystem})
     1622  (eval (read-from-string "(some expression that runs the tests)"))
     1623  t)
     1624@end example
    14261625@end deffn
     1627@deffn Operation @code{load-fasl-op}
     1629This operation will load and create if need be
     1630a single fasl file for all the files in each loaded system.
     1631(Its compilation-only equivalent is @code{asdf::fasl-op}.)
     1633Once you have created such a fasl,
     1634you can use @code{precompiled-system} to deliver it in a way
     1635that is compatible with clients having asdf dependencies
     1636on your system whether it is distributed as source of as a single binary.
     1638On your build platform, you run something like that:
     1640@code{(asdf:operate 'load-fasl-op @var{:mysystem})}
     1641@end example
     1643And on your delivery platform, a form like this is evaluated
     1644in a prologue or at some point before you save your image:
     1646(defsystem :mysystem :class :precompiled-system
     1647    :fasl (some expression that will evaluate to a pathname))
     1648@end example
     1650Of course, @emph{before} you define such systems,
     1651you should not forget to @code{(asdf:clear-configuration)}.
     1653@code{load-fasl-op} is available on all actively supported Lisp implementations,
     1654and on those implementations only, and only since ASDF 2.27.
     1655This functionality was previously available for select implementations,
     1656as part of a separate system @code{asdf-bundle},
     1657itself descended from @code{asdf-ecl}.
     1658@end deffn
    14281661@c @deffn Operation test-system-version @&key minimum
     1719@item @code{input-files}
     1720ASDF has a pretty clever default @code{input-files} mechanism.
     1721You only need create a method if there are multiple ultimate input files,
     1722and/or the bottom one doesn't depend
     1723on the @code{component-pathname} of the component.
    14861725@item @code{output-files}
    14871726The @code{output-files} method determines where the method will put its files.
    14921731may translate these pathnames, e.g. to ensure object files
    14931732are somehow stored in some implementation-dependent cache.
    14941734@item @code{perform}
    14951735The @code{perform} method must call @code{output-files}
    14981738@item @code{output-files}
    14991739for local policy @code{explain}
    1500 @item @code{operation-done-p},
    1501 if you don't like the default one
     1741@item @code{operation-done-p}
     1742You only need to define a method on that function
     1743if you can detect conditions that invalidate previous runs of the operation,
     1744even though no filesystem timestamp has changed,
     1745in which case you return @code{nil} (the default is @code{t}).
     1747For instance, the method for @code{test-op} always returns @code{nil},
     1748so that tests are always run afresh.
     1749Of course, the @code{test-op} for your system could depend
     1750on a deterministically repeatable @code{test-report-op},
     1751and just read the results from the report files.
     1753@item @code{component-depends-on}
     1754When you add new operations, you probably need to explain
     1755how they relate to loading, compiling, testing, etc.,
     1756in terms of dependencies between actions.
     1758That's where you typically define methods on @code{component-depends-on}.
     1759Your method will take as arguments
     1760some properly specialized operation
     1761and a component denoting a current action,
     1762and return a list of entries,
     1763denoting the children actions that the current action depends on.
     1764The format of entries is described below.
     1766It is @emph{strongly} advised that
     1767you should always append the results of @code{(call-next-method)}
     1768to the results of your method,
     1769or ``interesting'' failures will likely occur,
     1770unless you're a true specialist of ASDF internals.
     1772Each entry returned by @code{component-depends-on} is itself a list.
     1774The first element of an entry is the name of an operation:
     1775a symbol that you can use with @code{make-instance}
     1776(ASDF will instead use with @code{asdf::make-sub-operation}),
     1777to create a related operation for use in a build plan.
     1778For instance, @code{load-op} and @code{compile-op}
     1779are common such names, denoting the respective operations.
     1781The rest of an entry is a list of identifiers
     1782each denote a component such that
     1783the pair of the previous operation and this component
     1784is a children action of current action.
     1786Identifiers follow the @code{defsystem} grammar
     1787previously documented.
     1788The main format for identifiers is a string or symbol
     1789(that will be downcase as per @code{coerce-name}),
     1790and looked up against the sibling list of the parent module's children components,
     1791as per @code{find-component}.
     1792As a special case, @code{nil} denotes the parent itself.
     1793Other syntaxes are allowed, for instance to specify a component with a version.
    15031795@end itemize
    1687   for all x, (load x) depends on (compile x)
     1979  for all source file x, (load x) depends on (compile x)
    16881980@end verbatim
    1806 This attribute takes one of the values
    1807 @code{:fail}, @code{:try-next}, @code{:ignore},
    1808 its default value is @code{:fail}.
    1809 The other values can be used for implementing conditional compilation
    1810 based on implementation @code{*features*},
    1811 for the case where it is not necessary for all files in a module to be
    1812 compiled.
    1813 @emph{FIXME: such conditional compilation has been reported
    1814 to be broken in 2009.}
     2098This attribute was removed in ASDF 2.27. Do not use it.
     2099Use @code{:if-feature} instead.
    19882273in configuration files, no matter if the last one inherits or not.
     2276@section Truenames and other dangers
     2278One great innovation of the original ASDF was its ability to leverage
     2279@code{CL:TRUENAME} to locate where your source code was and where to build it,
     2280allowing for symlink farms as a simple but effective configuration mechanism
     2281that is easy to control programmatically.
     2282ASDF2 still supports this configuration style, and it is enabled by default;
     2283however we recommend you instead use
     2284our source-registry configuration mechanism described below,
     2285because it is easier to setup in a portable way across users and implementations.
     2287Addtionally, some people dislike truename,
     2288either because it is very slow on their system, or
     2289because they are using content-addressed storage where the truename of a file
     2290is related to a digest of its individual contents,
     2291and not to other files in the same intended project.
     2292For these people, ASDF 2.27 allows to eschew the @code{TRUENAME} mechanism,
     2293by setting the variable @var{asdf:*resolve-symlinks*} to @code{NIL}.
     2295PS: Yes, if you haven't read Vernor Vinge's short but great classic
     2296``True Names... and Other Dangers'' then you're in for a treat.
    19902299@section XDG base directory
    20052314we try to use folder configuration from the registry regarding
    20062315@code{Common AppData} and similar directories.
    2007 However, support for querying the Windows registry is limited as of ASDF 2,
    2008 and on many implementations, we may fall back to always using the defaults
    2009 without consulting the registry.
    2010 Patches welcome.
     2316Since support for querying the Windows registry
     2317is not possible to do in reasonable amounts of portable Common Lisp code,
     2318ASDF 2 relies on the environment variables that Windows usually exports.
    20122320@section Backward Compatibility
    2324 @section Future
    2326 If this mechanism is successful, in the future, we may declare
    2327 @code{asdf:*central-registry*} obsolete and eventually remove it.
    2328 Any hook into implementation-specific search mechanisms will by then
    2329 have been integrated in the @code{:default-configuration} which everyone
    2330 should either explicitly use or implicit inherit. Some shell syntax
    2331 for it should probably be added somehow.
    2333 But we're not there yet. For now, let's see how practical this new
    2334 source-registry is.
     2632@section Status
     2634This mechanism is vastly successful, and we have declared
     2635that @code{asdf:*central-registry*} is not recommended anymore,
     2636though we will continue to support it.
     2637All hooks into implementation-specific search mechanisms
     2638have been integrated in the @code{wrapping-source-registry}
     2639that everyone uses implicitly.
    28993204When declaring a component (system, module, file),
    29003205you can specify a keyword argument @code{:around-compile function}.
    2901 If left unspecified,
     3206If left unspecified (and therefore unbound),
    29023207the value will be inherited from the parent component if any,
    29033208or with a default of @code{nil}
    29083213a function object (e.g. using @code{#.#'} but that's discouraged
    29093214because it prevents the introspection done by e.g. asdf-dependency-grovel),
    2910 or a string that when read yields a symbol or a lambda-expression.
     3215or a string that when @code{read} yields a symbol or a lambda-expression.
    29113216@code{nil} means the normal compile-file function will be called.
    29123217A non-nil value designates a function of one argument
    2913 that will be called with a function that
    2914 calls the @code{*compile-op-compile-file-function*}
    2915 (usually @code{compile-file*})
    2916 with proper arguments;
    2917 the around-compile hook may supply additional arguments
    2918 to pass to that @code{*compile-op-compile-file-function*}.
     3218that will be called with a function that will
     3219invoke @code{compile-file*} with various arguments;
     3220the around-compile hook may supply additional keyword arguments
     3221to pass to that call to @code{compile-file*}.
    29203223One notable argument that is heeded by @code{compile-file*} is
    29243227the function shall return true if the compilation
    29253228and its resulting compiled file respected all system-specific invariants,
    2926 and false (NIL) if it broke any of those invariants;
    2927 it may issue warnings or errors before it returns NIL.
     3229and false (@code{nil}) if it broke any of those invariants;
     3230it may issue warnings or errors before it returns @code{nil}.
    29283231(NB: The ability to pass such extra flags
    29293232is only available starting with ASDF 2.22.3.)
    3101 @section Miscellaneous Exported Functions
     3404@section Miscellaneous Functions
     3406Most of these functions are not exported by ASDF anymore,
     3407but only used for private purposes of ASDF.
     3408Please use ASDF-UTILS for the same functions exported from a stable library.
    31033410@defun coerce-pathname name @&key type defaults
    31943501@end defun
     3503@defun run-program
     3505run-program takes a @var{COMMAND} argument that is either
     3506a list of a program path and its arguments,
     3507or a string to be executed by a shell.
     3508It spawns the command, waits for it to return,
     3509verifies that it exited cleanly (unless told not too below),
     3510and optionally captures and processes its output.
     3511It accepts many keyword arguments to configure its behavior.
     3513@code{output} is its most important argument;
     3514it specifies how the output is captured and processed.
     3515If it is @code{nil}, then the output is not captured.
     3516If it is @code{:interactive}, then
     3517input and output are inherited from the current process,
     3518which the subprocess can control until it exits.
     3519Otherwise, the output is captured and redirected to a stream,
     3520and processed by @code{slurp-input-stream} with the object as first argument.
     3521See below.
     3523@code{element-type} and @code{external-format} are passed on
     3524to your Lisp implementation, when available, for creation of the output stream.
     3526@code{force-shell} forces evaluation of the command through a shell,
     3527even if it was passed as a list rather than a string.
     3529@code{ignore-error-status} causes @code{run-program}
     3530to not raise an error if the spawned program exits in error.
     3531Following POSIX convention, an error is anything but
     3532a normal exit with status code zero.
     3534run-program works on all platforms supported by ASDF, except Genera.
     3536@end defun
     3538@defun slurp-input-stream
     3540It's a generic function of two arguments, a target object and an input stream,
     3541and accepting keyword arguments.
     3542Predefined methods based on the target object are as follow:
     3544If the object is a function, the function is called with the stream as argument.
     3546If the object is a cons, its first element is applied to its rest appended by
     3547a list of the input stream.
     3549If the object is an output stream, the contents of the input stream are copied to it.
     3550If the linewise argument is provided, copying happens line by line,
     3551and an optional prefix is printed before each line.
     3552Otherwise, copying happen based on a buffer of size buffer-size,
     3553using the element-type.
     3555If the object is 'string or :string, the content is captured into a string
     3556of the given element-type.
     3558If the object is :lines, the content is captured as a list of strings,
     3559one per line, without line ending. If the count argument is provided,
     3560it is a maximum count of lines to be read.
     3562If the object is :line, the content is capture as with :lines above,
     3563and then its sub-object is extracted with the path argument,
     3564which defaults to 0, extracting the first line.
     3565A number will extract the corresponding line.
     3566See the documentation for asdf-driver:sub-object.
     3568If the object is :forms, the content is captured as a list of S-expressions,
     3569as read by the Lisp reader.
     3570If the count argument is provided,
     3571it is a maximum count of lines to be read.
     3572We recommend you control the syntax with such macro as
     3575If the object is :form, the content is capture as with :forms above,
     3576and then its sub-object is extracted with the path argument,
     3577which defaults to 0, extracting the first form.
     3578A number will extract the corresponding form.
     3579See the documentation for asdf-driver:sub-object.
     3580We recommend you control the syntax with such macro as
     3583@end defun
    31963585@defun run-shell-command
    32003589Its current behavior is only well-defined on Unix platforms
    32013590(which include MacOS X and cygwin). On Windows, anything goes.
    3203 Instead we recommend the use of such a function as
    3204 @code{xcvb-driver:run-program/}
    3205 from the @code{xcvb-driver} system that is distributed with XCVB:
    3206 @url{}.
    3207 It's the only alternative that supports
    3208 as many implementations and operating systems as ASDF does,
    3209 and provides well-defined behavior outside Unix (i.e. on Windows).
    3210 (The only unsupported exception is Genera, since on it
    3211 @code{run-shell-command} doesn't make sense anyway on that platform).
     3591The following documentation is only for the purpose of your migrating away from it
     3592in a way that preserves semantics.
     3594Instead we recommend the use @code{run-program} above
     3595available as part of ASDF since ASDF 2.27.
    32133597@code{run-shell-command} takes as arguments a @code{format} control-string
    3390 The infamous TRAVERSE function has been revamped significantly,
    3391 with many bugs squashed.
     3774The infamous TRAVERSE function has been revamped completely
     3775between ASDF 1 and ASDF 2, with many bugs squashed.
    33923776In particular, dependencies were not correctly propagated
    3393 across submodules within a system but now are.
    3394 The :version and :feature features and
     3777across modules but now are.
     3778It has been completely rewritten many times over
     3779between ASDF 2.000 and ASDF 2.27,
     3780with fundamental issues in the original model being fixed.
     3781Timestamps were not propagated at all, and now are.
     3782The internal model of how actions depend on each other
     3783is now both consistent and complete.
     3784The :version and
    33953785the :force (system1 .. systemN) feature have been fixed.
    34163806Support was lacking for some implementations.
    34173807ABCL and GCL were notably wholly broken.
    3418 ECL extensions were not integrated in the ASDF release.
     3808ECL extensions were not integrated with ASDF release.
    36334023but @file{asdf.asd} if included at all,
    36344024should be secluded from the magic systems,
    3635 in a separate file hierarchy;
    3636 alternatively, you may provide the system
     4025in a separate file hierarchy.
     4026Alternatively, you may provide the system
    36374027after renaming it and its @file{.asd} file to e.g.
    36384028@code{asdf-ecl} and @file{asdf-ecl.asd}, or
    36464036If you do not have any such magic systems, or have other non-magic systems
    36474037that you want to bundle with your implementation,
    3648 then you may add them to the @code{default-source-registry},
     4038then you may add them to the @code{wrapping-source-registry},
    36494039and you are welcome to include @file{asdf.asd} amongst them.
     4040Non-magic systems should be at the back of the @code{wrapping-source-registry}
     4041while magic systems are at the front.
    38744266(defclass cl-source-file.lis (cl-source-file)
    3875    ((type :initform "lis")))
     4267  ((type :initform "lis")))
    38764268@end lisp
    3909 (defmethod source-file-type ((f cl-source-file.lis) (m module))
    3910   (declare (ignorable f m))
     4301(defmethod source-file-type ((f cl-source-file.lis) (s system))
     4302  (declare (ignorable f s))
    39114303  "lis")
    39124304@end lisp
    39744366** proclamations probably aren't
    3976 ** (stuff that might happen later)
    3978 *** Propagation of the @code{:force} option.
    3980 ``I notice that
    3982         @code{(asdf:compile-system :araneida :force t)}
    3984 also forces compilation of every other system
    3985 the @code{:araneida} system depends on.
    3986 This is rarely useful to me;
    3987 usually, when I want to force recompilation
    3988 of something more than a single source file,
    3989 I want to recompile only one system.
    3990 So it would be more useful to have @code{make-sub-operation}
    3991 refuse to propagate @code{:force t} to other systems, and
    3992 propagate only something like @code{:force :recursively}.
    3994 Ideally what we actually want is some kind of criterion that says
    3995 to which systems (and which operations) a @code{:force} switch will propagate.
    3997 The problem is perhaps that ``force'' is a pretty meaningless concept.
    3998 How obvious is it that @code{load :force t} should force @emph{compilation}?
    3999 But we don't really have the right dependency setup
    4000 for the user to compile @code{:force t} and expect it to work
    4001 (files will not be loaded after compilation, so the compile
    4002 environment for subsequent files will be emptier than it needs to be)
    4004 What does the user actually want to do when he forces?
    4005 Usually, for me, update for use with a new version of the Lisp compiler.
    4006 Perhaps for recovery when he suspects that something has gone wrong.
    4007 Or else when he's changed compilation options or configuration
    4008 in some way that's not reflected in the dependency graph.
     4368** A revert function
    40104370Other possible interface: have a ``revert'' function akin to @code{make clean}.
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14277 r14361  
    1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
    2 ;;; This is ASDF 2.26.6: Another System Definition Facility.
     1;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
     2;;; This is ASDF Another System Definition Facility.
    44;;; Feedback, bug reports, and patches are all welcome:
    4848#+xcvb (module ())
    50 (cl:in-package :common-lisp-user)
    51 #+genera (in-package :future-common-lisp-user)
     50(in-package :cl-user)
     53(eval-when (:load-toplevel :compile-toplevel :execute)
     54  (documentation 'car 'function)) ;; workaround (SETF DOCUMENTATION) autoloader bug
     57(eval-when (:load-toplevel :compile-toplevel :execute)
     58  (declaim (optimize (speed 1) (safety 3) (debug 3)))
     59  (setf ext:*gc-verbose* nil))
     61#+(or abcl clisp cmu)
     62(eval-when (:load-toplevel :compile-toplevel :execute)
     63  (unless (member :asdf2.27 *features*)
     64    (let* ((existing-version
     65             (when (find-package :asdf)
     66               (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
     67                   (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
     68                     (etypecase ver
     69                       (string ver)
     70                       (cons (format nil "~{~D~^.~}" ver))
     71                       (null "1.0"))))))
     72           (away (format nil "~A-~A" :asdf existing-version)))
     73      (when existing-version
     74        (rename-package :asdf away)
     75        (when *load-verbose*
     76          (format t "; Renamed package ~A away to ~A~%" :asdf away))))))
     78;;;; ---------------------------------------------------------------------------
     79;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     81;; See
     83;; CAUTION: we must handle the first few packages specially for hot-upgrade.
     84;; asdf/package will be frozen as of 2.27
     85;; to forever export the same exact symbols.
     86;; Any other symbol must be import-from'ed
     87;; and reexported in a different package
     88;; (alternatively the package may be dropped & replaced by one with a new name).
     90(defpackage :asdf/package
     91  (:use :common-lisp)
     92  (:export
     93   #:find-package* #:find-symbol* #:symbol-call
     94   #:intern* #:unintern* #:export* #:make-symbol*
     95   #:symbol-shadowing-p #:home-package-p #:rehome-symbol
     96   #:symbol-package-name #:standard-common-lisp-symbol-p
     97   #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
     98   #:nuke-symbol-in-package #:nuke-symbol
     99   #:ensure-package-unused #:delete-package*
     100   #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
     101   #:package-definition-form #:parse-define-package-form
     102   #:ensure-package #:define-package))
     104(in-package :asdf/package)
     106;;;; General purpose package utilities
     108(eval-when (:load-toplevel :compile-toplevel :execute)
     109  (defun find-package* (package-designator &optional (error t))
     110    (let ((package (find-package package-designator)))
     111      (cond
     112        (package package)
     113        (error (error "No package named ~S" (string package-designator)))
     114        (t nil))))
     115  (defun find-symbol* (name package-designator &optional (error t))
     116    "Find a symbol in a package of given string'ified NAME;
     117unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
     118by letting you supply a symbol or keyword for the name;
     119also works well when the package is not present.
     120If optional ERROR argument is NIL, return NIL instead of an error
     121when the symbol is not found."
     122    (block nil
     123      (let ((package (find-package* package-designator error)))
     124        (when package ;; package error handled by find-package* already
     125          (multiple-value-bind (symbol status) (find-symbol (string name) package)
     126            (cond
     127              (status (return (values symbol status)))
     128              (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
     129        (values nil nil))))
     130  (defun symbol-call (package name &rest args)
     131    "Call a function associated with symbol of given name in given package,
     132with given ARGS. Useful when the call is read before the package is loaded,
     133or when loading the package is optional."
     134    (apply (find-symbol* name package) args))
     135  (defun intern* (name package-designator &optional (error t))
     136    (intern (string name) (find-package* package-designator error)))
     137  (defun export* (name package-designator)
     138    (let* ((package (find-package* package-designator))
     139           (symbol (intern* name package)))
     140      (export (or symbol (list symbol)) package)))
     141  (defun make-symbol* (name)
     142    (etypecase name
     143      (string (make-symbol name))
     144      (symbol (copy-symbol name))))
     145  (defun unintern* (name package-designator &optional (error t))
     146    (block nil
     147      (let ((package (find-package* package-designator error)))
     148        (when package
     149          (multiple-value-bind (symbol status) (find-symbol* name package error)
     150            (cond
     151              (status (unintern symbol package)
     152                      (return (values symbol status)))
     153              (error (error "symbol ~A not present in package ~A"
     154                            (string symbol) (package-name package))))))
     155        (values nil nil))))
     156  (defun symbol-shadowing-p (symbol package)
     157    (and (member symbol (package-shadowing-symbols package)) t))
     158  (defun home-package-p (symbol package)
     159    (and package (let ((sp (symbol-package symbol)))
     160                   (and sp (let ((pp (find-package* package)))
     161                             (and pp (eq sp pp))))))))
     164(eval-when (:load-toplevel :compile-toplevel :execute)
     165  (defun symbol-package-name (symbol)
     166    (let ((package (symbol-package symbol)))
     167      (and package (package-name package))))
     168  (defun standard-common-lisp-symbol-p (symbol)
     169    (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
     170      (and (eq sym symbol) (eq status :external))))
     171  (defun reify-package (package &optional package-context)
     172    (if (eq package package-context) t
     173        (etypecase package
     174          (null nil)
     175          ((eql (find-package :cl)) :cl)
     176          (package (package-name package)))))
     177  (defun unreify-package (package &optional package-context)
     178    (etypecase package
     179      (null nil)
     180      ((eql t) package-context)
     181      ((or symbol string) (find-package package))))
     182  (defun reify-symbol (symbol &optional package-context)
     183    (etypecase symbol
     184      ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
     185      (symbol (vector (symbol-name symbol)
     186                      (reify-package (symbol-package symbol) package-context)))))
     187  (defun unreify-symbol (symbol &optional package-context)
     188    (etypecase symbol
     189      (symbol symbol)
     190      ((simple-vector 2)
     191       (let* ((symbol-name (svref symbol 0))
     192              (package-foo (svref symbol 1))
     193              (package (unreify-package package-foo package-context)))
     194         (if package (intern* symbol-name package)
     195             (make-symbol* symbol-name)))))))
     197(eval-when (:load-toplevel :compile-toplevel :execute)
     198  (defvar *all-package-happiness* '())
     199  (defvar *all-package-fishiness* (list t))
     200  (defvar *package-fishiness* '())
     201  (defun flush-fishy ()
     202    (when *package-fishiness*
     203      (if (null (rest *package-fishiness*))
     204          (push (first *package-fishiness*) *all-package-happiness*)
     205          (push (nreverse *package-fishiness*) *all-package-fishiness*))
     206      (setf *package-fishiness* nil)))
     207  (defun record-fishy (info)
     208    ;;(format t "~&FISHY: ~S~%" info)
     209    (push info *package-fishiness*))
     210  (defmacro when-package-fishiness (&body body)
     211    `(when *all-package-fishiness* ,@body))
     212  (defmacro note-package-fishiness (&rest info)
     213    `(when-package-fishiness (record-fishy (list ,@info)))))
     215(eval-when (:load-toplevel :compile-toplevel :execute)
     216  #+(or clisp clozure)
     217  (defun get-setf-function-symbol (symbol)
     218    #+clisp (let ((sym (get symbol 'system::setf-function)))
     219              (if sym (values sym :setf-function)
     220                  (let ((sym (get symbol 'system::setf-expander)))
     221                    (if sym (values sym :setf-expander)
     222                        (values nil nil)))))
     223    #+clozure (gethash symbol ccl::%setf-function-names%))
     224  #+(or clisp clozure)
     225  (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
     226    #+clisp (assert (member kind '(:setf-function :setf-expander)))
     227    #+clozure (assert (eq kind t))
     228    #+clisp
     229    (cond
     230      ((null new-setf-symbol)
     231       (remprop symbol 'system::setf-function)
     232       (remprop symbol 'system::setf-expander))
     233      ((eq kind :setf-function)
     234       (setf (get symbol 'system::setf-function) new-setf-symbol))
     235      ((eq kind :setf-expander)
     236       (setf (get symbol 'system::setf-expander) new-setf-symbol))
     237      (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
     238                kind symbol new-setf-symbol)))
     239    #+clozure
     240    (progn
     241      (gethash symbol ccl::%setf-function-names%) new-setf-symbol
     242      (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
     243  #+(or clisp clozure)
     244  (defun create-setf-function-symbol (symbol)
     245    #+clisp (system::setf-symbol symbol)
     246    #+clozure (ccl::construct-setf-function-name symbol))
     247  (defun set-dummy-symbol (symbol reason other-symbol)
     248    (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
     249  (defun make-dummy-symbol (symbol)
     250    (let ((dummy (copy-symbol symbol)))
     251      (set-dummy-symbol dummy 'replacing symbol)
     252      (set-dummy-symbol symbol 'replaced-by dummy)
     253      dummy))
     254  (defun dummy-symbol (symbol)
     255    (get symbol 'dummy-symbol))
     256  (defun get-dummy-symbol (symbol)
     257    (let ((existing (dummy-symbol symbol)))
     258      (if existing (values (cdr existing) (car existing))
     259          (make-dummy-symbol symbol))))
     260  (defun nuke-symbol-in-package (symbol package-designator)
     261    (let ((package (find-package* package-designator))
     262          (name (symbol-name symbol)))
     263      (multiple-value-bind (sym stat) (find-symbol name package)
     264        (when (and (member stat '(:internal :external)) (eq symbol sym))
     265          (if (symbol-shadowing-p symbol package)
     266              (shadowing-import (get-dummy-symbol symbol) package)
     267              (unintern symbol package))))))
     268  (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
     269    #+(or clisp clozure)
     270    (multiple-value-bind (setf-symbol kind)
     271        (get-setf-function-symbol symbol)
     272      (when kind (nuke-symbol setf-symbol)))
     273    (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
     274  (defun rehome-symbol (symbol package-designator)
     275    "Changes the home package of a symbol, also leaving it present in its old home if any"
     276    (let* ((name (symbol-name symbol))
     277           (package (find-package* package-designator))
     278           (old-package (symbol-package symbol))
     279           (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
     280           (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
     281      (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
     282        (unless (eq package old-package)
     283          (let ((overwritten-symbol-shadowing-p
     284                  (and overwritten-symbol-status
     285                       (symbol-shadowing-p overwritten-symbol package))))
     286            (note-package-fishiness
     287             :rehome-symbol name (package-name old-package)
     288             (package-name package) old-status (and shadowing t)
     289             overwritten-symbol-status overwritten-symbol-shadowing-p)
     290            (when old-package
     291              (if shadowing
     292                  (shadowing-import shadowing old-package))
     293              (unintern symbol old-package))
     294            (cond
     295              (overwritten-symbol-shadowing-p
     296               (shadowing-import symbol package))
     297              (t
     298               (when overwritten-symbol-status
     299                 (unintern overwritten-symbol package))
     300               (import symbol package)))
     301            (if shadowing
     302                (shadowing-import symbol old-package)
     303                (import symbol old-package))
     304            #+(or clisp clozure)
     305            (multiple-value-bind (setf-symbol kind)
     306                (get-setf-function-symbol symbol)
     307              (when kind
     308                (let* ((setf-function (fdefinition setf-symbol))
     309                       (new-setf-symbol (create-setf-function-symbol symbol)))
     310                  (note-package-fishiness
     311                   :setf-function
     312                   name (package-name package)
     313                   (symbol-name setf-symbol) (symbol-package-name setf-symbol)
     314                   (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
     315                  (when (symbol-package setf-symbol)
     316                    (unintern setf-symbol (symbol-package setf-symbol)))
     317                  (setf (fdefinition new-setf-symbol) setf-function)
     318                  (set-setf-function-symbol new-setf-symbol symbol kind))))
     319            #+(or clisp clozure)
     320            (multiple-value-bind (overwritten-setf foundp)
     321                (get-setf-function-symbol overwritten-symbol)
     322              (when foundp
     323                (unintern overwritten-setf)))
     324            (when (eq old-status :external)
     325              (export* symbol old-package))
     326            (when (eq overwritten-symbol-status :external)
     327              (export* symbol package))))
     328        (values overwritten-symbol overwritten-symbol-status))))
     329  (defun ensure-package-unused (package)
     330    (loop :for p :in (package-used-by-list package) :do
     331      (unuse-package package p)))
     332  (defun delete-package* (package &key nuke)
     333    (let ((p (find-package package)))
     334      (when p
     335        (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
     336        (ensure-package-unused p)
     337        (delete-package package))))
     338  (defun package-names (package)
     339    (cons (package-name package) (package-nicknames package)))
     340  (defun packages-from-names (names)
     341    (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
     342  (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
     343                               separator
     344                               (index (random most-positive-fixnum)))
     345    (loop :for i :from index
     346          :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
     347          :thereis (and (not (find-package n)) n)))
     348  (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
     349    (let ((new-name
     350            (apply 'fresh-package-name
     351                   :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
     352      (record-fishy (list :rename-away (package-names p) new-name))
     353      (rename-package p new-name))))
     356;;; Communicable representation of symbol and package information
     358(eval-when (:load-toplevel :compile-toplevel :execute)
     359  (defun package-definition-form (package-designator
     360                                  &key (nicknamesp t) (usep t)
     361                                    (shadowp t) (shadowing-import-p t)
     362                                    (exportp t) (importp t) internp (error t))
     363    (let* ((package (or (find-package* package-designator error)
     364                        (return-from package-definition-form nil)))
     365           (name (package-name package))
     366           (nicknames (package-nicknames package))
     367           (use (mapcar #'package-name (package-use-list package)))
     368           (shadow ())
     369           (shadowing-import (make-hash-table :test 'equal))
     370           (import (make-hash-table :test 'equal))
     371           (export ())
     372           (intern ()))
     373      (when package
     374        (loop :for sym :being :the :symbols :in package
     375              :for status = (nth-value 1 (find-symbol* sym package)) :do
     376                (ecase status
     377                  ((nil :inherited))
     378                  ((:internal :external)
     379                   (let* ((name (symbol-name sym))
     380                          (external (eq status :external))
     381                          (home (symbol-package sym))
     382                          (home-name (package-name home))
     383                          (imported (not (eq home package)))
     384                          (shadowing (symbol-shadowing-p sym package)))
     385                     (cond
     386                       ((and shadowing imported)
     387                        (push name (gethash home-name shadowing-import)))
     388                       (shadowing
     389                        (push name shadow))
     390                       (imported
     391                        (push name (gethash home-name import))))
     392                     (cond
     393                       (external
     394                        (push name export))
     395                       (imported)
     396                       (t (push name intern)))))))
     397        (labels ((sort-names (names)
     398                   (sort names #'string<))
     399                 (table-keys (table)
     400                   (loop :for k :being :the :hash-keys :of table :collect k))
     401                 (when-relevant (key value)
     402                   (when value (list (cons key value))))
     403                 (import-options (key table)
     404                   (loop :for i :in (sort-names (table-keys table))
     405                         :collect `(,key ,i ,@(sort-names (gethash i table))))))
     406          `(defpackage ,name
     407             ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
     408             (:use ,@(and usep (sort-names use)))
     409             ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
     410             ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
     411             ,@(import-options :import-from (and importp import))
     412             ,@(when-relevant :export (and exportp (sort-names export)))
     413             ,@(when-relevant :intern (and internp (sort-names intern)))))))))
     416;;; ensure-package, define-package
     418(eval-when (:load-toplevel :compile-toplevel :execute)
     419  (defun ensure-package (name &key
     420                                nicknames documentation use
     421                                shadow shadowing-import-from
     422                                import-from export intern
     423                                recycle mix reexport
     424                                unintern)
     425    (declare (ignorable documentation))
     426    (macrolet ((when-fishy (&body body) `(when-package-fishiness ,@body))
     427               (fishy (&rest info) `(note-package-fishiness ,@info)))
     428      (let* ((package-name (string name))
     429             (nicknames (mapcar #'string nicknames))
     430             (names (cons package-name nicknames))
     431             (previous (packages-from-names names))
     432             (discarded (cdr previous))
     433             (to-delete ())
     434             (package (or (first previous) (make-package package-name :nicknames nicknames)))
     435             (recycle (packages-from-names recycle))
     436             (use (mapcar 'find-package* use))
     437             (mix (mapcar 'find-package* mix))
     438             (reexport (mapcar 'find-package* reexport))
     439             (shadow (mapcar 'string shadow))
     440             (export (mapcar 'string export))
     441             (intern (mapcar 'string intern))
     442             (unintern (mapcar 'string unintern))
     443             (shadowed (make-hash-table :test 'equal)) ; string to bool
     444             (imported (make-hash-table :test 'equal)) ; string to bool
     445             (exported (make-hash-table :test 'equal)) ; string to bool
     446             ;; string to list home package and use package:
     447             (inherited (make-hash-table :test 'equal)))
     448        (when-fishy (record-fishy package-name))
     449        (labels
     450            ((ensure-shadowing-import (name p)
     451               (let ((import-me (find-symbol* name p)))
     452                 (multiple-value-bind (existing status) (find-symbol name package)
     453                   (cond
     454                     ((gethash name shadowed)
     455                      (unless (eq import-me existing)
     456                        (error "Conflicting shadowings for ~A" name)))
     457                     (t
     458                      (setf (gethash name shadowed) t)
     459                      (setf (gethash name imported) t)
     460                      (unless (or (null status)
     461                                  (and (member status '(:internal :external))
     462                                       (eq existing import-me)
     463                                       (symbol-shadowing-p existing package)))
     464                        (fishy :shadowing-import
     465                               name (package-name p) (symbol-package-name import-me)
     466                               (and status (symbol-package-name existing)) status))
     467                      (shadowing-import import-me package))))))
     468             (ensure-import (sym p)
     469               (let* ((name (string sym))
     470                      (import-me (find-symbol* name p)))
     471                 (multiple-value-bind (existing status) (find-symbol name package)
     472                   (cond
     473                     ((gethash name imported)
     474                      (unless (eq import-me existing)
     475                        (error "Can't import ~S from both ~S and ~S"
     476                               name (package-name (symbol-package existing)) (package-name p))))
     477                     ((gethash name shadowed)
     478                      (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
     479                     (t
     480                      (setf (gethash name imported) t)
     481                      (unless (and status (eq import-me existing))
     482                        (when status
     483                          (fishy :import name (package-name p) (symbol-package-name import-me)
     484                                 (and status (symbol-package-name existing)) status)
     485                          (unintern* existing package))
     486                        (import import-me package)))))))
     487             (ensure-mix (name symbol p)
     488               (unless (gethash name shadowed)
     489                 (multiple-value-bind (existing status) (find-symbol name package)
     490                   (let* ((sp (symbol-package symbol))
     491                          (im (gethash name imported))
     492                          (in (gethash name inherited)))
     493                     (cond
     494                       ((or (null status)
     495                            (and status (eq symbol existing))
     496                            (and in (eq sp (first in))))
     497                        (ensure-inherited name symbol p t))
     498                       (in
     499                        (remhash name inherited)
     500                        (ensure-shadowing-import name (second in)))
     501                       (im
     502                         (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S"
     503                                existing symbol (package-name package)))
     504                       (t
     505                        (ensure-inherited name symbol p t)))))))
     506             (ensure-inherited (name symbol p mix)
     507               (multiple-value-bind (existing status) (find-symbol name package)
     508                 (let* ((sp (symbol-package symbol))
     509                        (in (gethash name inherited))
     510                        (xp (and status (symbol-package existing))))
     511                   (when (null sp)
     512                     (fishy :import-uninterned name (package-name p) mix)
     513                     (import symbol p)
     514                     (setf sp (package-name p)))
     515                   (cond
     516                     ((gethash name shadowed))
     517                     (in
     518                      (unless (equal sp (first in))
     519                        (if mix
     520                            (ensure-shadowing-import name (second in))
     521                            (error "Can't inherit ~S from ~S, it is inherited from ~S"
     522                                   name (package-name sp) (package-name (first in))))))
     523                     ((gethash name imported)
     524                      (unless (eq symbol existing)
     525                        (error "Can't inherit ~S from ~S, it is imported from ~S"
     526                               name (package-name sp) (package-name xp))))
     527                     (t
     528                      (setf (gethash name inherited) (list sp p))
     529                      (when (and status (not (eq sp xp)))
     530                        (let ((shadowing (symbol-shadowing-p existing package)))
     531                          (fishy :inherited name (package-name p) (package-name sp)
     532                                 (package-name xp))
     533                          (if shadowing (ensure-shadowing-import name p)
     534                              (unintern* existing package)))))))))
     535             (recycle-symbol (name)
     536               (when (gethash name exported) ;; don't bother recycling private symbols
     537                 (let (recycled foundp)
     538                   (dolist (r recycle (values recycled foundp))
     539                     (multiple-value-bind (symbol status) (find-symbol name r)
     540                       (when (and status (home-package-p symbol r))
     541                         (cond
     542                           (foundp
     543                            ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
     544                            (fishy :recycled-duplicate name (package-name foundp) (package-name r)))
     545                           (t
     546                            (setf recycled symbol foundp r)))))))))
     547             (symbol-recycled-p (sym)
     548               (member (symbol-package sym) recycle))
     549             (ensure-symbol (name &optional intern)
     550               (unless (or (gethash name shadowed)
     551                           (gethash name imported)
     552                           (gethash name inherited))
     553                 (multiple-value-bind (existing status)
     554                     (find-symbol name package)
     555                   (multiple-value-bind (recycled previous) (recycle-symbol name)
     556                     (cond
     557                       ((and status (eq existing recycled) (eq previous package)))
     558                       (previous
     559                        (rehome-symbol recycled package))
     560                       ((and status (eq package (symbol-package existing))))
     561                       (t
     562                        (when status
     563                          (fishy :ensure-symbol name
     564                                 (reify-package (symbol-package existing) package)
     565                                 status intern)
     566                          (unintern existing))
     567                        (when intern
     568                          (intern* name package))))))))
     569             (ensure-export (name p)
     570               (multiple-value-bind (symbol status) (find-symbol* name p)
     571                 (unless (eq status :external)
     572                   (ensure-exported name symbol p))))
     573             (ensure-exported (name sym p)
     574               (dolist (u (package-used-by-list p))
     575                 (ensure-exported-to-user name sym u))
     576               (export* sym p))
     577             (ensure-exported-to-user (name sym u)
     578               (multiple-value-bind (usym ustat) (find-symbol name u)
     579                 (unless (and ustat (eq sym usym))
     580                   (let ((accessible
     581                           (or (null ustat)
     582                               (let ((shadowing (symbol-shadowing-p usym u))
     583                                     (recycled (symbol-recycled-p usym)))
     584                                 (unless (and shadowing (not recycled))
     585                                   (fishy :ensure-export name (symbol-package-name sym)
     586                                          (package-name u)
     587                                          (and ustat (symbol-package-name usym)) ustat shadowing)
     588                                   (if (or (eq ustat :inherited) shadowing)
     589                                       (shadowing-import sym u)
     590                                       (unintern usym u))
     591                                   t)))))
     592                     (when (and accessible (eq ustat :external))
     593                       (ensure-exported name sym u)))))))
     594          #-(or gcl genera) (setf (documentation package t) documentation) #+gcl documentation
     595          (loop :for p :in (set-difference (package-use-list package) (append mix use))
     596                :do (fishy :use (package-names p)) (unuse-package p package))
     597          (loop :for p :in discarded
     598                :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
     599                                    (package-names p))
     600                :do (fishy :nickname (package-names p))
     601                    (cond (n (rename-package p (first n) (rest n)))
     602                          (t (rename-package-away p)
     603                             (push p to-delete))))
     604          (rename-package package package-name nicknames)
     605          (dolist (name unintern)
     606            (multiple-value-bind (existing status) (find-symbol name package)
     607              (when status
     608                (unless (eq status :inherited)
     609                  (fishy :unintern name (symbol-package-name existing) status)
     610                  (unintern* name package nil)))))
     611          (dolist (name export)
     612            (setf (gethash name exported) t))
     613          (dolist (p reexport)
     614            (do-external-symbols (sym p)
     615              (setf (gethash (string sym) exported) t)))
     616          (do-external-symbols (sym package)
     617            (let ((name (symbol-name sym)))
     618              (unless (gethash name exported)
     619                (fishy :over-exported name (symbol-package-name sym))
     620                (unexport sym package))))
     621          (dolist (name shadow)
     622            (setf (gethash name shadowed) t)
     623            (multiple-value-bind (existing status) (find-symbol name package)
     624              (multiple-value-bind (recycled previous) (recycle-symbol name)
     625                (let ((shadowing (and status (symbol-shadowing-p existing package))))
     626                  (cond
     627                    ((eq previous package))
     628                    (previous
     629                     (rehome-symbol recycled package))
     630                    ((or (member status '(nil :inherited))
     631                         (home-package-p existing package)))
     632                    (t
     633                     (let ((dummy (make-symbol name)))
     634                       (fishy :shadow-imported name (symbol-package-name existing) status shadowing)
     635                       (shadowing-import dummy package)
     636                       (import dummy package)))))))
     637            (shadow name package))
     638          (loop :for (p . syms) :in shadowing-import-from
     639                :for pp = (find-package* p) :do
     640                  (dolist (sym syms) (ensure-shadowing-import (string sym) pp)))
     641          (dolist (p mix)
     642            (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p)))
     643          (loop :for (p . syms) :in import-from :do
     644            (dolist (sym syms) (ensure-import sym p)))
     645          (dolist (p (append use mix))
     646            (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil))
     647            (use-package p package))
     648          (loop :for name :being :the :hash-keys :of exported :do
     649            (ensure-symbol name t)
     650            (ensure-export name package))
     651          (dolist (name intern)
     652            (ensure-symbol name t))
     653          (do-symbols (sym package)
     654            (ensure-symbol (symbol-name sym)))
     655          (map () 'delete-package* to-delete)
     656          (flush-fishy)
     657          package)))))
     659(eval-when (:load-toplevel :compile-toplevel :execute)
     660  (defun parse-define-package-form (package clauses)
     661    (loop
     662      :with use-p = nil :with recycle-p = nil
     663      :with documentation = nil
     664      :for (kw . args) :in clauses
     665      :when (eq kw :nicknames) :append args :into nicknames :else
     666        :when (eq kw :documentation)
     667          :do (cond
     668                (documentation (error "define-package: can't define documentation twice"))
     669                ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
     670                (t (setf documentation (car args)))) :else
     671      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
     672        :when (eq kw :shadow) :append args :into shadow :else
     673          :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
     674            :when (eq kw :import-from) :collect args :into import-from :else
     675              :when (eq kw :export) :append args :into export :else
     676                :when (eq kw :intern) :append args :into intern :else
     677                  :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
     678                    :when (eq kw :mix) :append args :into mix :else
     679                      :when (eq kw :reexport) :append args :into reexport :else
     680                        :when (eq kw :unintern) :append args :into unintern :else
     681                          :do (error "unrecognized define-package keyword ~S" kw)
     682      :finally (return `(,package
     683                         :nicknames ,nicknames :documentation ,documentation
     684                         :use ,(if use-p use '(:common-lisp))
     685                         :shadow ,shadow :shadowing-import-from ,shadowing-import-from
     686                         :import-from ,import-from :export ,export :intern ,intern
     687                         :recycle ,(if recycle-p recycle (cons package nicknames))
     688                         :mix ,mix :reexport ,reexport :unintern ,unintern)))))
     690(defmacro define-package (package &rest clauses)
     691  (let ((ensure-form
     692          `(apply 'ensure-package ',(parse-define-package-form package clauses))))
     693    `(progn
     694       #+clisp
     695       (eval-when (:compile-toplevel :load-toplevel :execute)
     696         ,ensure-form)
     697       #+(or clisp ecl gcl) (defpackage ,package (:use))
     698       (eval-when (:compile-toplevel :load-toplevel :execute)
     699         ,ensure-form))))
     701;;;; Final tricks to keep various implementations happy.
     702;; We want most such tricks in common-lisp.lisp,
     703;; but these need to be done before the define-package form there,
     704;; that we nevertheless want to be the very first form.
     705(eval-when (:load-toplevel :compile-toplevel :execute)
     706  #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
     707  (setf excl::*autoload-package-name-alist*
     708        (remove "asdf" excl::*autoload-package-name-alist*
     709                :test 'equalp :key 'car))
     711  #+gcl
     712  ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
     713  ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
     714  (cond
     715    ((or (< system::*gcl-major-version* 2)
     716         (and (= system::*gcl-major-version* 2)
     717              (< system::*gcl-minor-version* 6)))
     718     (error "GCL 2.6 or later required to use ASDF"))
     719    ((and (= system::*gcl-major-version* 2)
     720          (= system::*gcl-minor-version* 6))
     721     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
     722     (pushnew :gcl2.6 *features*))
     723    (t
     724     (pushnew :gcl2.7 *features*))))
     725;;;; -------------------------------------------------------------------------
     726;;;; Handle compatibility with multiple implementations.
     727;;; This file is for papering over the deficiencies and peculiarities
     728;;; of various Common Lisp implementations.
     729;;; For implementation-specific access to the system, see os.lisp instead.
     730;;; A few functions are defined here, but actually exported from utility;
     731;;; from this package only common-lisp symbols are exported.
     733(asdf/package:define-package :asdf/common-lisp
     734  (:nicknames :asdf/cl)
     735  (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
     736  (:reexport :common-lisp)
     737  (:recycle :asdf/common-lisp :asdf)
     738  #+allegro (:intern #:*acl-warn-save*)
     739  #+cormanlisp
     740  (:export
     741   #:logical-pathname #:translate-logical-pathname
     742   #:make-broadcast-stream #:file-namestring)
     743  #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
     744  #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
     745  #+genera (:shadowing-import-from :scl #:boolean)
     746  #+genera (:export #:boolean #:ensure-directories-exist)
     747  #+mcl (:shadow #:user-homedir-pathname))
     748(in-package :asdf/common-lisp)
    53750#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    54751(error "ASDF is not supported on your implementation. Please help us port it.")
    56 ;;;; Create and setup packages in a way that is compatible with hot-upgrade.
    57 ;;;; See
    58 ;;;; See these two eval-when forms, and more near the end of the file.
    60 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
     753;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
     756;;;; Early meta-level tweaks
     758#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
     759      clozure lispworks (and sbcl sb-unicode) scl)
    62760(eval-when (:load-toplevel :compile-toplevel :execute)
    63   ;;; Before we do anything, some implementation-dependent tweaks
    64   ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
    65   #+allegro
    66   (setf excl::*autoload-package-name-alist*
    67         (remove "asdf" excl::*autoload-package-name-alist*
    68                 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    69   #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    70   (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
    71             (and (= system::*gcl-major-version* 2)
    72                  (< system::*gcl-minor-version* 7)))
    73     (pushnew :gcl-pre2.7 *features*))
    74   #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
    75         clozure lispworks (and sbcl sb-unicode) scl)
    76   (pushnew :asdf-unicode *features*)
    77   ;;; make package if it doesn't exist yet.
    78   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
    79   (unless (find-package :asdf)
    80     (make-package :asdf :use '(:common-lisp))))
    82 (in-package :asdf)
     761  (pushnew :asdf-unicode *features*))
    84764(eval-when (:load-toplevel :compile-toplevel :execute)
    85   ;;; This would belong amongst implementation-dependent tweaks above,
    86   ;;; except that the defun has to be in package asdf.
    87   #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
    88   #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
    89   #+mkcl (require :cmp)
    90   #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics
    92   ;;; Package setup, step 2.
    93   (defvar *asdf-version* nil)
    94   (defvar *upgraded-p* nil)
    95   (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
    96   (defun find-symbol* (s p)
    97     (find-symbol (string s) p))
    98   ;; Strip out formatting that is not supported on Genera.
    99   ;; Has to be inside the eval-when to make Lispworks happy (!)
    100   (defun strcat (&rest strings)
    101     (apply 'concatenate 'string strings))
    102   (defmacro compatfmt (format)
    103     #-(or gcl genera) format
    104     #+(or gcl genera)
    105     (loop :for (unsupported . replacement) :in
    106       (append
    107        '(("~3i~_" . ""))
    108        #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
    109       (loop :for found = (search unsupported format) :while found :do
    110         (setf format (strcat (subseq format 0 found) replacement
    111                              (subseq format (+ found (length unsupported)))))))
    112     format)
    113   (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    114          ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    115          ;; can help you do these changes in synch (look at the source for documentation).
    116          ;; Relying on its automation, the version is now redundantly present on top of this file.
    117          ;; "2.345" would be an official release
    118          ;; "2.345.6" would be a development version in the official upstream
    119          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    120          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    121          (asdf-version "2.26.6")
    122          (existing-asdf (find-class 'component nil))
    123          (existing-version *asdf-version*)
    124          (already-there (equal asdf-version existing-version)))
    125     (unless (and existing-asdf already-there)
    126       (when (and existing-asdf *asdf-verbose*)
    127         (format *trace-output*
    128                 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
    129                 existing-version asdf-version))
    130       (labels
    131           ((present-symbol-p (symbol package)
    132              (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
    133            (present-symbols (package)
    134              ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
    135              (let (l)
    136                (do-symbols (s package)
    137                  (when (present-symbol-p s package) (push s l)))
    138                (reverse l)))
    139            (unlink-package (package)
    140              (let ((u (find-package package)))
    141                (when u
    142                  (ensure-unintern u (present-symbols u))
    143                  (loop :for p :in (package-used-by-list u) :do
    144                    (unuse-package u p))
    145                  (delete-package u))))
    146            (ensure-exists (name nicknames use)
    147              (let ((previous
    148                     (remove-duplicates
    149                      (mapcar #'find-package (cons name nicknames))
    150                      :from-end t)))
    151                ;; do away with packages with conflicting (nick)names
    152                (map () #'unlink-package (cdr previous))
    153                ;; reuse previous package with same name
    154                (let ((p (car previous)))
    155                  (cond
    156                    (p
    157                     (rename-package p name nicknames)
    158                     (ensure-use p use)
    159                     p)
    160                    (t
    161                     (make-package name :nicknames nicknames :use use))))))
    162            (intern* (symbol package)
    163              (intern (string symbol) package))
    164            (remove-symbol (symbol package)
    165              (let ((sym (find-symbol* symbol package)))
    166                (when sym
    167                  #-cormanlisp (unexport sym package)
    168                  (unintern sym package)
    169                  sym)))
    170            (ensure-unintern (package symbols)
    171              (loop :with packages = (list-all-packages)
    172                :for sym :in symbols
    173                :for removed = (remove-symbol sym package)
    174                :when removed :do
    175                (loop :for p :in packages :do
    176                  (when (eq removed (find-symbol* sym p))
    177                    (unintern removed p)))))
    178            (ensure-shadow (package symbols)
    179              (shadow symbols package))
    180            (ensure-use (package use)
    181              (dolist (used (package-use-list package))
    182                (unless (member (package-name used) use :test 'string=)
    183                  (unuse-package used)
    184                  (do-external-symbols (sym used)
    185                    (when (eq sym (find-symbol* sym package))
    186                      (remove-symbol sym package)))))
    187              (dolist (used (reverse use))
    188                (do-external-symbols (sym used)
    189                  (unless (eq sym (find-symbol* sym package))
    190                    (remove-symbol sym package)))
    191                (use-package used package)))
    192            (ensure-fmakunbound (package symbols)
    193              (loop :for name :in symbols
    194                :for sym = (find-symbol* name package)
    195                :when sym :do (fmakunbound sym)))
    196            (ensure-export (package export)
    197              (let ((formerly-exported-symbols nil)
    198                    (bothly-exported-symbols nil)
    199                    (newly-exported-symbols nil))
    200                (do-external-symbols (sym package)
    201                  (if (member sym export :test 'string-equal)
    202                      (push sym bothly-exported-symbols)
    203                      (push sym formerly-exported-symbols)))
    204                (loop :for sym :in export :do
    205                  (unless (member sym bothly-exported-symbols :test 'equal)
    206                    (push sym newly-exported-symbols)))
    207                (loop :for user :in (package-used-by-list package)
    208                  :for shadowing = (package-shadowing-symbols user) :do
    209                  (loop :for new :in newly-exported-symbols
    210                    :for old = (find-symbol* new user)
    211                    :when (and old (not (member old shadowing)))
    212                    :do (unintern old user)))
    213                (loop :for x :in newly-exported-symbols :do
    214                  (export (intern* x package)))))
    215            (ensure-package (name &key nicknames use unintern
    216                                  shadow export redefined-functions)
    217              (let* ((p (ensure-exists name nicknames use)))
    218                (ensure-unintern p unintern)
    219                (ensure-shadow p shadow)
    220                (ensure-export p export)
    221                (ensure-fmakunbound p redefined-functions)
    222                p)))
    223         (macrolet
    224             ((pkgdcl (name &key nicknames use export
    225                            redefined-functions unintern shadow)
    226                  `(ensure-package
    227                    ',name :nicknames ',nicknames :use ',use :export ',export
    228                    :shadow ',shadow
    229                    :unintern ',unintern
    230                    :redefined-functions ',redefined-functions)))
    231           (pkgdcl
    232            :asdf
    233            :use (:common-lisp)
    234            :redefined-functions
    235            (#:perform #:explain #:output-files #:operation-done-p
    236             #:perform-with-restarts #:component-relative-pathname
    237             #:system-source-file #:operate #:find-component #:find-system
    238             #:apply-output-translations #:translate-pathname* #:resolve-location
    239             #:system-relative-pathname
    240             #:inherit-source-registry #:process-source-registry
    241             #:process-source-registry-directive
    242             #:compile-file* #:source-file-type)
    243            :unintern
    244            (#:*asdf-revision* #:around #:asdf-method-combination
    245             #:split #:make-collector #:do-dep #:do-one-dep
    246             #:resolve-relative-location-component #:resolve-absolute-location-component
    247             #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    248            :export
    249            (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
    250             #:system-definition-pathname #:with-system-definitions
    251             #:search-for-system-definition #:find-component #:component-find-path
    252             #:compile-system #:load-system #:load-systems
    253             #:require-system #:test-system #:clear-system
    254             #:operation #:compile-op #:load-op #:load-source-op #:test-op
    255             #:feature #:version #:version-satisfies
    256             #:upgrade-asdf
    257             #:implementation-identifier #:implementation-type #:hostname
    258             #:input-files #:output-files #:output-file #:perform
    259             #:operation-done-p #:explain
    261             #:component #:source-file
    262             #:c-source-file #:cl-source-file #:java-source-file
    263    #:cl-source-file.lsp
    264             #:static-file
    265             #:doc-file
    266             #:html-file
    267             #:text-file
    268             #:source-file-type
    269             #:module                     ; components
    270             #:system
    271             #:unix-dso
    273             #:module-components          ; component accessors
    274             #:module-components-by-name
    275             #:component-pathname
    276             #:component-relative-pathname
    277             #:component-name
    278             #:component-version
    279             #:component-parent
    280             #:component-property
    281             #:component-system
    282             #:component-depends-on
    283             #:component-encoding
    284             #:component-external-format
    286             #:system-description
    287             #:system-long-description
    288             #:system-author
    289             #:system-maintainer
    290             #:system-license
    291             #:system-licence
    292             #:system-source-file
    293             #:system-source-directory
    294             #:system-relative-pathname
    295             #:map-systems
    297             #:operation-description
    298             #:operation-on-warnings
    299             #:operation-on-failure
    300             #:component-visited-p
    302             #:*system-definition-search-functions*   ; variables
    303             #:*central-registry*
    304             #:*compile-file-warnings-behaviour*
    305             #:*compile-file-failure-behaviour*
    306             #:*resolve-symlinks*
    307             #:*load-system-operation*
    308             #:*asdf-verbose*
    309             #:*verbose-out*
    311             #:asdf-version
    313             #:operation-error #:compile-failed #:compile-warned #:compile-error
    314             #:error-name
    315             #:error-pathname
    316             #:load-system-definition-error
    317             #:error-component #:error-operation
    318             #:system-definition-error
    319             #:missing-component
    320             #:missing-component-of-version
    321             #:missing-dependency
    322             #:missing-dependency-of-version
    323             #:circular-dependency        ; errors
    324             #:duplicate-names
    326             #:try-recompiling
    327             #:retry
    328             #:accept                     ; restarts
    329             #:coerce-entry-to-directory
    330             #:remove-entry-from-registry
    332             #:*encoding-detection-hook*
    333             #:*encoding-external-format-hook*
    334             #:*default-encoding*
    335             #:*utf-8-external-format*
    337             #:clear-configuration
    338             #:*output-translations-parameter*
    339             #:initialize-output-translations
    340             #:disable-output-translations
    341             #:clear-output-translations
    342             #:ensure-output-translations
    343             #:apply-output-translations
    344             #:compile-file*
    345             #:compile-file-pathname*
    346             #:enable-asdf-binary-locations-compatibility
    347             #:*default-source-registries*
    348             #:*source-registry-parameter*
    349             #:initialize-source-registry
    350             #:compute-source-registry
    351             #:clear-source-registry
    352             #:ensure-source-registry
    353             #:process-source-registry
    354             #:system-registered-p #:registered-systems #:loaded-systems
    355             #:resolve-location
    356             #:asdf-message
    357             #:user-output-translations-pathname
    358             #:system-output-translations-pathname
    359             #:user-output-translations-directory-pathname
    360             #:system-output-translations-directory-pathname
    361             #:user-source-registry
    362             #:system-source-registry
    363             #:user-source-registry-directory
    364             #:system-source-registry-directory
    366             ;; Utilities: please use asdf-utils instead
    367             #|
    368             ;; #:aif #:it
    369             ;; #:appendf #:orf
    370             #:length=n-p
    371             #:remove-keys #:remove-keyword
    372             #:first-char #:last-char #:string-suffix-p
    373             #:coerce-name
    374             #:directory-pathname-p #:ensure-directory-pathname
    375             #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
    376             #:getenv #:getenv-pathname #:getenv-pathnames
    377             #:getenv-absolute-directory #:getenv-absolute-directories
    378             #:probe-file*
    379             #:find-symbol* #:strcat
    380             #:make-pathname-component-logical #:make-pathname-logical
    381             #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
    382             #:pathname-directory-pathname #:pathname-parent-directory-pathname
    383             #:read-file-forms
    384             #:resolve-symlinks #:truenamize
    385             #:split-string
    386             #:component-name-to-pathname-components
    387             #:split-name-type
    388             #:subdirectories #:directory-files
    389             #:while-collecting
    390             #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
    391             #:*wild-path* #:wilden
    392             #:directorize-pathname-host-device|#
    393             )))
    394         #+genera (import 'scl:boolean :asdf)
    395         (setf *asdf-version* asdf-version
    396               *upgraded-p* (if existing-version
    397                                (cons existing-version *upgraded-p*)
    398                                *upgraded-p*))))))
    400 ;;;; -------------------------------------------------------------------------
    401 ;;;; User-visible parameters
    402 ;;;;
    403 (defvar *resolve-symlinks* t
    404   "Determine whether or not ASDF resolves symlinks when defining systems.
    406 Defaults to T.")
    408 (defvar *compile-file-warnings-behaviour*
    409   (or #+clisp :ignore :warn)
    410   "How should ASDF react if it encounters a warning when compiling a file?
    411 Valid values are :error, :warn, and :ignore.")
    413 (defvar *compile-file-failure-behaviour*
    414   (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
    415   "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
    416 when compiling a file?  Valid values are :error, :warn, and :ignore.
    417 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
    419 (defvar *verbose-out* nil)
    421 (defparameter +asdf-methods+
    422   '(perform-with-restarts perform explain output-files operation-done-p))
    424 (defvar *load-system-operation* 'load-op
    425   "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
    426 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
    427 or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
    429 (defvar *compile-op-compile-file-function* 'compile-file*
    430   "Function used to compile lisp files.")
    434 #+allegro
    435 (eval-when (:compile-toplevel :execute)
    436765  (defparameter *acl-warn-save*
    437                 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    438                   excl:*warn-on-nested-reader-conditionals*))
     766    (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     767      excl:*warn-on-nested-reader-conditionals*))
    439768  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    440     (setf excl:*warn-on-nested-reader-conditionals* nil)))
    442 ;;;; -------------------------------------------------------------------------
    443 ;;;; Resolve forward references
    445 (declaim (ftype (function (t) t)
    446                 format-arguments format-control
    447                 error-name error-pathname error-condition
    448                 duplicate-names-name
    449                 error-component error-operation
    450                 module-components module-components-by-name
    451                 circular-dependency-components
    452                 condition-arguments condition-form
    453                 condition-format condition-location
    454                 coerce-name)
    455          (ftype (function (&optional t) (values)) initialize-source-registry)
    456          #-(or cormanlisp gcl-pre2.7)
    457          (ftype (function (t t) t) (setf module-components-by-name)))
    459 ;;;; -------------------------------------------------------------------------
    460 ;;;; Compatibility various implementations
     769    (setf excl:*warn-on-nested-reader-conditionals* nil))
     770  (setf *print-readably* nil))
    467778    (setf p (pathname p))
    468779    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     782(eval-when (:load-toplevel :compile-toplevel :execute)
     783  (setf *load-verbose* nil)
     784  (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
     785  (unless (use-ecl-byte-compiler-p) (require :cmp)))
     787#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     788(eval-when (:load-toplevel :compile-toplevel :execute)
     789  (unless (member :ansi-cl *features*)
     790    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
     791  (setf compiler::*compiler-default-type* (pathname "")
     792        compiler::*lsp-ext* ""))
     795(eval-when (:compile-toplevel :load-toplevel :execute)
     796  (shadow 'type-of :asdf/common-lisp)
     797  (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
     800(eval-when (:compile-toplevel :load-toplevel :execute)
     801  (export 'type-of :asdf/common-lisp)
     802  (export 'system:*load-pathname* :asdf/common-lisp))
     805(progn ;; Doesn't support either logical-pathnames or output-translations.
     806  (defvar *gcl2.6* t)
     807  (deftype logical-pathname () nil)
     808  (defun type-of (x) (class-name (class-of x)))
     809  (defun wild-pathname-p (path) (declare (ignore path)) nil)
     810  (defun translate-logical-pathname (x) x)
     811  (defvar *compile-file-pathname* nil)
     812  (defun pathname-match-p (in-pathname wild-pathname)
     813    (declare (ignore in-wildname wild-wildname)) nil)
     814  (defun translate-pathname (source from-wildname to-wildname &key)
     815    (declare (ignore from-wildname to-wildname)) source)
     816  (defun %print-unreadable-object (object stream type identity thunk)
     817    (format stream "#<~@[~S ~]" (when type (type-of object)))
     818    (funcall thunk)
     819    (format stream "~@[ ~X~]>" (when identity (system:address object))))
     820  (defmacro with-standard-io-syntax (&body body)
     821    `(progn ,@body))
     822  (defmacro with-compilation-unit (options &body body)
     823    (declare (ignore options)) `(progn ,@body))
     824  (defmacro print-unreadable-object ((object stream &key type identity) &body body)
     825    `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
     826  (defun ensure-directories-exist (path)
     827    (lisp:system (format nil "mkdir -p ~S"
     828                         (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
     831(unless (fboundp 'ensure-directories-exist)
     832  (defun ensure-directories-exist (path)
     833    (fs:create-directories-recursively (pathname path))))
    470835#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
    477842          ;; MCL by default provides the directory from which MCL was started.
    478843          ;; See
    479           (defun current-user-homedir-pathname ()
     844          (defun user-homedir-pathname ()
    480845            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
    481846          (defun probe-posix (posix-namestring)
    487852                  (ccl::%path-from-fsref fsref is-dir))))))"))
     855(eval-when (:load-toplevel :compile-toplevel :execute)
     856  (require :cmp)
     857  (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
     860;;;; compatfmt: avoid fancy format directives when unsupported
     862(defmacro loop* (&rest rest)
     863  #-genera `(loop ,@rest)
     864  #+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
     866(eval-when (:load-toplevel :compile-toplevel :execute)
     867  (defun strcat (&rest strings)
     868    (apply 'concatenate 'string strings)))
     870(defmacro compatfmt (format)
     871  #+(or gcl genera)
     872  (loop* :for (unsupported . replacement)
     873         :in (append
     874              '(("~3i~_" . ""))
     875              #+(or genera gcl2.6) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
     876      (loop :for found = (search unsupported format) :while found :do
     877        (setf format (strcat (subseq format 0 found) replacement
     878                             (subseq format (+ found (length unsupported)))))))
     879    format)
    489880;;;; -------------------------------------------------------------------------
    490 ;;;; General Purpose Utilities
     881;;;; General Purpose Utilities for ASDF
     883(asdf/package:define-package :asdf/utility
     884  (:recycle :asdf/utility :asdf)
     885  (:use :asdf/common-lisp :asdf/package)
     886  ;; import and reexport a few things defined in :asdf/common-lisp
     887  (:import-from :asdf/common-lisp #:strcat #:compatfmt #:loop*
     888   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     889  (:export #:nil #:strcat #:compatfmt #:loop*
     890   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     891  (:export
     892   ;; magic helper to define debugging functions:
     893   #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
     894   #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions
     895   #:if-let ;; basic flow control
     896   #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
     897   #:emptyp ;; sequences
     898   #:first-char #:last-char #:split-string ;; strings
     899   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
     900   #:find-class* ;; CLOS
     901   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
     902   #:earlier-stamp #:stamps-earliest #:earliest-stamp
     903   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
     904   #:list-to-hash-set ;; hash-table
     905   #:ensure-function #:access-at #:access-at-count ;; functions
     906   #:call-function #:call-functions #:register-hook-function
     907   #:match-condition-p #:match-any-condition-p ;; conditions
     908   #:call-with-muffled-conditions #:with-muffled-conditions
     909   #:load-string #:load-stream
     910   #:parse-version #:unparse-version #:version-compatible-p)) ;; version
     911(in-package :asdf/utility)
     913;;;; Defining functions in a way compatible with hot-upgrade:
     914;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
     915;; thus replacing the function without warning or error
     916;; even if the signature and/or generic-ness of the function has changed.
     917;; For a generic function, this invalidates any previous DEFMETHOD.
     918(eval-when (:load-toplevel :compile-toplevel :execute)
     919  (defun undefine-function (function-spec)
     920    (cond
     921      ((symbolp function-spec)
     922       #+clisp
     923       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
     924         (when (typep f 'clos:standard-generic-function)
     925           (loop :for m :in (clos:generic-function-methods f)
     926                 :do (remove-method f m))))
     927       (fmakunbound function-spec))
     928      ((and (consp function-spec) (eq (car function-spec) 'setf)
     929            (consp (cdr function-spec)) (null (cddr function-spec)))
     930       #-gcl2.6 (fmakunbound function-spec))
     931      (t (error "bad function spec ~S" function-spec))))
     932  (defun undefine-functions (function-spec-list)
     933    (map () 'undefine-function function-spec-list)))
    493936    ((defdef (def* def)
    494937       `(defmacro ,def* (name formals &rest rest)
    495           `(progn
    496              #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
    497              #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    498              ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
    499                 `(declaim (notinline ,name)))
    500              (,',def ,name ,formals ,@rest)))))
     938          (destructuring-bind (name &key (supersede t))
     939              (if (or (atom name) (eq (car name) 'setf))
     940                  (list name :supersede nil)
     941                  name)
     942            (declare (ignorable supersede))
     943            `(progn
     944             ;; undefining the previous function is the portable way
     945             ;; of overriding any incompatible previous gf, except on CLISP.
     946             ;; We usually try to do it only for the functions that need it,
     947             ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
     948             ;; (which causes issues in clisp)
     949               ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
     950                   `((undefine-function ',name)))
     951               #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
     952               ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     953                   `((declaim (notinline ,name))))
     954               (,',def ,name ,formals ,@rest))))))
    501955  (defdef defgeneric* defgeneric)
    502956  (defdef defun* defun))
     959;;; Magic debugging help. See contrib/debug.lisp
     960(defvar *asdf-debug-utility*
     961  '(ignore-errors (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
     962  "form that evaluates to the pathname to your favorite debugging utilities")
     964(defmacro asdf-debug (&rest keys)
     965  `(eval-when (:compile-toplevel :load-toplevel :execute)
     966     (load-asdf-debug-utility ,@keys)))
     968(defun* load-asdf-debug-utility (&key package utility-file)
     969  (let* ((*package* (if package (find-package package) *package*))
     970         (keyword (read-from-string
     971                   (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
     972    (unless (member keyword *features*)
     973      (let* ((utility-file (or utility-file *asdf-debug-utility*))
     974             (file (ignore-errors (probe-file (eval utility-file)))))
     975        (if file (load file)
     976            (error "Failed to locate debug utility file: ~S" utility-file))))))
     979;;; Flow control
     980(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
     981  ;; bindings can be (var form) or ((var1 form1) ...)
     982  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
     983                           (list bindings)
     984                           bindings))
     985         (variables (mapcar #'car binding-list)))
     986    `(let ,binding-list
     987       (if (and ,@variables)
     988           ,then-form
     989           ,else-form))))
     991;;; List manipulation
    504992(defmacro while-collecting ((&rest collectors) &body body)
    505993  "COLLECTORS should be a list of names for collections.  A collector
    5201008         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    522 (defmacro aif (test then &optional else)
    523   "Anaphoric version of IF, On Lisp style"
    524   `(let ((it ,test)) (if it ,then ,else)))
    526 (defun* pathname-directory-pathname (pathname)
    527   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    528 and NIL NAME, TYPE and VERSION components"
    529   (when pathname
    530     (make-pathname :name nil :type nil :version nil :defaults pathname)))
     1010(define-modify-macro appendf (&rest args)
     1011  append "Append onto list") ;; only to be used on short lists.
     1013(defun* length=n-p (x n) ;is it that (= (length x) n) ?
     1014  (check-type n (integer 0 *))
     1015  (loop
     1016    :for l = x :then (cdr l)
     1017    :for i :downfrom n :do
     1018    (cond
     1019      ((zerop i) (return (null l)))
     1020      ((not (consp l)) (return nil)))))
     1022;;; remove a key from a plist, i.e. for keyword argument cleanup
     1023(defun* remove-plist-key (key plist)
     1024  "Remove a single key from a plist"
     1025  (loop* :for (k v) :on plist :by #'cddr
     1026    :unless (eq k key)
     1027    :append (list k v)))
     1029(defun* remove-plist-keys (keys plist)
     1030  "Remove a list of keys from a plist"
     1031  (loop* :for (k v) :on plist :by #'cddr
     1032    :unless (member k keys)
     1033    :append (list k v)))
     1036;;; Sequences
     1037(defun* emptyp (x)
     1038  "Predicate that is true for an empty sequence"
     1039  (or (null x) (and (vectorp x) (zerop (length x)))))
     1042;;; Strings
     1044(defun* first-char (s)
     1045  (and (stringp s) (plusp (length s)) (char s 0)))
     1047(defun* last-char (s)
     1048  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     1050(defun* split-string (string &key max (separator '(#\Space #\Tab)))
     1051  "Split STRING into a list of components separated by
     1052any of the characters in the sequence SEPARATOR.
     1053If MAX is specified, then no more than max(1,MAX) components will be returned,
     1054starting the separation from the end, e.g. when called with arguments
     1055 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
     1056  (block ()
     1057    (let ((list nil) (words 0) (end (length string)))
     1058      (flet ((separatorp (char) (find char separator))
     1059             (done () (return (cons (subseq string 0 end) list))))
     1060        (loop
     1061          :for start = (if (and max (>= words (1- max)))
     1062                           (done)
     1063                           (position-if #'separatorp string :end end :from-end t)) :do
     1064          (when (null start)
     1065            (done))
     1066          (push (subseq string (1+ start) end) list)
     1067          (incf words)
     1068          (setf end start))))))
     1070(defun* string-prefix-p (prefix string)
     1071  "Does STRING begin with PREFIX?"
     1072  (let* ((x (string prefix))
     1073         (y (string string))
     1074         (lx (length x))
     1075         (ly (length y)))
     1076    (and (<= lx ly) (string= x y :end2 lx))))
     1078(defun* string-suffix-p (string suffix)
     1079  "Does STRING end with SUFFIX?"
     1080  (let* ((x (string string))
     1081         (y (string suffix))
     1082         (lx (length x))
     1083         (ly (length y)))
     1084    (and (<= ly lx) (string= x y :start1 (- lx ly)))))
     1086(defun* string-enclosed-p (prefix string suffix)
     1087  "Does STRING begin with PREFIX and end with SUFFIX?"
     1088  (and (string-prefix-p prefix string)
     1089       (string-suffix-p string suffix)))
     1092;;; CLOS
     1093(defun* find-class* (x &optional (errorp t) environment)
     1094  (etypecase x
     1095    ((or standard-class built-in-class) x)
     1096    #+gcl2.6 (keyword nil)
     1097    (symbol (find-class x errorp environment))))
     1100;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
     1101(deftype stamp () '(or real boolean))
     1102(defun* stamp< (x y)
     1103  (etypecase x
     1104    (null (and y t))
     1105    ((eql t) nil)
     1106    (real (etypecase y
     1107            (null nil)
     1108            ((eql t) t)
     1109            (real (< x y))))))
     1110(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
     1111(defun* stamp*< (&rest list) (stamps< list))
     1112(defun* stamp<= (x y) (not (stamp< y x)))
     1113(defun* earlier-stamp (x y) (if (stamp< x y) x y))
     1114(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
     1115(defun* earliest-stamp (&rest list) (stamps-earliest list))
     1116(defun* later-stamp (x y) (if (stamp< x y) y x))
     1117(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
     1118(defun* latest-stamp (&rest list) (stamps-latest list))
     1119(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)
     1122;;; Hash-tables
     1123(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
     1124  (dolist (x list h) (setf (gethash x h) t)))
     1127;;; Function designators
     1128(defun* ensure-function (fun &key (package :cl))
     1129  "Coerce the object FUN into a function.
     1131If FUN is a FUNCTION, return it.
     1132If the FUN is a non-sequence literal constant, return constantly that,
     1133i.e. for a boolean keyword character number or pathname.
     1134Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
     1135If FUN is a CONS, return the function that applies its CAR
     1136to the appended list of the rest of its CDR and the arguments.
     1137If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
     1138and EVAL that in a (FUNCTION ...) context."
     1139  (etypecase fun
     1140    (function fun)
     1141    ((or boolean keyword character number pathname) (constantly fun))
     1142    ((or function symbol) fun)
     1143    (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
     1144    (string (eval `(function ,(with-standard-io-syntax
     1145                                (let ((*package* (find-package package)))
     1146                                  (read-from-string fun))))))))
     1148(defun* access-at (object at)
     1149  "Given an OBJECT and an AT specifier, list of successive accessors,
     1150call each accessor on the result of the previous calls.
     1151An accessor may be an integer, meaning a call to ELT,
     1152a keyword, meaning a call to GETF,
     1153NIL, meaning identity,
     1154a function or other symbol, meaning itself,
     1155or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
     1156As a degenerate case, the AT specifier may be an atom of a single such accessor
     1157instead of a list."
     1158  (flet ((access (object accessor)
     1159           (etypecase accessor
     1160             (function (funcall accessor object))
     1161             (integer (elt object accessor))
     1162             (keyword (getf object accessor))
     1163             (null object)
     1164             (symbol (funcall accessor object))
     1165             (cons (funcall (ensure-function accessor) object)))))
     1166    (if (listp at)
     1167        (dolist (accessor at object)
     1168          (setf object (access object accessor)))
     1169        (access object at))))
     1171(defun* access-at-count (at)
     1172  "From an AT specification, extract a COUNT of maximum number
     1173   of sub-objects to read as per ACCESS-AT"
     1174  (cond
     1175    ((integerp at)
     1176     (1+ at))
     1177    ((and (consp at) (integerp (first at)))
     1178     (1+ (first at)))))
     1180(defun* call-function (function-spec &rest arguments)
     1181  (apply (ensure-function function-spec) arguments))
     1183(defun* call-functions (function-specs)
     1184  (map () 'call-function function-specs))
     1186(defun* register-hook-function (variable hook &optional (call-now-p t))
     1187  (pushnew hook (symbol-value variable))
     1188  (when call-now-p (call-function hook)))
     1191;;; Version handling
     1192(defun* unparse-version (version-list)
     1193  (format nil "~{~D~^.~}" version-list))
     1195(defun* parse-version (version-string &optional on-error)
     1196  "Parse a VERSION-STRING as a series of natural integers separated by dots.
     1197Return a (non-null) list of integers if the string is valid;
     1198otherwise return NIL.
     1200When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
     1201with format arguments explaining why the version is invalid.
     1202ON-ERROR is also called if the version is not canonical
     1203in that it doesn't print back to itself, but the list is returned anyway."
     1204  (block nil
     1205   (unless (stringp version-string)
     1206     (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
     1207     (return))
     1208   (unless (loop :for prev = nil :then c :for c :across version-string
     1209                 :always (or (digit-char-p c)
     1210                             (and (eql c #\.) prev (not (eql prev #\.))))
     1211                 :finally (return (and c (digit-char-p c))))
     1212     (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
     1213                    'parse-version version-string)
     1214     (return))
     1215   (let* ((version-list
     1216            (mapcar #'parse-integer (split-string version-string :separator ".")))
     1217          (normalized-version (unparse-version version-list)))
     1218     (unless (equal version-string normalized-version)
     1219       (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
     1220     version-list)))
     1223(defun* version-compatible-p (provided-version required-version)
     1224  "Is the provided version a compatible substitution for the required-version?
     1225If major versions differ, it's not compatible.
     1226If they are equal, then any later version is compatible,
     1227with later being determined by a lexicographical comparison of minor numbers."
     1228  (let ((x (parse-version provided-version 'warn))
     1229        (y (parse-version required-version 'warn)))
     1230    (labels ((bigger (x y)
     1231               (cond ((not y) t)
     1232                     ((not x) nil)
     1233                     ((> (car x) (car y)) t)
     1234                     ((= (car x) (car y))
     1235                      (bigger (cdr x) (cdr y))))))
     1236      (and x y (= (car x) (car y))
     1237           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     1240;;; Condition control
     1242(defvar *uninteresting-conditions* nil
     1243  "Uninteresting conditions, as per MATCH-CONDITION-P")
     1245(defparameter +simple-condition-format-control-slot+
     1246  #+abcl 'system::format-control
     1247  #+allegro 'excl::format-control
     1248  #+clisp 'system::$format-control
     1249  #+clozure 'ccl::format-control
     1250  #+ecl 'si::format-control
     1251  #+(or cmu scl) 'conditions::format-control
     1252  #+(or gcl lispworks) 'conditions::format-string
     1253  #+sbcl 'sb-kernel:format-control
     1254  #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
     1255  "Name of the slot for FORMAT-CONTROL in simple-condition")
     1257(defun* match-condition-p (x condition)
     1258  "Compare received CONDITION to some pattern X:
     1259a symbol naming a condition class,
     1260a simple vector of length 2, arguments to find-symbol* with result as above,
     1261or a string describing the format-control of a simple-condition."
     1262  (etypecase x
     1263    (symbol (typep condition x))
     1264    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
     1265    (function (funcall x condition))
     1266    (string (and (typep condition 'simple-condition)
     1267                 ;; On SBCL, it's always set and the check triggers a warning
     1268                 #+(or allegro clozure cmu lispworks scl)
     1269     (slot-boundp condition +simple-condition-format-control-slot+)
     1270                 (ignore-errors (equal (simple-condition-format-control condition) x))))))
     1272(defun* match-any-condition-p (condition conditions)
     1273  "match CONDITION against any of the patterns of CONDITIONS supplied"
     1274  (loop :for x :in conditions :thereis (match-condition-p x condition)))
     1276(defun* call-with-muffled-conditions (thunk conditions)
     1277  (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
     1278                                    (muffle-warning c)))))
     1279    (funcall thunk)))
     1281(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
     1282  `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
     1284;;;; -------------------------------------------------------------------------
     1285;;;; Portability layer around Common Lisp pathnames
     1287(asdf/package:define-package :asdf/pathname
     1288  (:recycle :asdf/pathname :asdf)
     1289  (:use :asdf/common-lisp :asdf/package :asdf/utility)
     1290  (:export
     1291   #:*resolve-symlinks*
     1292   ;; Making and merging pathnames, portably
     1293   #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
     1294   #:pathname-equal
     1295   #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type*
     1296   #:make-pathname-component-logical #:make-pathname-logical
     1297   #:merge-pathnames*
     1298   ;; Directories
     1299   #:pathname-directory-pathname #:pathname-parent-directory-pathname
     1300   #:directory-pathname-p #:ensure-directory-pathname #:file-pathname-p
     1301   ;; Absolute vs relative pathnames
     1302   #:ensure-pathname-absolute
     1303   #:relativize-directory-component #:relativize-pathname-directory
     1304   ;; Parsing filenames and lists thereof
     1305   #:component-name-to-pathname-components
     1306   #:split-name-type #:parse-unix-namestring #:unix-namestring
     1307   #:split-unix-namestring-directory-components
     1308   #:subpathname #:subpathname* #:subpathp
     1309   ;; Resolving symlinks somewhat
     1310   #:truenamize #:resolve-symlinks #:resolve-symlinks*
     1311   ;; Wildcard pathnames
     1312   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
     1313   ;; Pathname host and its root
     1314   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p
     1315   #:pathname-root #:directory-separator-for-host
     1316   #:directorize-pathname-host-device
     1317   ;; defaults
     1318   #:nil-pathname #:with-pathname-defaults
     1319   ;; probe filesystem
     1320   #:truename* #:probe-file* #:safe-file-write-date
     1321   #:subdirectories #:directory-files #:directory*
     1322   #:filter-logical-directory-results #:collect-sub*directories
     1323   ;; Simple filesystem operations
     1324   #:ensure-all-directories-exist
     1325   #:rename-file-overwriting-target
     1326   #:delete-file-if-exists
     1327   ;; Translate a pathname
     1328   #:translate-pathname*
     1329   ;; temporary
     1330   #:add-pathname-suffix #:tmpize-pathname
     1331   #:call-with-staging-pathname #:with-staging-pathname
     1332   ;; physical pathnames
     1333   #:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname #:root-pathname
     1334   ;; Windows shortcut support
     1335   #:read-null-terminated-string #:read-little-endian
     1336   #:parse-file-location-info #:parse-windows-shortcut
     1337   ;; Checking constraints
     1338   #:ensure-pathname
     1339   #:absolutize-pathnames
     1340   ;; Output translations
     1341   #:*output-translation-function*))
     1343(in-package :asdf/pathname)
     1345;;; User-visible parameters
     1346(defvar *resolve-symlinks* t
     1347  "Determine whether or not ASDF resolves symlinks when defining systems.
     1349Defaults to T.")
     1352;;; Normalizing pathnames across implementations
    5321354(defun* normalize-pathname-directory-component (directory)
    5331355  "Given a pathname directory component, return an equivalent form that is a list"
     1356  #+gcl2.6 (setf directory (substitute :back :parent directory))
    5341357  (cond
    5351358    #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    536     ((stringp directory) `(:absolute ,directory) directory)
    537     #+gcl
    538     ((and (consp directory) (stringp (first directory)))
    539      `(:absolute ,@directory))
     1359    ((stringp directory) `(:absolute ,directory))
     1360    #+gcl2.6
     1361    ((and (consp directory) (eq :root (first directory)))
     1362     `(:absolute ,@(rest directory)))
    5401363    ((or (null directory)
    5411364         (and (consp directory) (member (first directory) '(:absolute :relative))))
    5421365     directory)
     1366    #+gcl2.6
     1367    ((consp directory)
     1368     `(:relative ,@directory))
    5431369    (t
    5441370     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
     1372(defun* denormalize-pathname-directory-component (directory-component)
     1373  #-gcl2.6 directory-component
     1374  #+gcl2.6
     1375  (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
     1376                          directory-component)))
     1377    (cond
     1378      ((and (consp d) (eq :relative (first d))) (rest d))
     1379      ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
     1380      (t d))))
    5461382(defun* merge-pathname-directory-components (specified defaults)
    5671403              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
     1405;; Giving :unspecific as :type argument to make-pathname is not portable.
     1406;; See CLHS make-pathname and
     1407;; This will be :unspecific if supported, or NIL if not.
     1408(defparameter *unspecific-pathname-type*
     1409  #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
     1410  #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
     1412(defun* make-pathname* (&rest keys &key (directory nil directoryp)
     1413                              host (device () devicep) name type version defaults
     1414                              #+scl &allow-other-keys)
     1415  "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
     1416   tries hard to make a pathname that will actually behave as documented,
     1417   despite the peculiarities of each implementation"
     1418  (declare (ignorable host device devicep name type version defaults))
     1419  (apply 'make-pathname
     1420         (append
     1421          #+allegro (when (and devicep (null device)) `(:device :unspecific))
     1422          (when directoryp
     1423            `(:directory ,(denormalize-pathname-directory-component directory)))
     1424          keys)))
    5691426(defun* make-pathname-component-logical (x)
    5701427  "Make a pathname component suitable for use in a logical-pathname"
    5781435  "Take a PATHNAME's directory, name, type and version components,
    5791436and make a new pathname with corresponding components and specified logical HOST"
    580   (make-pathname
     1437  (make-pathname*
    5811438   :host host
    5821439   :directory (make-pathname-component-logical (pathname-directory pathname))
    5851442   :version (make-pathname-component-logical (pathname-version pathname))))
     1445;;; Some pathname predicates
     1447(defun* pathname-equal (p1 p2)
     1448  (when (stringp p1) (setf p1 (pathname p1)))
     1449  (when (stringp p2) (setf p2 (pathname p2)))
     1450  (flet ((normalize-component (x)
     1451           (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
     1452             x)))
     1453    (macrolet ((=? (&rest accessors)
     1454                 (flet ((frob (x)
     1455                          (reduce 'list (cons 'normalize-component accessors)
     1456                                  :initial-value x :from-end t)))
     1457                   `(equal ,(frob 'p1) ,(frob 'p2)))))
     1458      (or (and (null p1) (null p2))
     1459          (and (pathnamep p1) (pathnamep p2)
     1460               (and (=? pathname-host)
     1461                    (=? pathname-device)
     1462                    (=? normalize-pathname-directory-component pathname-directory)
     1463                    (=? pathname-name)
     1464                    (=? pathname-type)
     1465                    (=? pathname-version)))))))
     1467(defun* logical-pathname-p (x)
     1468  (typep x 'logical-pathname))
     1470(defun* physical-pathname-p (x)
     1471  (and (pathnamep x) (not (logical-pathname-p x))))
     1473(defun* absolute-pathname-p (pathspec)
     1474  "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1475possessing an :ABSOLUTE directory component, return the (parsed) pathname.
     1476Otherwise return NIL"
     1477  (and pathspec
     1478       (typep pathspec '(or null pathname string))
     1479       (let ((pathname (pathname pathspec)))
     1480         (and (eq :absolute (car (normalize-pathname-directory-component
     1481                                  (pathname-directory pathname))))
     1482              pathname))))
     1484(defun* relative-pathname-p (pathspec)
     1485  "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1486possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
     1487Otherwise return NIL"
     1488  (and pathspec
     1489       (typep pathspec '(or null pathname string))
     1490       (let* ((pathname (pathname pathspec))
     1491              (directory (normalize-pathname-directory-component
     1492                          (pathname-directory pathname))))
     1493         (when (or (null directory) (eq :relative (car directory)))
     1494           pathname))))
     1496(defun* hidden-pathname-p (pathname)
     1497  "Return a boolean that is true if the pathname is hidden as per Unix style,
     1498i.e. its name starts with a dot."
     1499  (and pathname (equal (first-char (pathname-name pathname)) #\.)))
     1502;;;; merging pathnames
    5871503(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    5881504  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
    5911507if the SPECIFIED pathname does have an absolute directory,
    5921508then the HOST and DEVICE both come from the SPECIFIED.
    593 Also, if either argument is NIL, then the other argument is returned unmodified."
     1509This is what users want on a modern Unix or Windows operating system,
     1510unlike the MERGE-PATHNAME behavior.
     1511Also, if either argument is NIL, then the other argument is returned unmodified;
     1512this is unlike MERGE-PATHNAME which always merges with a pathname,
     1513by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
    5941514  (when (null specified) (return-from merge-pathnames* defaults))
    5951515  (when (null defaults) (return-from merge-pathnames* specified))
    6041524         (version (or (pathname-version specified) (pathname-version defaults))))
    6051525    (labels ((unspecific-handler (p)
    606                (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
     1526               (if (logical-pathname-p p) #'make-pathname-component-logical #'identity)))
    6071527      (multiple-value-bind (host device directory unspecific-handler)
    6081528          (ecase (first directory)
    6171537                     (merge-pathname-directory-components directory (pathname-directory defaults))
    6181538                     (unspecific-handler defaults))))
    619         (make-pathname :host host :device device :directory directory
    620                        :name (funcall unspecific-handler name)
    621                        :type (funcall unspecific-handler type)
    622                        :version (funcall unspecific-handler version))))))
     1539        (make-pathname* :host host :device device :directory directory
     1540                        :name (funcall unspecific-handler name)
     1541                        :type (funcall unspecific-handler type)
     1542                        :version (funcall unspecific-handler version))))))
     1544;;; Directories
     1545(defun* pathname-directory-pathname (pathname)
     1546  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     1547and NIL NAME, TYPE and VERSION components"
     1548  (when pathname
     1549    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    6241551(defun* pathname-parent-directory-pathname (pathname)
    6261553and NIL NAME, TYPE and VERSION components"
    6271554  (when pathname
    628     (make-pathname :name nil :type nil :version nil
    629                    :directory (merge-pathname-directory-components
    630                                '(:relative :back) (pathname-directory pathname))
    631                    :defaults pathname)))
    633 (define-modify-macro appendf (&rest args)
    634   append "Append onto list") ;; only to be used on short lists.
    636 (define-modify-macro orf (&rest args)
    637   or "or a flag")
    639 (defun* first-char (s)
    640   (and (stringp s) (plusp (length s)) (char s 0)))
    642 (defun* last-char (s)
    643   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    646 (defun* asdf-message (format-string &rest format-args)
    647   (declare (dynamic-extent format-args))
    648   (apply 'format *verbose-out* format-string format-args))
    650 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
    651   "Split STRING into a list of components separated by
    652 any of the characters in the sequence SEPARATOR.
    653 If MAX is specified, then no more than max(1,MAX) components will be returned,
    654 starting the separation from the end, e.g. when called with arguments
    655  \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    656   (catch nil
    657     (let ((list nil) (words 0) (end (length string)))
    658       (flet ((separatorp (char) (find char separator))
    659              (done () (throw nil (cons (subseq string 0 end) list))))
    660         (loop
    661           :for start = (if (and max (>= words (1- max)))
    662                            (done)
    663                            (position-if #'separatorp string :end end :from-end t)) :do
    664           (when (null start)
    665             (done))
    666           (push (subseq string (1+ start) end) list)
    667           (incf words)
    668           (setf end start))))))
    670 (defun* split-name-type (filename)
    671   (let ((unspecific
    672          ;; Giving :unspecific as argument to make-pathname is not portable.
    673          ;; See CLHS make-pathname and
    674          ;; We only use it on implementations that support it,
    675          #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
    676          #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
    677     (destructuring-bind (name &optional (type unspecific))
    678         (split-string filename :max 2 :separator ".")
    679       (if (equal name "")
    680           (values filename unspecific)
    681           (values name type)))))
    683 (defun* component-name-to-pathname-components (s &key force-directory force-relative)
    684   "Splits the path string S, returning three values:
    685 A flag that is either :absolute or :relative, indicating
    686    how the rest of the values are to be interpreted.
    687 A directory path --- a list of strings, suitable for
    688    use with MAKE-PATHNAME when prepended with the flag
    689    value.
    690 A filename with type extension, possibly NIL in the
    691    case of a directory pathname.
    692 FORCE-DIRECTORY forces S to be interpreted as a directory
    693 pathname \(third return value will be NIL, final component
    694 of S will be treated as part of the directory path.
    696 The intention of this function is to support structured component names,
    697 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
    698 pathnames."
    699   (check-type s string)
    700   (when (find #\: s)
    701     (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
    702   (let* ((components (split-string s :separator "/"))
    703          (last-comp (car (last components))))
    704     (multiple-value-bind (relative components)
    705         (if (equal (first components) "")
    706             (if (equal (first-char s) #\/)
    707                 (progn
    708                   (when force-relative
    709                     (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
    710                   (values :absolute (cdr components)))
    711                 (values :relative nil))
    712           (values :relative components))
    713       (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
    714       (setf components (substitute :back ".." components :test #'equal))
    715       (cond
    716         ((equal last-comp "")
    717          (values relative components nil)) ; "" already removed
    718         (force-directory
    719          (values relative components nil))
    720         (t
    721          (values relative (butlast components) last-comp))))))
    723 (defun* remove-keys (key-names args)
    724   (loop :for (name val) :on args :by #'cddr
    725     :unless (member (symbol-name name) key-names
    726                     :key #'symbol-name :test 'equal)
    727     :append (list name val)))
    729 (defun* remove-keyword (key args)
    730   (loop :for (k v) :on args :by #'cddr
    731     :unless (eq k key)
    732     :append (list k v)))
    734 (defun* getenv (x)
    735   (declare (ignorable x))
    736   #+(or abcl clisp ecl xcl) (ext:getenv x)
    737   #+allegro (sys:getenv x)
    738   #+clozure (ccl:getenv x)
    739   #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
    740   #+cormanlisp
    741   (let* ((buffer (ct:malloc 1))
    742          (cname (ct:lisp-string-to-c-string x))
    743          (needed-size (win:getenvironmentvariable cname buffer 0))
    744          (buffer1 (ct:malloc (1+ needed-size))))
    745     (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
    746                nil
    747                (ct:c-string-to-lisp-string buffer1))
    748       (ct:free buffer)
    749       (ct:free buffer1)))
    750   #+gcl (system:getenv x)
    751   #+genera nil
    752   #+lispworks (lispworks:environment-variable x)
    753   #+mcl (ccl:with-cstrs ((name x))
    754           (let ((value (_getenv name)))
    755             (unless (ccl:%null-ptr-p value)
    756               (ccl:%get-cstring value))))
    757   #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
    758   #+sbcl (sb-ext:posix-getenv x)
    759   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    760   (error "~S is not supported on your implementation" 'getenv))
     1555    (make-pathname* :name nil :type nil :version nil
     1556                    :directory (merge-pathname-directory-components
     1557                                '(:relative :back) (pathname-directory pathname))
     1558                    :defaults pathname)))
    7621560(defun* directory-pathname-p (pathname)
    7771575             (check-one (pathname-type pathname))
    7781576             t)))))
     1578(defun* file-pathname-p (pathname)
     1579  "Does PATHNAME represent a file, i.e. has a non-null NAME component?
     1581Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
     1583Note that this does _not_ check to see that PATHNAME points to an
     1584actually-existing file.
     1586Returns the (parsed) PATHNAME when true"
     1587  (when pathname
     1588    (let* ((pathname (pathname pathname))
     1589           (name (pathname-name pathname)))
     1590      (when (not (member name '(nil :unspecific "") :test 'equal))
     1591        pathname))))
    7801593(defun* ensure-directory-pathname (pathspec)
    7901603    pathspec)
    7911604   (t
    792     (make-pathname :directory (append (or (pathname-directory pathspec)
    793                                           (list :relative))
    794                                       (list (file-namestring pathspec)))
    795                    :name nil :type nil :version nil
    796                    :defaults pathspec))))
    798 #+genera
    799 (unless (fboundp 'ensure-directories-exist)
    800   (defun* ensure-directories-exist (path)
    801     (fs:create-directories-recursively (pathname path))))
    803 (defun* absolute-pathname-p (pathspec)
    804   (and (typep pathspec '(or pathname string))
    805        (eq :absolute (car (pathname-directory (pathname pathspec))))))
    807 (defun* coerce-pathname (name &key type defaults)
    808   "coerce NAME into a PATHNAME.
    809 When given a string, portably decompose it into a relative pathname:
    810 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
    811 if TYPE is NIL, its last #\\. if any separates name and type from from type;
    812 if TYPE is a string, it is the type, and the whole string is the name;
    813 if TYPE is :DIRECTORY, the string is a directory component;
    814 if the string is empty, it's a directory.
    815 Any directory named .. is read as :BACK.
    816 Host, device and version components are taken from DEFAULTS."
    817   ;; The defaults are required notably because they provide the default host
    818   ;; to the below make-pathname, which may crucially matter to people using
    819   ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
    820   ;; NOTE that the host and device slots will be taken from the defaults,
    821   ;; but that should only matter if you later merge relative pathnames with
    823   (etypecase name
    824     ((or null pathname)
    825      name)
    826     (symbol
    827      (coerce-pathname (string-downcase name) :type type :defaults defaults))
    828     (string
    829      (multiple-value-bind (relative path filename)
    830          (component-name-to-pathname-components name :force-directory (eq type :directory)
    831                                                 :force-relative t)
    832        (multiple-value-bind (name type)
     1605    (make-pathname* :directory (append (or (normalize-pathname-directory-component
     1606                                            (pathname-directory pathspec))
     1607                                           (list :relative))
     1608                                       (list (file-namestring pathspec)))
     1609                    :name nil :type nil :version nil :defaults pathspec))))
     1612;;; Wildcard pathnames
     1613(defparameter *wild* (or #+cormanlisp "*" :wild))
     1614(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
     1615(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
     1616(defparameter *wild-file*
     1617  (make-pathname :directory nil :name *wild* :type *wild*
     1618                 :version (or #-(or allegro abcl xcl) *wild*)))
     1619(defparameter *wild-directory*
     1620  (make-pathname* :directory `(:relative ,*wild-directory-component*)
     1621                  :name nil :type nil :version nil))
     1622(defparameter *wild-inferiors*
     1623  (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
     1624                  :name nil :type nil :version nil))
     1625(defparameter *wild-path*
     1626  (merge-pathnames* *wild-file* *wild-inferiors*))
     1628(defun* wilden (path)
     1629  (merge-pathnames* *wild-path* path))
     1632;;; Probing the filesystem
     1633(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
     1634  ;; says a NIL host can mean a default host;
     1635  ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
     1636  ;; strings and lists of strings or :unspecific
     1637  ;; But CMUCL decides to die on NIL.
     1638  (make-pathname* :directory nil :name nil :type nil :version nil :device nil
     1639                  :host (or #+cmu lisp::*unix-host*)
     1640                  ;; the default shouldn't matter, but we really want something physical
     1641                  :defaults defaults))
     1643(defmacro with-pathname-defaults ((&optional defaults) &body body)
     1644  `(let ((*default-pathname-defaults* ,(or defaults '(nil-pathname)))) ,@body))
     1646(defun* truename* (p)
     1647  ;; avoids both logical-pathname merging and physical resolution issues
     1648  (and p (ignore-errors (with-pathname-defaults () (truename p)))))
     1650(defun* probe-file* (p &key truename)
     1651  "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
     1652probes the filesystem for a file or directory with given pathname.
     1653If it exists, return its truename is ENSURE-PATHNAME is true,
     1654or the original (parsed) pathname if it is false (the default)."
     1655  (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
     1656    (etypecase p
     1657      (null nil)
     1658      (string (probe-file* (parse-namestring p) :truename truename))
     1659      (pathname (unless (wild-pathname-p p)
     1660                  (let ((foundtrue
     1661                          #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
     1662                                '(probe-file p)
     1663                                #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil))
     1664                                          `(ignore-errors (,it p)))
     1665                                #+gcl2.6
     1666                                '(or (probe-file p)
     1667                                  (and (directory-pathname-p p)
     1668                                   (ignore-errors
     1669                                    (ensure-directory-pathname
     1670                                     (truename* (subpathname
     1671                                                 (ensure-directory-pathname p) "."))))))
     1672                                '(truename* p))))
     1673                    (cond
     1674                      (truename foundtrue)
     1675                      (foundtrue p)
     1676                      (t nil))))))))
     1678(defun* safe-file-write-date (pathname)
     1679  ;; If FILE-WRITE-DATE returns NIL, it's possible that
     1680  ;; the user or some other agent has deleted an input file.
     1681  ;; Also, generated files will not exist at the time planning is done
     1682  ;; and calls compute-action-stamp which calls safe-file-write-date.
     1683  ;; So it is very possible that we can't get a valid file-write-date,
     1684  ;; and we can survive and we will continue the planning
     1685  ;; as if the file were very old.
     1686  ;; (or should we treat the case in a different, special way?)
     1687  (and (probe-file* pathname) (ignore-errors (file-write-date pathname))))
     1689(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
     1690  (apply 'directory pathname-spec
     1691         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     1692                             #+clozure '(:follow-links nil)
     1693                             #+clisp '(:circle t :if-does-not-exist :ignore)
     1694                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
     1695                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
     1696                                      '(:resolve-symlinks nil))))))
     1698(defun* filter-logical-directory-results (directory entries merger)
     1699  (if (logical-pathname-p directory)
     1700      ;; Try hard to not resolve logical-pathname into physical pathnames;
     1701      ;; otherwise logical-pathname users/lovers will be disappointed.
     1702      ;; If directory* could use some implementation-dependent magic,
     1703      ;; we will have logical pathnames already; otherwise,
     1704      ;; we only keep pathnames for which specifying the name and
     1705      ;; translating the LPN commute.
     1706      (loop :for f :in entries
     1707        :for p = (or (and (logical-pathname-p f) f)
     1708                     (let* ((u (ignore-errors (funcall merger f))))
     1709                       ;; The first u avoids a cumbersome (truename u) error.
     1710                       ;; At this point f should already be a truename,
     1711                       ;; but isn't quite in CLISP, for it doesn't have :version :newest
     1712                       (and u (equal (truename* u) (truename* f)) u)))
     1713        :when p :collect p)
     1714      entries))
     1716(defun* directory-files (directory &optional (pattern *wild-file*))
     1717  (let ((dir (pathname directory)))
     1718    (when (logical-pathname-p dir)
     1719      ;; Because of the filtering we do below,
     1720      ;; logical pathnames have restrictions on wild patterns.
     1721      ;; Not that the results are very portable when you use these patterns on physical pathnames.
     1722      (when (wild-pathname-p dir)
     1723        (error "Invalid wild pattern in logical directory ~S" directory))
     1724      (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     1725        (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
     1726      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
     1727    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     1728      (filter-logical-directory-results
     1729       directory entries
     1730       #'(lambda (f)
     1731           (make-pathname :defaults dir
     1732                          :name (make-pathname-component-logical (pathname-name f))
     1733                          :type (make-pathname-component-logical (pathname-type f))
     1734                          :version (make-pathname-component-logical (pathname-version f))))))))
     1736(defun* subdirectories (directory)
     1737  (let* ((directory (ensure-directory-pathname directory))
     1738         #-(or abcl cormanlisp genera xcl)
     1739         (wild (merge-pathnames*
     1740                #-(or abcl allegro cmu lispworks sbcl scl xcl)
     1741                *wild-directory*
     1742                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
     1743                directory))
     1744         (dirs
     1745          #-(or abcl cormanlisp genera xcl)
     1746          (ignore-errors
     1747            (directory* wild . #.(or #+clozure '(:directories t :files nil)
     1748                                     #+mcl '(:directories t))))
     1749          #+(or abcl xcl) (system:list-directory directory)
     1750          #+cormanlisp (cl::directory-subdirs directory)
     1751          #+genera (fs:directory-list directory))
     1752         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
     1753         (dirs (loop :for x :in dirs
     1754                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
     1755                          #+allegro (excl:probe-directory x)
     1756                          #+(or cmu sbcl scl) (directory-pathname-p x)
     1757                          #+genera (getf (cdr x) :directory)
     1758                          #+lispworks (lw:file-directory-p x)
     1759                 :when d :collect #+(or abcl allegro xcl) d
     1760                                  #+genera (ensure-directory-pathname (first x))
     1761                                  #+(or cmu lispworks sbcl scl) x)))
     1762    (filter-logical-directory-results
     1763     directory dirs
     1764     (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
     1765                       '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
     1766       #'(lambda (d)
     1767           (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
     1768             (and (consp dir) (consp (cdr dir))
     1769                  (make-pathname
     1770                   :defaults directory :name nil :type nil :version nil
     1771                   :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
     1773(defun* collect-sub*directories (directory collectp recursep collector)
     1774  (when (funcall collectp directory)
     1775    (funcall collector directory))
     1776  (dolist (subdir (subdirectories directory))
     1777    (when (funcall recursep subdir)
     1778      (collect-sub*directories subdir collectp recursep collector))))
     1781;;; Parsing filenames and lists thereof
     1782(defun* split-unix-namestring-directory-components
     1783    (unix-namestring &key ensure-directory dot-dot)
     1784  "Splits the path string UNIX-NAMESTRING, returning four values:
     1785A flag that is either :absolute or :relative, indicating
     1786   how the rest of the values are to be interpreted.
     1787A directory path --- a list of strings and keywords, suitable for
     1788   use with MAKE-PATHNAME when prepended with the flag value.
     1789   Directory components with an empty name or the name . are removed.
     1790   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
     1791A last-component, either a file-namestring including type extension,
     1792   or NIL in the case of a directory pathname.
     1793A flag that is true iff the unix-style-pathname was just
     1794   a file-namestring without / path specification.
     1795ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
     1796the third return value will be NIL, and final component of the namestring
     1797will be treated as part of the directory path.
     1799An empty string is thus read as meaning a pathname object with all fields nil.
     1801Note that : characters will NOT be interpreted as host specification.
     1802Absolute pathnames are only appropriate on Unix-style systems.
     1804The intention of this function is to support structured component names,
     1805e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
     1806  (check-type unix-namestring string)
     1807  (check-type dot-dot (member nil :back :up))
     1808  (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
     1809           (plusp (length unix-namestring)))
     1810      (values :relative () unix-namestring t)
     1811      (let* ((components (split-string unix-namestring :separator "/"))
     1812             (last-comp (car (last components))))
     1813        (multiple-value-bind (relative components)
     1814            (if (equal (first components) "")
     1815                (if (equal (first-char unix-namestring) #\/)
     1816                    (values :absolute (cdr components))
     1817                    (values :relative nil))
     1818                (values :relative components))
     1819          (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
     1820                                      components))
     1821          (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
     1822          (cond
     1823            ((equal last-comp "")
     1824             (values relative components nil nil)) ; "" already removed from components
     1825            (ensure-directory
     1826             (values relative components nil nil))
     1827            (t
     1828             (values relative (butlast components) last-comp nil)))))))
     1830(defun* split-name-type (filename)
     1831  "Split a filename into two values NAME and TYPE that are returned.
     1832We assume filename has no directory component.
     1833The last . if any separates name and type from from type,
     1834except that if there is only one . and it is in first position,
     1835the whole filename is the NAME with an empty type.
     1836NAME is always a string.
     1837For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
     1838  (check-type filename string)
     1839  (assert (plusp (length filename)))
     1840  (destructuring-bind (name &optional (type *unspecific-pathname-type*))
     1841      (split-string filename :max 2 :separator ".")
     1842    (if (equal name "")
     1843        (values filename *unspecific-pathname-type*)
     1844        (values name type))))
     1846(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
     1847                                    &allow-other-keys)
     1848  "Coerce NAME into a PATHNAME using standard Unix syntax.
     1850Unix syntax is used whether or not the underlying system is Unix;
     1851on such non-Unix systems it is only usable but for relative pathnames;
     1852but especially to manipulate relative pathnames portably, it is of crucial
     1853to possess a portable pathname syntax independent of the underlying OS.
     1854This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
     1856When given a PATHNAME object, just return it untouched.
     1857When given NIL, just return NIL.
     1858When given a non-null SYMBOL, first downcase its name and treat it as a string.
     1859When given a STRING, portably decompose it into a pathname as below.
     1861#\\/ separates directory components.
     1863The last #\\/-separated substring is interpreted as follows:
     18641- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
     1865 the string is made the last directory component, and NAME and TYPE are NIL.
     1866 if the string is empty, it's the empty pathname with all slots NIL.
     18672- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
     1868 are separated by SPLIT-NAME-TYPE.
     18693- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
     1871Directory components with an empty name the name . are removed.
     1872Any directory named .. is read as DOT-DOT,
     1873which must be one of :BACK or :UP and defaults to :BACK.
     1875HOST, DEVICE and VERSION components are taken from DEFAULTS,
     1876which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL.
     1877No host or device can be specified in the string itself,
     1878which makes it unsuitable for absolute pathnames outside Unix.
     1880For relative pathnames, these components (and hence the defaults) won't matter
     1881if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
     1882which is an important reason to always use MERGE-PATHNAMES*.
     1884Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
     1885with those keys, removing TYPE DEFAULTS and DOT-DOT.
     1886When you're manipulating pathnames that are supposed to make sense portably
     1887even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
     1888to throw an error if the pathname is absolute"
     1889  (block nil
     1890    (check-type type (or null string (eql :directory)))
     1891    (when ensure-directory
     1892      (setf type :directory))
     1893    (etypecase name
     1894      ((or null pathname) (return name))
     1895      (symbol
     1896       (setf name (string-downcase name)))
     1897      (string))
     1898    (multiple-value-bind (relative path filename file-only)
     1899        (split-unix-namestring-directory-components
     1900         name :dot-dot dot-dot :ensure-directory (eq type :directory))
     1901      (multiple-value-bind (name type)
     1902          (cond
     1903            ((or (eq type :directory) (null filename))
     1904             (values nil nil))
     1905            (type
     1906             (values filename type))
     1907            (t
     1908             (split-name-type filename)))
     1909        (apply 'ensure-pathname
     1910               (make-pathname*
     1911                :directory (unless file-only (cons relative path))
     1912                :name name :type type
     1913                :defaults (or defaults (nil-pathname)))
     1914               (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
     1916(defun* unix-namestring (pathname)
     1917  "Given a non-wild PATHNAME, return a Unix-style namestring for it.
     1918If the PATHNAME is NIL or a STRING, return it unchanged.
     1920This only considers the DIRECTORY, NAME and TYPE components of the pathname.
     1921This is a portable solution for representing relative pathnames,
     1922But unless you are running on a Unix system, it is not a general solution
     1923to representing native pathnames.
     1925An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
     1926or if it is a PATHNAME but some of its components are not recognized."
     1927  (etypecase pathname
     1928    ((or null string) pathname)
     1929    (pathname
     1930     (with-output-to-string (s)
     1931       (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
     1932         (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
     1933                (name (pathname-name pathname))
     1934                (type (pathname-type pathname))
     1935                (type (and (not (eq type :unspecific)) type)))
    8331936           (cond
    834              ((or (eq type :directory) (null filename))
    835               (values nil nil))
    836              (type
    837               (values filename type))
     1937             ((eq dir ()))
     1938             ((eq dir '(:relative)) (princ "./" s))
     1939             ((consp dir)
     1940              (destructuring-bind (relabs &rest dirs) dir
     1941                (or (member relabs '(:relative :absolute)) (err))
     1942                (when (eq relabs :absolute) (princ #\/ s))
     1943                (loop :for x :in dirs :do
     1944                  (cond
     1945                    ((member x '(:back :up)) (princ "../" s))
     1946                    ((equal x "") (err))
     1947                    ;;((member x '("." "..") :test 'equal) (err))
     1948                    ((stringp x) (format s "~A/" x))
     1949                    (t (err))))))
     1950             (t (err)))
     1951           (cond
     1952             (name
     1953              (or (and (stringp name) (or (null type) (stringp type))) (err))
     1954              (format s "~A~@[.~A~]" name type))
    8381955             (t
    839               (split-name-type filename)))
    840          (apply 'make-pathname :directory (cons relative path) :name name :type type
    841                 (when defaults `(:defaults ,defaults))))))))
    843 (defun* merge-component-name-type (name &key type defaults)
    844   ;; For backwards compatibility only, for people using internals.
    845   ;; Will be removed in a future release, e.g. 2.016.
    846   (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    847   (coerce-pathname name :type type :defaults defaults))
     1956              (or (null type) (err))))))))))
    8491958(defun* subpathname (pathname subpath &key type)
    850   (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
    851                                   (pathname-directory-pathname pathname))))
    853 (defun subpathname* (pathname subpath &key type)
     1959  "This function takes a PATHNAME and a SUBPATH and a TYPE.
     1960If SUBPATH is already a PATHNAME object (not namestring),
     1961and is an absolute pathname at that, it is returned unchanged;
     1962otherwise, SUBPATH is turned into a relative pathname with given TYPE
     1964then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
     1965  (or (and (pathnamep subpath) (absolute-pathname-p subpath))
     1966      (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
     1967                        (pathname-directory-pathname pathname))))
     1969(defun* subpathname* (pathname subpath &key type)
     1970  "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
    8541971  (and pathname
    8551972       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    857 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
    858   (check-type n (integer 0 *))
    859   (loop
    860     :for l = x :then (cdr l)
    861     :for i :downfrom n :do
    862     (cond
    863       ((zerop i) (return (null l)))
    864       ((not (consp l)) (return nil)))))
    866 (defun* string-suffix-p (s suffix)
    867   (check-type s string)
    868   (check-type suffix string)
    869   (let ((start (- (length s) (length suffix))))
    870     (and (<= 0 start)
    871          (string-equal s suffix :start1 start))))
    873 (defun* read-file-forms (file)
    874   (with-open-file (in file)
    875     (loop :with eof = (list nil)
    876      :for form = (read in nil eof)
    877      :until (eq form eof)
    878      :collect form)))
     1974;;; Pathname host and its root
    8801975(defun* pathname-root (pathname)
    881   (make-pathname :directory '(:absolute)
    882                  :name nil :type nil :version nil
    883                  :defaults pathname ;; host device, and on scl, *some*
    884                  ;; scheme-specific parts: port username password, not others:
    885                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    887 (defun* probe-file* (p)
    888   "when given a pathname P, probes the filesystem for a file or directory
    889 with given pathname and if it exists return its truename."
    890   (etypecase p
    891     (null nil)
    892     (string (probe-file* (parse-namestring p)))
    893     (pathname (unless (wild-pathname-p p)
    894                 #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
    895                       '(probe-file p)
    896                       #+clisp (aif (find-symbol* '#:probe-pathname :ext)
    897                                    `(ignore-errors (,it p)))
    898                       '(ignore-errors (truename p)))))))
    900 (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
    901   "Resolve as much of a pathname as possible"
    902   (block nil
    903     (when (typep pathname '(or null logical-pathname)) (return pathname))
    904     (let ((p (merge-pathnames* pathname defaults)))
    905       (when (typep p 'logical-pathname) (return p))
    906       (let ((found (probe-file* p)))
    907         (when found (return found)))
    908       (unless (absolute-pathname-p p)
    909         (let ((true-defaults (ignore-errors (truename defaults))))
    910           (when true-defaults
    911             (setf p (merge-pathnames pathname true-defaults)))))
    912       (unless (absolute-pathname-p p) (return p))
    913       (let ((sofar (probe-file* (pathname-root p))))
    914         (unless sofar (return p))
    915         (flet ((solution (directories)
    916                  (merge-pathnames*
    917                   (make-pathname :host nil :device nil
    918                                  :directory `(:relative ,@directories)
    919                                  :name (pathname-name p)
    920                                  :type (pathname-type p)
    921                                  :version (pathname-version p))
    922                   sofar)))
    923           (loop :with directory = (normalize-pathname-directory-component
    924                                    (pathname-directory p))
    925             :for component :in (cdr directory)
    926             :for rest :on (cdr directory)
    927             :for more = (probe-file*
    928                          (merge-pathnames*
    929                           (make-pathname :directory `(:relative ,component))
    930                           sofar)) :do
    931             (if more
    932                 (setf sofar more)
    933                 (return (solution rest)))
    934             :finally
    935             (return (solution nil))))))))
    937 (defun* resolve-symlinks (path)
    938   #-allegro (truenamize path)
    939   #+allegro (if (typep path 'logical-pathname)
    940                 path
    941                 (excl:pathname-resolve-symbolic-links path)))
    943 (defun* resolve-symlinks* (path)
    944   (if *resolve-symlinks*
    945       (and path (resolve-symlinks path))
    946       path))
    948 (defun* ensure-pathname-absolute (path)
    949   (cond
    950     ((absolute-pathname-p path) path)
    951     ((stringp path) (ensure-pathname-absolute (pathname path)))
    952     ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
    953     (t (let ((resolved (resolve-symlinks path)))
    954          (assert (absolute-pathname-p resolved))
    955          resolved))))
    957 (defun* default-directory ()
    958   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    960 (defun* lispize-pathname (input-file)
    961   (make-pathname :type "lisp" :defaults input-file))
    963 (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
    964 (defparameter *wild-file*
    965   (make-pathname :name *wild* :type *wild*
    966                  :version (or #-(or abcl xcl) *wild*) :directory nil))
    967 (defparameter *wild-directory*
    968   (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
    969 (defparameter *wild-inferiors*
    970   (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
    971 (defparameter *wild-path*
    972   (merge-pathnames *wild-file* *wild-inferiors*))
    974 (defun* wilden (path)
    975   (merge-pathnames* *wild-path* path))
     1976  (make-pathname* :directory '(:absolute)
     1977                  :name nil :type nil :version nil
     1978                  :defaults pathname ;; host device, and on scl, *some*
     1979                  ;; scheme-specific parts: port username password, not others:
     1980                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
     1982(defun* pathname-host-pathname (pathname)
     1983  (make-pathname* :directory nil
     1984                  :name nil :type nil :version nil :device nil
     1985                  :defaults pathname ;; host device, and on scl, *some*
     1986                  ;; scheme-specific parts: port username password, not others:
     1987                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    9781990(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
    979   (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     1991  (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
    9801992    (last-char (namestring foo))))
    9932005                         root-namestring)))
    9942006    (multiple-value-bind (relative path filename)
    995         (component-name-to-pathname-components root-string :force-directory t)
     2007        (split-unix-namestring-directory-components root-string :ensure-directory t)
    9962008      (declare (ignore relative filename))
    9972009      (let ((new-base
    998              (make-pathname :defaults root
    999                             :directory `(:absolute ,@path))))
     2010             (make-pathname* :defaults root :directory `(:absolute ,@path))))
    10002011        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    10192030            (setf prefix (strcat scheme prefix)))
    10202031          (assert (and directory (eq (first directory) :absolute)))
    1021           (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    1022                          :defaults pathname)))
     2032          (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
     2033                          :defaults pathname)))
    10232034    pathname)))
    1025 ;;;; -------------------------------------------------------------------------
    1026 ;;;; ASDF Interface, in terms of generic functions.
    1027 (defgeneric* find-system (system &optional error-p))
    1028 (defgeneric* perform-with-restarts (operation component))
    1029 (defgeneric* perform (operation component))
    1030 (defgeneric* operation-done-p (operation component))
    1031 (defgeneric* mark-operation-done (operation component))
    1032 (defgeneric* explain (operation component))
    1033 (defgeneric* output-files (operation component))
    1034 (defgeneric* input-files (operation component))
    1035 (defgeneric* component-operation-time (operation component))
    1036 (defgeneric* operation-description (operation component)
    1037   (:documentation "returns a phrase that describes performing this operation
    1038 on this component, e.g. \"loading /a/b/c\".
    1039 You can put together sentences using this phrase."))
    1041 (defgeneric* system-source-file (system)
    1042   (:documentation "Return the source file in which system is defined."))
    1044 (defgeneric* component-system (component)
    1045   (:documentation "Find the top-level system containing COMPONENT"))
    1047 (defgeneric* component-pathname (component)
    1048   (:documentation "Extracts the pathname applicable for a particular component."))
    1050 (defgeneric* component-relative-pathname (component)
    1051   (:documentation "Returns a pathname for the component argument intended to be
    1052 interpreted relative to the pathname of that component's parent.
    1053 Despite the function's name, the return value may be an absolute
    1054 pathname, because an absolute pathname may be interpreted relative to
    1055 another pathname in a degenerate way."))
    1057 (defgeneric* component-property (component property))
    1059 (defgeneric* (setf component-property) (new-value component property))
    1061 (defgeneric* component-external-format (component))
    1063 (defgeneric* component-encoding (component))
    1065 (eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
    1066   (defgeneric* (setf module-components-by-name) (new-value module)))
    1068 (defgeneric* version-satisfies (component version))
    1070 (defgeneric* find-component (base path)
    1071   (:documentation "Finds the component with PATH starting from BASE module;
    1072 if BASE is nil, then the component is assumed to be a system."))
    1074 (defgeneric* source-file-type (component system))
    1076 (defgeneric* operation-ancestor (operation)
    1077   (:documentation
    1078    "Recursively chase the operation's parent pointer until we get to
    1079 the head of the tree"))
    1081 (defgeneric* component-visited-p (operation component)
    1082   (:documentation "Returns the value stored by a call to
    1083 VISIT-COMPONENT, if that has been called, otherwise NIL.
    1084 This value stored will be a cons cell, the first element
    1085 of which is a computed key, so not interesting.  The
    1086 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
    1087 it as (cdr (component-visited-p op c)).
    1088   In the current form of ASDF, the DATA value retrieved is
    1089 effectively a boolean, indicating whether some operations are
    1090 to be performed in order to do OPERATION X COMPONENT.  If the
    1091 data value is NIL, the combination had been explored, but no
    1092 operations needed to be performed."))
    1094 (defgeneric* visit-component (operation component data)
    1095   (:documentation "Record DATA as being associated with OPERATION
    1096 and COMPONENT.  This is a side-effecting function:  the association
    1097 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
    1098 OPERATION\).
    1099   No evidence that DATA is ever interesting, beyond just being
    1100 non-NIL.  Using the data field is probably very risky; if there is
    1101 already a record for OPERATION X COMPONENT, DATA will be quietly
    1102 discarded instead of recorded.
    1103   Starting with 2.006, TRAVERSE will store an integer in data,
    1104 so that nodes can be sorted in decreasing order of traversal."))
    1107 (defgeneric* (setf visiting-component) (new-value operation component))
    1109 (defgeneric* component-visiting-p (operation component))
    1111 (defgeneric* component-depends-on (operation component)
    1112   (:documentation
    1113    "Returns a list of dependencies needed by the component to perform
    1114     the operation.  A dependency has one of the following forms:
    1116       (<operation> <component>*), where <operation> is a class
    1117         designator and each <component> is a component
    1118         designator, which means that the component depends on
    1119         <operation> having been performed on each <component>; or
    1121       (FEATURE <feature>), which means that the component depends
    1122         on <feature>'s presence in *FEATURES*.
    1124     Methods specialized on subclasses of existing component types
    1125     should usually append the results of CALL-NEXT-METHOD to the
    1126     list."))
    1128 (defgeneric* component-self-dependencies (operation component))
    1130 (defgeneric* traverse (operation component)
    1131   (:documentation
    1132 "Generate and return a plan for performing OPERATION on COMPONENT.
    1134 The plan returned is a list of dotted-pairs. Each pair is the CONS
    1135 of ASDF operation object and a COMPONENT object. The pairs will be
    1136 processed in order by OPERATE."))
    1139 ;;;; -------------------------------------------------------------------------
    1140 ;;; Methods in case of hot-upgrade. See
    1141 (when *upgraded-p*
    1142   (when (find-class 'module nil)
    1143     (eval
    1144      '(defmethod update-instance-for-redefined-class :after
    1145           ((m module) added deleted plist &key)
    1146         (declare (ignorable deleted plist))
    1147         (when *asdf-verbose*
    1148           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    1149                         m (asdf-version)))
    1150         (when (member 'components-by-name added)
    1151           (compute-module-components-by-name m))
    1152         (when (typep m 'system)
    1153           (when (member 'source-file added)
    1154             (%set-system-source-file
    1155              (probe-asd (component-name m) (component-pathname m)) m)
    1156            (when (equal (component-name m) "asdf")
    1157              (setf (component-version m) *asdf-version*))))))))
    1159 ;;;; -------------------------------------------------------------------------
    1160 ;;;; Classes, Conditions
    1162 (define-condition system-definition-error (error) ()
    1163   ;; [this use of :report should be redundant, but unfortunately it's not.
    1164   ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    1165   ;; over print-object; this is always conditions::%print-condition for
    1166   ;; condition objects, which in turn does inheritance of :report options at
    1167   ;; run-time.  fortunately, inheritance means we only need this kludge here in
    1168   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    1169   #+cmu (:report print-object))
    1171 (define-condition formatted-system-definition-error (system-definition-error)
    1172   ((format-control :initarg :format-control :reader format-control)
    1173    (format-arguments :initarg :format-arguments :reader format-arguments))
    1174   (:report (lambda (c s)
    1175                (apply 'format s (format-control c) (format-arguments c)))))
    1177 (define-condition load-system-definition-error (system-definition-error)
    1178   ((name :initarg :name :reader error-name)
    1179    (pathname :initarg :pathname :reader error-pathname)
    1180    (condition :initarg :condition :reader error-condition))
    1181   (:report (lambda (c s)
    1182              (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
    1183                      (error-name c) (error-pathname c) (error-condition c)))))
    1185 (define-condition circular-dependency (system-definition-error)
    1186   ((components :initarg :components :reader circular-dependency-components))
    1187   (:report (lambda (c s)
    1188              (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    1189                      (circular-dependency-components c)))))
    1191 (define-condition duplicate-names (system-definition-error)
    1192   ((name :initarg :name :reader duplicate-names-name))
    1193   (:report (lambda (c s)
    1194              (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
    1195                      (duplicate-names-name c)))))
    1197 (define-condition missing-component (system-definition-error)
    1198   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    1199    (parent :initform nil :reader missing-parent :initarg :parent)))
    1201 (define-condition missing-component-of-version (missing-component)
    1202   ((version :initform nil :reader missing-version :initarg :version)))
    1204 (define-condition missing-dependency (missing-component)
    1205   ((required-by :initarg :required-by :reader missing-required-by)))
    1207 (define-condition missing-dependency-of-version (missing-dependency
    1208                                                  missing-component-of-version)
    1209   ())
    1211 (define-condition operation-error (error)
    1212   ((component :reader error-component :initarg :component)
    1213    (operation :reader error-operation :initarg :operation))
    1214   (:report (lambda (c s)
    1215                (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
    1216                        (type-of c) (error-operation c) (error-component c)))))
    1217 (define-condition compile-error (operation-error) ())
    1218 (define-condition compile-failed (compile-error) ())
    1219 (define-condition compile-warned (compile-error) ())
    1221 (define-condition invalid-configuration ()
    1222   ((form :reader condition-form :initarg :form)
    1223    (location :reader condition-location :initarg :location)
    1224    (format :reader condition-format :initarg :format)
    1225    (arguments :reader condition-arguments :initarg :arguments :initform nil))
    1226   (:report (lambda (c s)
    1227                (format s (compatfmt "~@<~? (will be skipped)~@:>")
    1228                        (condition-format c)
    1229                        (list* (condition-form c) (condition-location c)
    1230                               (condition-arguments c))))))
    1231 (define-condition invalid-source-registry (invalid-configuration warning)
    1232   ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    1233 (define-condition invalid-output-translation (invalid-configuration warning)
    1234   ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    1236 (defclass component ()
    1237   ((name :accessor component-name :initarg :name :type string :documentation
    1238          "Component name: designator for a string composed of portable pathname characters")
    1239    ;; We might want to constrain version with
    1240    ;; :type (and string (satisfies parse-version))
    1241    ;; but we cannot until we fix all systems that don't use it correctly!
    1242    (version :accessor component-version :initarg :version)
    1243    (description :accessor component-description :initarg :description)
    1244    (long-description :accessor component-long-description :initarg :long-description)
    1245    ;; This one below is used by POIU -
    1246    ;; a parallelizing extension of ASDF that compiles in multiple parallel
    1247    ;; slave processes (forked on demand) and loads in the master process.
    1248    ;; Maybe in the future ASDF may use it internally instead of in-order-to.
    1249    (load-dependencies :accessor component-load-dependencies :initform nil)
    1250    ;; In the ASDF object model, dependencies exist between *actions*
    1251    ;; (an action is a pair of operation and component). They are represented
    1252    ;; alists of operations to dependencies (other actions) in each component.
    1253    ;; There are two kinds of dependencies, each stored in its own slot:
    1254    ;; in-order-to and do-first dependencies. These two kinds are related to
    1255    ;; the fact that some actions modify the filesystem,
    1256    ;; whereas other actions modify the current image, and
    1257    ;; this implies a difference in how to interpret timestamps.
    1258    ;; in-order-to dependencies will trigger re-performing the action
    1259    ;; when the timestamp of some dependency
    1260    ;; makes the timestamp of current action out-of-date;
    1261    ;; do-first dependencies do not trigger such re-performing.
    1262    ;; Therefore, a FASL must be recompiled if it is obsoleted
    1263    ;; by any of its FASL dependencies (in-order-to); but
    1264    ;; it needn't be recompiled just because one of these dependencies
    1265    ;; hasn't yet been loaded in the current image (do-first).
    1266    ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
    1267    ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
    1268    ;; Maybe rename the slots in ASDF? But that's not very backwards compatible.
    1269    ;; See our ASDF 2 paper for more complete explanations.
    1270    (in-order-to :initform nil :initarg :in-order-to
    1271                 :accessor component-in-order-to)
    1272    (do-first :initform nil :initarg :do-first
    1273              :accessor component-do-first)
    1274    ;; methods defined using the "inline" style inside a defsystem form:
    1275    ;; need to store them somewhere so we can delete them when the system
    1276    ;; is re-evaluated
    1277    (inline-methods :accessor component-inline-methods :initform nil)
    1278    (parent :initarg :parent :initform nil :reader component-parent)
    1279    ;; no direct accessor for pathname, we do this as a method to allow
    1280    ;; it to default in funky ways if not supplied
    1281    (relative-pathname :initarg :pathname)
    1282    ;; the absolute-pathname is computed based on relative-pathname...
    1283    (absolute-pathname)
    1284    (operation-times :initform (make-hash-table)
    1285                     :accessor component-operation-times)
    1286    (around-compile :initarg :around-compile)
    1287    (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
    1288    ;; XXX we should provide some atomic interface for updating the
    1289    ;; component properties
    1290    (properties :accessor component-properties :initarg :properties
    1291                :initform nil)))
    1293 (defun* component-find-path (component)
    1294   (reverse
    1295    (loop :for c = component :then (component-parent c)
    1296      :while c :collect (component-name c))))
    1298 (defmethod print-object ((c component) stream)
    1299   (print-unreadable-object (c stream :type t :identity nil)
    1300     (format stream "~{~S~^ ~}" (component-find-path c))))
    1303 ;;;; methods: conditions
    1305 (defmethod print-object ((c missing-dependency) s)
    1306   (format s (compatfmt "~@<~A, required by ~A~@:>")
    1307           (call-next-method c nil) (missing-required-by c)))
    1309 (defun* sysdef-error (format &rest arguments)
    1310   (error 'formatted-system-definition-error :format-control
    1311          format :format-arguments arguments))
    1313 ;;;; methods: components
    1315 (defmethod print-object ((c missing-component) s)
    1316   (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
    1317           (missing-requires c)
    1318           (when (missing-parent c)
    1319             (coerce-name (missing-parent c)))))
    1321 (defmethod print-object ((c missing-component-of-version) s)
    1322   (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
    1323           (missing-requires c)
    1324           (missing-version c)
    1325           (when (missing-parent c)
    1326             (coerce-name (missing-parent c)))))
    1328 (defmethod component-system ((component component))
    1329   (aif (component-parent component)
    1330        (component-system it)
    1331        component))
    1333 (defvar *default-component-class* 'cl-source-file)
    1335 (defun* compute-module-components-by-name (module)
    1336   (let ((hash (make-hash-table :test 'equal)))
    1337     (setf (module-components-by-name module) hash)
    1338     (loop :for c :in (module-components module)
    1339       :for name = (component-name c)
    1340       :for previous = (gethash name (module-components-by-name module))
    1341       :do
    1342       (when previous
    1343         (error 'duplicate-names :name name))
    1344       :do (setf (gethash name (module-components-by-name module)) c))
    1345     hash))
    1347 (defclass module (component)
    1348   ((components
    1349     :initform nil
    1350     :initarg :components
    1351     :accessor module-components)
    1352    (components-by-name
    1353     :accessor module-components-by-name)
    1354    ;; What to do if we can't satisfy a dependency of one of this module's
    1355    ;; components.  This allows a limited form of conditional processing.
    1356    (if-component-dep-fails
    1357     :initform :fail
    1358     :initarg :if-component-dep-fails
    1359     :accessor module-if-component-dep-fails)
    1360    (default-component-class
    1361     :initform nil
    1362     :initarg :default-component-class
    1363     :accessor module-default-component-class)))
    1365 (defun* component-parent-pathname (component)
    1366   ;; No default anymore (in particular, no *default-pathname-defaults*).
    1367   ;; If you force component to have a NULL pathname, you better arrange
    1368   ;; for any of its children to explicitly provide a proper absolute pathname
    1369   ;; wherever a pathname is actually wanted.
    1370   (let ((parent (component-parent component)))
    1371     (when parent
    1372       (component-pathname parent))))
    1374 (defmethod component-pathname ((component component))
    1375   (if (slot-boundp component 'absolute-pathname)
    1376       (slot-value component 'absolute-pathname)
    1377       (let ((pathname
    1378              (merge-pathnames*
    1379               (component-relative-pathname component)
    1380               (pathname-directory-pathname (component-parent-pathname component)))))
    1381         (unless (or (null pathname) (absolute-pathname-p pathname))
    1382           (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
    1383                  pathname (component-find-path component)))
    1384         (setf (slot-value component 'absolute-pathname) pathname)
    1385         pathname)))
    1387 (defmethod component-property ((c component) property)
    1388   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    1390 (defmethod (setf component-property) (new-value (c component) property)
    1391   (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    1392     (if a
    1393         (setf (cdr a) new-value)
    1394         (setf (slot-value c 'properties)
    1395               (acons property new-value (slot-value c 'properties)))))
    1396   new-value)
    1398 (defvar *default-encoding* :default
    1399   "Default encoding for source files.
    1400 The default value :default preserves the legacy behavior.
    1401 A future default might be :utf-8 or :autodetect
    1402 reading emacs-style -*- coding: utf-8 -*- specifications,
    1403 and falling back to utf-8 or latin1 if nothing is specified.")
    1405 (defparameter *utf-8-external-format*
    1406   #+(and asdf-unicode (not clisp)) :utf-8
    1407   #+(and asdf-unicode clisp) charset:utf-8
    1408   #-asdf-unicode :default
    1409   "Default :external-format argument to pass to CL:OPEN and also
    1410 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
    1411 On modern implementations, this will decode UTF-8 code points as CL characters.
    1412 On legacy implementations, it may fall back on some 8-bit encoding,
    1413 with non-ASCII code points being read as several CL characters;
    1414 hopefully, if done consistently, that won't affect program behavior too much.")
    1416 (defun* always-default-encoding (pathname)
    1417   (declare (ignore pathname))
    1418   *default-encoding*)
    1420 (defvar *encoding-detection-hook* #'always-default-encoding
    1421   "Hook for an extension to define a function to automatically detect a file's encoding")
    1423 (defun* detect-encoding (pathname)
    1424   (funcall *encoding-detection-hook* pathname))
    1426 (defmethod component-encoding ((c component))
    1427   (or (loop :for x = c :then (component-parent x)
    1428         :while x :thereis (%component-encoding x))
    1429       (detect-encoding (component-pathname c))))
    1431 (defun* default-encoding-external-format (encoding)
    1432   (case encoding
    1433     (:default :default) ;; for backwards compatibility only. Explicit usage discouraged.
    1434     (:utf-8 *utf-8-external-format*)
    1435     (otherwise
    1436      (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
    1437      :default)))
    1439 (defvar *encoding-external-format-hook*
    1440   #'default-encoding-external-format
    1441   "Hook for an extension to define a mapping between non-default encodings
    1442 and implementation-defined external-format's")
    1444 (defun encoding-external-format (encoding)
    1445   (funcall *encoding-external-format-hook* encoding))
    1447 (defmethod component-external-format ((c component))
    1448   (encoding-external-format (component-encoding c)))
    1450 (defclass proto-system () ; slots to keep when resetting a system
    1451   ;; To preserve identity for all objects, we'd need keep the components slots
    1452   ;; but also to modify parse-component-form to reset the recycled objects.
    1453   ((name) #|(components) (components-by-names)|#))
    1455 (defclass system (module proto-system)
    1456   (;; description and long-description are now available for all component's,
    1457    ;; but now also inherited from component, but we add the legacy accessor
    1458    (description :accessor system-description :initarg :description)
    1459    (long-description :accessor system-long-description :initarg :long-description)
    1460    (author :accessor system-author :initarg :author)
    1461    (maintainer :accessor system-maintainer :initarg :maintainer)
    1462    (licence :accessor system-licence :initarg :licence
    1463             :accessor system-license :initarg :license)
    1464    (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
    1465    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    1467 ;;;; -------------------------------------------------------------------------
    1468 ;;;; version-satisfies
    1470 (defmethod version-satisfies ((c component) version)
    1471   (unless (and version (slot-boundp c 'version))
    1472     (when version
    1473       (warn "Requested version ~S but component ~S has no version" version c))
    1474     (return-from version-satisfies t))
    1475   (version-satisfies (component-version c) version))
    1477 (defun* asdf-version ()
    1478   "Exported interface to the version of ASDF currently installed. A string.
    1479 You can compare this string with e.g.:
    1481   *asdf-version*)
    1483 (defun* parse-version (string &optional on-error)
    1484   "Parse a version string as a series of natural integers separated by dots.
    1485 Return a (non-null) list of integers if the string is valid, NIL otherwise.
    1486 If on-error is error, warn, or designates a function of compatible signature,
    1487 the function is called with an explanation of what is wrong with the argument.
    1488 NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
    1489   (and
    1490    (or (stringp string)
    1491        (when on-error
    1492          (funcall on-error "~S: ~S is not a string"
    1493                   'parse-version string)) nil)
    1494    (or (loop :for prev = nil :then c :for c :across string
    1495          :always (or (digit-char-p c)
    1496                      (and (eql c #\.) prev (not (eql prev #\.))))
    1497          :finally (return (and c (digit-char-p c))))
    1498        (when on-error
    1499          (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
    1500                   'parse-version string)) nil)
    1501    (mapcar #'parse-integer (split-string string :separator "."))))
    1503 (defmethod version-satisfies ((cver string) version)
    1504   (let ((x (parse-version cver 'warn))
    1505         (y (parse-version version 'warn)))
    1506     (labels ((bigger (x y)
    1507                (cond ((not y) t)
    1508                      ((not x) nil)
    1509                      ((> (car x) (car y)) t)
    1510                      ((= (car x) (car y))
    1511                       (bigger (cdr x) (cdr y))))))
    1512       (and x y (= (car x) (car y))
    1513            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     2036(defun* subpathp (maybe-subpath base-pathname)
     2037  (and (pathnamep maybe-subpath) (pathnamep base-pathname)
     2038       (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
     2039       (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
     2040       (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
     2041       (with-pathname-defaults ()
     2042         (let ((enough (enough-namestring maybe-subpath base-pathname)))
     2043           (and (relative-pathname-p enough) (pathname enough))))))
     2046;;; Resolving symlinks somewhat
     2047(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
     2048  "Resolve as much of a pathname as possible"
     2049  (block nil
     2050    (when (typep pathname '(or null logical-pathname)) (return pathname))
     2051    (let ((p (merge-pathnames* pathname defaults)))
     2052      (when (logical-pathname-p p) (return p))
     2053      (let ((found (probe-file* p :truename t)))
     2054        (when found (return found)))
     2055      (unless (absolute-pathname-p p)
     2056        (let ((true-defaults (truename* defaults)))
     2057          (when true-defaults
     2058            (setf p (merge-pathnames pathname true-defaults)))))
     2059      (unless (absolute-pathname-p p) (return p))
     2060      (let ((sofar (probe-file* (pathname-root p) :truename t)))
     2061        (unless sofar (return p))
     2062        (flet ((solution (directories)
     2063                 (merge-pathnames*
     2064                  (make-pathname* :host nil :device nil
     2065                                  :directory `(:relative ,@directories)
     2066                                  :name (pathname-name p)
     2067                                  :type (pathname-type p)
     2068                                  :version (pathname-version p))
     2069                  sofar)))
     2070          (loop :with directory = (normalize-pathname-directory-component
     2071                                   (pathname-directory p))
     2072            :for dir :in (cdr directory)
     2073            :for rest :on (cdr directory)
     2074            :for more = (probe-file*
     2075                         (merge-pathnames*
     2076                          (make-pathname* :directory `(:relative ,dir))
     2077                          sofar) :truename t) :do
     2078            (if more
     2079                (setf sofar more)
     2080                (return (solution rest)))
     2081            :finally
     2082            (return (solution nil))))))))
     2084(defun* resolve-symlinks (path)
     2085  #-allegro (truenamize path)
     2086  #+allegro
     2087  (if (physical-pathname-p path)
     2088      (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
     2089      path))
     2091(defun* resolve-symlinks* (path)
     2092  (if *resolve-symlinks*
     2093      (and path (resolve-symlinks path))
     2094      path))
     2097;;; absolute vs relative
     2098(defun* ensure-pathname-absolute (path &optional defaults (on-error 'error))
     2099  (cond
     2100    ((absolute-pathname-p path))
     2101    ((stringp path) (ensure-pathname-absolute (pathname path) defaults))
     2102    ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
     2103    ((absolute-pathname-p defaults)
     2104     (or (absolute-pathname-p (merge-pathnames* path defaults))
     2105         (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
     2106                        path defaults)))
     2107    (t (call-function on-error
     2108                      "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
     2109                      path defaults))))
     2111(defun relativize-directory-component (directory-component)
     2112  (let ((directory (normalize-pathname-directory-component directory-component)))
     2113    (cond
     2114      ((stringp directory)
     2115       (list :relative directory))
     2116      ((eq (car directory) :absolute)
     2117       (cons :relative (cdr directory)))
     2118      (t
     2119       directory))))
     2121(defun* relativize-pathname-directory (pathspec)
     2122  (let ((p (pathname pathspec)))
     2123    (make-pathname*
     2124     :directory (relativize-directory-component (pathname-directory p))
     2125     :defaults p)))
     2128;;; Simple filesystem operations
     2129(defun* ensure-all-directories-exist (pathnames)
     2130   (dolist (pathname pathnames)
     2131     (ensure-directories-exist (translate-logical-pathname pathname))))
     2133(defun* rename-file-overwriting-target (source target)
     2134  #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
     2135  (posix:copy-file source target :method :rename)
     2136  #-clisp
     2137  (rename-file source target
     2138               #+clozure :if-exists #+clozure :rename-and-delete))
     2140(defun* delete-file-if-exists (x)
     2141  (when (probe-file* x)
     2142    (delete-file x)))
     2144;;; Translate a pathname
     2145(defun* (translate-pathname*) (path absolute-source destination &optional root source)
     2146  (declare (ignore source))
     2147  (cond
     2148    ((functionp destination)
     2149     (funcall destination path absolute-source))
     2150    ((eq destination t)
     2151     path)
     2152    ((not (pathnamep destination))
     2153     (error "Invalid destination"))
     2154    ((not (absolute-pathname-p destination))
     2155     (translate-pathname path absolute-source (merge-pathnames* destination root)))
     2156    (root
     2157     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
     2158    (t
     2159     (translate-pathname path absolute-source destination))))
     2162;;; Temporary pathnames
     2163(defun* add-pathname-suffix (pathname suffix)
     2164  (make-pathname :name (strcat (pathname-name pathname) suffix)
     2165                 :defaults pathname))
     2167(defun* tmpize-pathname (x)
     2168  (add-pathname-suffix x "-ASDF-TMP"))
     2170(defun* call-with-staging-pathname (pathname fun)
     2171  "Calls fun with a staging pathname, and atomically
     2172renames the staging pathname to the pathname in the end.
     2173Note: this protects only against failure of the program,
     2174not against concurrent attempts.
     2175For the latter case, we ought pick random suffix and atomically open it."
     2176  (let* ((pathname (pathname pathname))
     2177         (staging (tmpize-pathname pathname)))
     2178    (unwind-protect
     2179         (multiple-value-prog1
     2180             (funcall fun staging)
     2181           (rename-file-overwriting-target staging pathname))
     2182      (delete-file-if-exists staging))))
     2184(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     2185  `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
     2187;;; Basic pathnames
     2188(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing)
     2189  (flet ((sanitize (x)
     2190           (setf x (and x (ignore-errors (translate-logical-pathname x))))
     2191           (when (pathnamep x)
     2192             (setf x
     2193                   (ecase keep
     2194                     ((t) x)
     2195                     ((:directory) (pathname-directory-pathname x))
     2196                     ((:root) (pathname-root x))
     2197                     ((:host) (pathname-host-pathname x))
     2198                     ((nil) (nil-pathname x))))
     2199             (when want-existing ;; CCL's probe-file will choke if d-p-d is logical
     2200               (setf x (probe-file* x)))
     2201             (and (physical-pathname-p x) x))))
     2202    (or (sanitize defaults)
     2203        (when fallback
     2204          (or (sanitize (nil-pathname))
     2205              (sanitize (ignore-errors (user-homedir-pathname)))))
     2206        (error "Could not find a sane a physical pathname~
     2207                ~@[ from ~S~]~@[~:*~@[ or~*~] fallbacks~]"
     2208               defaults fallback))))
     2210(defun* root-pathname ()
     2211  "On a Unix system, this will presumably be the root pathname /.
     2212Otherwise, this will be the root of some implementation-dependent filesystem host."
     2213  (sane-physical-pathname :keep :root :fallback t))
    15152216;;;; -----------------------------------------------------------------
    15842285                    (read-sequence buffer s)
    15852286                    (map 'string #'code-char buffer)))))))
    1586       (end-of-file ()
     2287      (end-of-file (c)
     2288        (declare (ignore c))
    15872289        nil)))))
    1589 ;;;; -------------------------------------------------------------------------
    1590 ;;;; Finding systems
    1592 (defun* make-defined-systems-table ()
    1593   (make-hash-table :test 'equal))
    1595 (defvar *defined-systems* (make-defined-systems-table)
    1596   "This is a hash table whose keys are strings, being the
    1597 names of the systems, and whose values are pairs, the first
    1598 element of which is a universal-time indicating when the
    1599 system definition was last updated, and the second element
    1600 of which is a system object.")
    1602 (defun* coerce-name (name)
    1603   (typecase name
    1604     (component (component-name name))
    1605     (symbol (string-downcase (symbol-name name)))
    1606     (string name)
    1607     (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
    1609 (defun* system-registered-p (name)
    1610   (gethash (coerce-name name) *defined-systems*))
    1612 (defun* registered-systems ()
    1613   (loop :for (() . system) :being :the :hash-values :of *defined-systems*
    1614     :collect (coerce-name system)))
    1616 (defun* register-system (system)
    1617   (check-type system system)
    1618   (let ((name (component-name system)))
    1619     (check-type name string)
    1620     (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
    1621     (unless (eq system (cdr (gethash name *defined-systems*)))
    1622       (setf (gethash name *defined-systems*)
    1623             (cons (get-universal-time) system)))))
    1625 (defun* clear-system (name)
    1626   "Clear the entry for a system in the database of systems previously loaded.
    1627 Note that this does NOT in any way cause the code of the system to be unloaded."
    1628   ;; There is no "unload" operation in Common Lisp, and
    1629   ;; a general such operation cannot be portably written,
    1630   ;; considering how much CL relies on side-effects to global data structures.
    1631   (remhash (coerce-name name) *defined-systems*))
    1633 (defun* map-systems (fn)
    1634   "Apply FN to each defined system.
    1636 FN should be a function of one argument. It will be
    1637 called with an object of type asdf:system."
    1638   (loop :for (nil . system) :being :the hash-values :of *defined-systems*
    1639         :do (funcall fn system)))
    1641 ;;; for the sake of keeping things reasonably neat, we adopt a
    1642 ;;; convention that functions in this list are prefixed SYSDEF-
    1644 (defvar *system-definition-search-functions* '())
    1646 (setf *system-definition-search-functions*
    1647       (append
    1648        ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
    1649        (remove 'contrib-sysdef-search *system-definition-search-functions*)
    1650        ;; Tuck our defaults at the end of the list if they were absent.
    1651        ;; This is imperfect, in case they were removed on purpose,
    1652        ;; but then it will be the responsibility of whoever does that
    1653        ;; to upgrade asdf before he does such a thing rather than after.
    1654        (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
    1655                   '(sysdef-central-registry-search
    1656                     sysdef-source-registry-search
    1657                     sysdef-find-asdf))))
    1659 (defun* search-for-system-definition (system)
    1660   (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
    1661         (cons 'find-system-if-being-defined
    1662               *system-definition-search-functions*)))
    1664 (defvar *central-registry* nil
    1665 "A list of 'system directory designators' ASDF uses to find systems.
    1667 A 'system directory designator' is a pathname or an expression
    1668 which evaluates to a pathname. For example:
    1670     (setf asdf:*central-registry*
    1671           (list '*default-pathname-defaults*
    1672                 #p\"/home/me/cl/systems/\"
    1673                 #p\"/usr/share/common-lisp/systems/\"))
    1675 This is for backward compatibilily.
    1676 Going forward, we recommend new users should be using the source-registry.
    1677 ")
    1679 (defun* featurep (x &optional (features *features*))
    1680   (cond
    1681     ((atom x)
    1682      (and (member x features) t))
    1683     ((eq :not (car x))
    1684      (assert (null (cddr x)))
    1685      (not (featurep (cadr x) features)))
    1686     ((eq :or (car x))
    1687      (some #'(lambda (x) (featurep x features)) (cdr x)))
    1688     ((eq :and (car x))
    1689      (every #'(lambda (x) (featurep x features)) (cdr x)))
    1690     (t
    1691      (error "Malformed feature specification ~S" x))))
    1693 (defun* os-unix-p ()
    1694   (featurep '(:or :unix :cygwin :darwin)))
    1696 (defun* os-windows-p ()
    1697   (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
    1699 (defun* probe-asd (name defaults)
     2292;;; Check pathname constraints
     2294(defun* ensure-pathname
     2295    (pathname &key
     2296              on-error
     2297              defaults type dot-dot
     2298              want-pathname
     2299              want-logical want-physical ensure-physical
     2300              want-relative want-absolute ensure-absolute ensure-subpath
     2301              want-non-wild want-wild wilden
     2302              want-file want-directory ensure-directory
     2303              want-existing ensure-directories-exist
     2304              truename resolve-symlinks truenamize
     2305              &aux (p pathname)) ;; mutable working copy, preserve original
     2306  "Coerces its argument into a PATHNAME,
     2307optionally doing some transformations and checking specified constraints.
     2309If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
     2311If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
     2313then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
     2314and the all the checks and transformations are run.
     2316Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
     2317The boolean T is an alias for ERROR.
     2318ERROR means that an error will be raised if the constraint is not satisfied.
     2319CERROR means that an continuable error will be raised if the constraint is not satisfied.
     2320IGNORE means just return NIL instead of the pathname.
     2322The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
     2323that will be called with the the following arguments:
     2324a generic format string for ensure pathname, the pathname,
     2325the keyword argument corresponding to the failed check or transformation,
     2326a format string for the reason ENSURE-PATHNAME failed,
     2327and a list with arguments to that format string.
     2328If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
     2329You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
     2331The transformations and constraint checks are done in this order,
     2332which is also the order in the lambda-list:
     2334WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
     2335Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
     2336WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
     2337WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
     2338ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
     2339WANT-RELATIVE checks that pathname has a relative directory component
     2340WANT-ABSOLUTE checks that pathname does have an absolute directory component
     2341ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
     2342that the result absolute is an absolute pathname indeed.
     2343ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
     2344WANT-FILE checks that pathname has a non-nil FILE component
     2345WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
     2347any file and type components as being actually a last directory component.
     2348WANT-NON-WILD checks that pathname is not a wild pathname
     2349WANT-WILD checks that pathname is a wild pathname
     2350WILDEN merges the pathname with **/*.*.* if it is not wild
     2351WANT-EXISTING checks that a file (or directory) exists with that pathname.
     2352ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
     2353TRUENAME replaces the pathname by its truename, or errors if not possible.
     2354RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
     2355TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
    17002356  (block nil
    1701     (when (directory-pathname-p defaults)
    1702       (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
    1703         (when file
    1704           (return file)))
    1705       #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
    1706       (when (os-windows-p)
    1707         (let ((shortcut
    1708                (make-pathname
    1709                 :defaults defaults :version :newest :case :local
    1710                 :name (strcat name ".asd")
    1711                 :type "lnk")))
    1712           (when (probe-file* shortcut)
    1713             (let ((target (parse-windows-shortcut shortcut)))
    1714               (when target
    1715                 (return (pathname target))))))))))
    1717 (defun* sysdef-central-registry-search (system)
    1718   (let ((name (coerce-name system))
    1719         (to-remove nil)
    1720         (to-replace nil))
    1721     (block nil
    1722       (unwind-protect
    1723            (dolist (dir *central-registry*)
    1724              (let ((defaults (eval dir)))
    1725                (when defaults
    1726                  (cond ((directory-pathname-p defaults)
    1727                         (let ((file (probe-asd name defaults)))
    1728                           (when file
    1729                             (return file))))
    1730                        (t
    1731                         (restart-case
    1732                             (let* ((*print-circle* nil)
    1733                                    (message
    1734                                     (format nil
    1735                                             (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
    1736                                             system dir defaults)))
    1737                               (error message))
    1738                           (remove-entry-from-registry ()
    1739                             :report "Remove entry from *central-registry* and continue"
    1740                             (push dir to-remove))
    1741                           (coerce-entry-to-directory ()
    1742                             :report (lambda (s)
    1743                                       (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
    1744                                               (ensure-directory-pathname defaults) dir))
    1745                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    1746         ;; cleanup
    1747         (dolist (dir to-remove)
    1748           (setf *central-registry* (remove dir *central-registry*)))
    1749         (dolist (pair to-replace)
    1750           (let* ((current (car pair))
    1751                  (new (cdr pair))
    1752                  (position (position current *central-registry*)))
    1753             (setf *central-registry*
    1754                   (append (subseq *central-registry* 0 position)
    1755                           (list new)
    1756                           (subseq *central-registry* (1+ position))))))))))
    1758 (defun* make-temporary-package ()
    1759   (flet ((try (counter)
    1760            (ignore-errors
    1761              (make-package (format nil "~A~D" :asdf counter)
    1762                            :use '(:cl :asdf)))))
    1763     (do* ((counter 0 (+ counter 1))
    1764           (package (try counter) (try counter)))
    1765          (package package))))
    1767 (defun* safe-file-write-date (pathname)
    1768   ;; If FILE-WRITE-DATE returns NIL, it's possible that
    1769   ;; the user or some other agent has deleted an input file.
    1770   ;; Also, generated files will not exist at the time planning is done
    1771   ;; and calls operation-done-p which calls safe-file-write-date.
    1772   ;; So it is very possible that we can't get a valid file-write-date,
    1773   ;; and we can survive and we will continue the planning
    1774   ;; as if the file were very old.
    1775   ;; (or should we treat the case in a different, special way?)
    1776   (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
    1777       (progn
    1778         (when (and pathname *asdf-verbose*)
    1779           (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
    1780                 pathname))
    1781         0)))
    1783 (defmethod find-system ((name null) &optional (error-p t))
    1784   (declare (ignorable name))
    1785   (when error-p
    1786     (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
    1788 (defmethod find-system (name &optional (error-p t))
    1789   (find-system (coerce-name name) error-p))
    1791 (defvar *systems-being-defined* nil
    1792   "A hash-table of systems currently being defined keyed by name, or NIL")
    1793 (defvar *systems-being-operated* nil
    1794   "A boolean indicating that some systems are being operated on")
    1796 (defun* find-system-if-being-defined (name)
    1797   (when *systems-being-defined*
    1798     (gethash (coerce-name name) *systems-being-defined*)))
    1800 (defun* call-with-system-definitions (thunk)
    1801   (if *systems-being-defined*
    1802       (funcall thunk)
    1803       (let ((*systems-being-defined* (make-hash-table :test 'equal)))
    1804         (funcall thunk))))
    1806 (defmacro with-system-definitions ((&optional) &body body)
    1807   `(call-with-system-definitions #'(lambda () ,@body)))
    1809 (defun* load-sysdef (name pathname)
    1810   ;; Tries to load system definition with canonical NAME from PATHNAME.
    1811   (with-system-definitions ()
    1812     (let ((package (make-temporary-package)))
    1813       (unwind-protect
    1814            (handler-bind
    1815                ((error #'(lambda (condition)
    1816                            (error 'load-system-definition-error
    1817                                   :name name :pathname pathname
    1818                                   :condition condition))))
    1819              (let ((*package* package)
    1820                    (*default-pathname-defaults*
    1821                     ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
    1822                     (pathname-directory-pathname (translate-logical-pathname pathname)))
    1823                    (external-format (encoding-external-format (detect-encoding pathname))))
    1824                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1825                              pathname package)
    1826                (load pathname :external-format external-format)))
    1827         (delete-package package)))))
    1829 (defun* locate-system (name)
    1830   "Given a system NAME designator, try to locate where to load the system from.
    1832 FOUNDP is true when a system was found,
    1833 either a new unregistered one or a previously registered one.
    1834 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
    1835 PATHNAME when not null is a path from where to load the system,
    1836 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
    1837 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    1838 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    1839   (let* ((name (coerce-name name))
    1840          (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1841          (previous (cdr in-memory))
    1842          (previous (and (typep previous 'system) previous))
    1843          (previous-time (car in-memory))
    1844          (found (search-for-system-definition name))
    1845          (found-system (and (typep found 'system) found))
    1846          (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1847                        (and found-system (system-source-file found-system))
    1848                        (and previous (system-source-file previous))))
    1849          (foundp (and (or found-system pathname previous) t)))
    1850     (check-type found (or null pathname system))
    1851     (when foundp
    1852       (setf pathname (resolve-symlinks* pathname))
    1853       (when (and pathname (not (absolute-pathname-p pathname)))
    1854         (setf pathname (ensure-pathname-absolute pathname))
    1855         (when found-system
    1856           (%set-system-source-file pathname found-system)))
    1857       (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
    1858                                              (system-source-file previous) pathname)))
    1859         (%set-system-source-file pathname previous)
    1860         (setf previous-time nil))
    1861       (values foundp found-system pathname previous previous-time))))
    1863 (defmethod find-system ((name string) &optional (error-p t))
    1864   (with-system-definitions ()
    1865     (loop
    1866       (restart-case
    1867           (multiple-value-bind (foundp found-system pathname previous previous-time)
    1868               (locate-system name)
    1869             (declare (ignore foundp))
    1870             (when (and found-system (not previous))
    1871               (register-system found-system))
    1872             (when (and pathname
    1873                        (or (not previous-time)
    1874                            ;; don't reload if it's already been loaded,
    1875                            ;; or its filestamp is in the future which means some clock is skewed
    1876                            ;; and trying to load might cause an infinite loop.
    1877                            (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1878               (load-sysdef name pathname))
    1879             (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
    1880               (return
    1881                 (cond
    1882                   (in-memory
    1883                    (when pathname
    1884                      (setf (car in-memory) (safe-file-write-date pathname)))
    1885                    (cdr in-memory))
    1886                   (error-p
    1887                    (error 'missing-component :requires name))))))
    1888         (reinitialize-source-registry-and-retry ()
    1889           :report (lambda (s)
    1890                     (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
    1891           (initialize-source-registry))))))
    1893 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    1894   (setf fallback (coerce-name fallback)
    1895         requested (coerce-name requested))
    1896   (when (equal requested fallback)
    1897     (let ((registered (cdr (gethash fallback *defined-systems*))))
    1898       (or registered
    1899           (apply 'make-instance 'system
    1900                  :name fallback :source-file source-file keys)))))
    1902 (defun* sysdef-find-asdf (name)
    1903   ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
    1904   (find-system-fallback name "asdf" :version *asdf-version*))
    1907 ;;;; -------------------------------------------------------------------------
    1908 ;;;; Finding components
    1910 (defmethod find-component ((base string) path)
    1911   (let ((s (find-system base nil)))
    1912     (and s (find-component s path))))
    1914 (defmethod find-component ((base symbol) path)
    1915   (cond
    1916     (base (find-component (coerce-name base) path))
    1917     (path (find-component path nil))
    1918     (t    nil)))
    1920 (defmethod find-component ((base cons) path)
    1921   (find-component (car base) (cons (cdr base) path)))
    1923 (defmethod find-component ((module module) (name string))
    1924   (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
    1925     (compute-module-components-by-name module))
    1926   (values (gethash name (module-components-by-name module))))
    1928 (defmethod find-component ((component component) (name symbol))
    1929   (if name
    1930       (find-component component (coerce-name name))
    1931       component))
    1933 (defmethod find-component ((module module) (name cons))
    1934   (find-component (find-component module (car name)) (cdr name)))
    1937 ;;; component subclasses
    1939 (defclass source-file (component)
    1940   ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
    1942 (defclass cl-source-file (source-file)
    1943   ((type :initform "lisp")))
    1944 (defclass (cl-source-file)
    1945   ((type :initform "cl")))
    1946 (defclass cl-source-file.lsp (cl-source-file)
    1947   ((type :initform "lsp")))
    1948 (defclass c-source-file (source-file)
    1949   ((type :initform "c")))
    1950 (defclass java-source-file (source-file)
    1951   ((type :initform "java")))
    1952 (defclass static-file (source-file) ())
    1953 (defclass doc-file (static-file) ())
    1954 (defclass html-file (doc-file)
    1955   ((type :initform "html")))
    1957 (defmethod source-file-type ((component module) (s module))
    1958   (declare (ignorable component s))
    1959   :directory)
    1960 (defmethod source-file-type ((component source-file) (s module))
    1961   (declare (ignorable s))
    1962   (source-file-explicit-type component))
    1964 (defmethod component-relative-pathname ((component component))
    1965   (coerce-pathname
    1966    (or (slot-value component 'relative-pathname)
    1967        (component-name component))
    1968    :type (source-file-type component (component-system component))
    1969    :defaults (component-parent-pathname component)))
    1971 ;;;; -------------------------------------------------------------------------
    1972 ;;;; Operations
    1974 ;;; one of these is instantiated whenever #'operate is called
    1976 (defclass operation ()
    1977   (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
    1978    ;; T to force the inside of the specified system,
    1979    ;;   but not recurse to other systems we depend on.
    1980    ;; :ALL (or any other atom) to force all systems
    1981    ;;   including other systems we depend on.
    1982    ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    1983    ;;   to force systems named in a given list
    1984    ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    1985    (forced :initform nil :initarg :force :accessor operation-forced)
    1986    (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
    1987    (original-initargs :initform nil :initarg :original-initargs
    1988                       :accessor operation-original-initargs)
    1989    (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
    1990    (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    1991    (parent :initform nil :initarg :parent :accessor operation-parent)))
    1993 (defmethod print-object ((o operation) stream)
    1994   (print-unreadable-object (o stream :type t :identity t)
    1995     (ignore-errors
    1996       (prin1 (operation-original-initargs o) stream))))
    1998 (defmethod shared-initialize :after ((operation operation) slot-names
    1999                                      &key force force-not
    2000                                      &allow-other-keys)
    2001   ;; the &allow-other-keys disables initarg validity checking
    2002   (declare (ignorable operation slot-names force force-not))
    2003   (macrolet ((frob (x) ;; normalize forced and forced-not slots
    2004                `(when (consp (slot-value operation ',x))
    2005                   (setf (slot-value operation ',x)
    2006                         (mapcar #'coerce-name (slot-value operation ',x))))))
    2007     (frob forced) (frob forced-not))
     2357    (flet ((report-error (keyword description &rest arguments)
     2358             (call-function (or on-error 'error)
     2359                            "Invalid pathname ~S: ~*~?"
     2360                            pathname keyword description arguments)))
     2361      (macrolet ((err (constraint &rest arguments)
     2362                   `(report-error ',(intern* constraint :keyword) ,@arguments))
     2363                 (check (constraint condition &rest arguments)
     2364                   `(when ,constraint
     2365                      (unless ,condition (err ,constraint ,@arguments))))
     2366                 (transform (transform condition expr)
     2367                   `(when ,transform
     2368                      (,@(if condition `(when ,condition) '(progn))
     2369                       (setf p ,expr)))))
     2370        (etypecase p
     2371          ((or null pathname))
     2372          (string
     2373           (setf p (parse-unix-namestring
     2374                    p :defaults defaults :type type :dot-dot dot-dot
     2375                    :ensure-directory ensure-directory :want-relative want-relative))))
     2376        (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
     2377        (unless (pathnamep p) (return nil))
     2378        (check want-logical (logical-pathname-p p) "Expected a logical pathname")
     2379        (check want-physical (physical-pathname-p p) "Expected a physical pathname")
     2380        (transform ensure-physical () (translate-logical-pathname p))
     2381        (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
     2382        (check want-relative (relative-pathname-p p) "Expected a relative pathname")
     2383        (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
     2384        (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
     2385        (check ensure-absolute (absolute-pathname-p p)
     2386               "Could not make into an absolute pathname even after merging with ~S" defaults)
     2387        (check ensure-subpath (absolute-pathname-p defaults)
     2388               "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
     2389        (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
     2390        (check want-file (file-pathname-p p) "Expected a file pathname")
     2391        (check want-directory (directory-pathname-p p) "Expected a directory pathname")
     2392        (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
     2393        (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
     2394        (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
     2395        (transform wilden (not (wild-pathname-p p)) (wilden p))
     2396        (when want-existing
     2397          (let ((existing (probe-file* p :truename truename)))
     2398            (if existing
     2399                (when truename
     2400                  (return existing))
     2401                (err want-existing "Expected an existing pathname"))))
     2402        (when ensure-directories-exist (ensure-directories-exist p))
     2403        (when truename
     2404          (let ((truename (truename* p)))
     2405            (if truename
     2406                (return truename)
     2407                (err truename "Can't get a truename for pathname"))))
     2408        (transform resolve-symlinks () (resolve-symlinks p))
     2409        (transform truenamize () (truenamize p))
     2410        p))))
     2413(defun absolutize-pathnames
     2414    (pathnames &key type (resolve-symlinks *resolve-symlinks*) truename)
     2415    "Given a list of PATHNAMES where each is in the context of the next ones,
     2416try to resolve these pathnames into an absolute pathname; first gently, then harder."
     2417  (block nil
     2418    (labels ((resolve (x)
     2419               (or (when truename
     2420                     (absolute-pathname-p (truename* x)))
     2421                   (when resolve-symlinks
     2422                     (absolute-pathname-p (resolve-symlinks x)))
     2423                   (absolute-pathname-p x)
     2424                   (unless resolve-symlinks
     2425                     (absolute-pathname-p (resolve-symlinks x)))
     2426                   (unless truename
     2427                     (absolute-pathname-p (truename* x)))
     2428                   (return nil)))
     2429             (tryone (x type rest)
     2430               (resolve (or (absolute-pathname-p x)
     2431                            (subpathname (recurse rest :directory) x :type type))))
     2432             (recurse (pathnames type)
     2433               (if (null pathnames) (return nil)
     2434                   (tryone (first pathnames) type (rest pathnames)))))
     2435      (recurse pathnames type))))
     2438;;; Hook for output translations
     2439(defvar *output-translation-function* 'identity)
     2440;;;; ---------------------------------------------------------------------------
     2441;;;; Utilities related to streams
     2443(asdf/package:define-package :asdf/stream
     2444  (:recycle :asdf/stream)
     2445  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname)
     2446  (:export
     2447   #:*default-stream-element-type* #:*stderr* #:setup-stderr
     2448   #:with-safe-io-syntax #:call-with-safe-io-syntax
     2449   #:with-output #:output-string #:with-input
     2450   #:with-input-file #:call-with-input-file
     2451   #:finish-outputs #:format! #:safe-format!
     2452   #:copy-stream-to-stream #:concatenate-files
     2453   #:copy-stream-to-stream-line-by-line
     2454   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
     2455   #:slurp-stream-forms #:slurp-stream-form
     2456   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
     2457   #:eval-input #:eval-thunk #:standard-eval-thunk
     2458   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
     2459   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
     2460   #:*default-encoding* #:*utf-8-external-format*))
     2461(in-package :asdf/stream)
     2463(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
     2464  "default element-type for open (depends on the current CL implementation)")
     2466(defvar *stderr* *error-output*
     2467  "the original error output stream at startup")
     2469(defun setup-stderr ()
     2470  (setf *stderr*
     2471        #+allegro excl::*stderr*
     2472        #+clozure ccl::*stderr*
     2473        #-(or allegro clozure) *error-output*))
     2477;;; Safe syntax
     2479(defvar *standard-readtable* (copy-readtable nil))
     2481(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
     2482  "Establish safe CL reader options around the evaluation of BODY"
     2483  `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
     2485(defun* call-with-safe-io-syntax (thunk &key (package :cl))
     2486  (with-standard-io-syntax ()
     2487    (let ((*package* (find-package package))
     2488          (*readtable* *standard-readtable*)
     2489          (*read-default-float-format* 'double-float)
     2490          (*print-readably* nil)
     2491    (*read-eval* nil))
     2492      (funcall thunk))))
     2495;;; Output to a stream or string, FORMAT-style
     2497(defun* call-with-output (output function)
     2498  "Calls FUNCTION with an actual stream argument,
     2499behaving like FORMAT with respect to how stream designators are interpreted:
     2500If OUTPUT is a stream, use it as the stream.
     2501If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
     2502If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
     2503If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
     2504Otherwise, signal an error."
     2505  (etypecase output
     2506    (null
     2507     (with-output-to-string (stream) (funcall function stream)))
     2508    ((eql t)
     2509     (funcall function *standard-output*))
     2510    (stream
     2511     (funcall function output))
     2512    (string
     2513     (assert (fill-pointer output))
     2514     (with-output-to-string (stream output) (funcall function stream)))))
     2516(defmacro with-output ((output-var &optional (value output-var)) &body body)
     2517  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
     2518as per FORMAT, and evaluate BODY within the scope of this binding."
     2519  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
     2521(defun* output-string (string &optional output)
     2522  "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
     2523  (if output
     2524      (with-output (output) (princ string output))
     2525      string))
     2528;;; Input helpers
     2530(defun* call-with-input (input function)
     2531  "Calls FUNCTION with an actual stream argument, interpreting
     2532stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
     2533If INPUT is a STREAM, use it as the stream.
     2534If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
     2535If INPUT is T, use *TERMINAL-IO* as the stream.
     2536As an extension, if INPUT is a string, use it as a string-input-stream.
     2537Otherwise, signal an error."
     2538  (etypecase input
     2539    (null (funcall function *standard-input*))
     2540    ((eql t) (funcall function *terminal-io*))
     2541    (stream (funcall function input))
     2542    (string (with-input-from-string (stream input) (funcall function stream)))))
     2544(defmacro with-input ((input-var &optional (value input-var)) &body body)
     2545  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
     2546as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
     2547  `(call-with-input ,value #'(lambda (,input-var) ,@body)))
     2549(defun* call-with-input-file (pathname thunk
     2550                                       &key
     2551                                       (element-type *default-stream-element-type*)
     2552                                       (external-format :default)
     2553                                       (if-does-not-exist :error))
     2554  "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     2555Other keys are accepted but discarded."
     2556  #+gcl2.6 (declare (ignore external-format))
     2557  (with-open-file (s pathname :direction :input
     2558                     :element-type element-type
     2559                     #-gcl2.6 :external-format #-gcl2.6 external-format
     2560                     :if-does-not-exist if-does-not-exist)
     2561    (funcall thunk s)))
     2563(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
     2564  (declare (ignore element-type external-format))
     2565  `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     2568;;; Ensure output buffers are flushed
     2570(defun* finish-outputs (&rest streams)
     2571  "Finish output on the main output streams as well as any specified one.
     2572Useful for portably flushing I/O before user input or program exit."
     2573  ;; CCL notably buffers its stream output by default.
     2574  (dolist (s (append streams
     2575                     (list *stderr* *error-output* *standard-output* *trace-output*
     2576                           *debug-io* *terminal-io* *debug-io* *query-io*)))
     2577    (ignore-errors (finish-output s)))
    20082578  (values))
    2010 (defun* node-for (o c)
    2011   (cons (class-name (class-of o)) c))
    2013 (defmethod operation-ancestor ((operation operation))
    2014   (aif (operation-parent operation)
    2015        (operation-ancestor it)
    2016        operation))
    2019 (defun* make-sub-operation (c o dep-c dep-o)
    2020   "C is a component, O is an operation, DEP-C is another
    2021 component, and DEP-O, confusingly enough, is an operation
    2022 class specifier, not an operation."
    2023   (let* ((args (copy-list (operation-original-initargs o)))
    2024          (force-p (getf args :force)))
    2025     ;; note explicit comparison with T: any other non-NIL force value
    2026     ;; (e.g. :recursive) will pass through
    2027     (cond ((and (null (component-parent c))
    2028                 (null (component-parent dep-c))
    2029                 (not (eql c dep-c)))
    2030            (when (eql force-p t)
    2031              (setf (getf args :force) nil))
    2032            (apply 'make-instance dep-o
    2033                   :parent o
    2034                   :original-initargs args args))
    2035           ((subtypep (type-of o) dep-o)
    2036            o)
    2037           (t
    2038            (apply 'make-instance dep-o
    2039                   :parent o :original-initargs args args)))))
    2042 (defmethod visit-component ((o operation) (c component) data)
    2043   (unless (component-visited-p o c)
    2044     (setf (gethash (node-for o c)
    2045                    (operation-visited-nodes (operation-ancestor o)))
    2046           (cons t data))))
    2048 (defmethod component-visited-p ((o operation) (c component))
    2049   (gethash (node-for o c)
    2050            (operation-visited-nodes (operation-ancestor o))))
    2052 (defmethod (setf visiting-component) (new-value operation component)
    2053   ;; MCL complains about unused lexical variables
    2054   (declare (ignorable operation component))
    2055   new-value)
    2057 (defmethod (setf visiting-component) (new-value (o operation) (c component))
    2058   (let ((node (node-for o c))
    2059         (a (operation-ancestor o)))
    2060     (if new-value
    2061         (setf (gethash node (operation-visiting-nodes a)) t)
    2062         (remhash node (operation-visiting-nodes a)))
    2063     new-value))
    2065 (defmethod component-visiting-p ((o operation) (c component))
    2066   (let ((node (node-for o c)))
    2067     (gethash node (operation-visiting-nodes (operation-ancestor o)))))
    2069 (defmethod component-depends-on ((op-spec symbol) (c component))
    2070   ;; Note: we go from op-spec to operation via make-instance
    2071   ;; to allow for specialization through defmethod's, even though
    2072   ;; it's a detour in the default case below.
    2073   (component-depends-on (make-instance op-spec) c))
    2075 (defmethod component-depends-on ((o operation) (c component))
    2076   (cdr (assoc (type-of o) (component-in-order-to c))))
    2078 (defmethod component-self-dependencies ((o operation) (c component))
    2079   (remove-if-not
    2080    #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
    2081    (component-depends-on o c)))
    2083 (defmethod input-files ((operation operation) (c component))
    2084   (let ((parent (component-parent c))
    2085         (self-deps (component-self-dependencies operation c)))
    2086     (if self-deps
    2087         (mapcan #'(lambda (dep)
    2088                     (destructuring-bind (op name) dep
    2089                       (output-files (make-instance op)
    2090                                     (find-component parent name))))
    2091                 self-deps)
    2092         ;; no previous operations needed?  I guess we work with the
    2093         ;; original source file, then
    2094         (list (component-pathname c)))))
    2096 (defmethod input-files ((operation operation) (c module))
    2097   (declare (ignorable operation c))
    2098   nil)
    2100 (defmethod component-operation-time (o c)
    2101   (gethash (type-of o) (component-operation-times c)))
    2103 (defmethod operation-done-p ((o operation) (c component))
    2104   (let ((out-files (output-files o c))
    2105         (in-files (input-files o c))
    2106         (op-time (component-operation-time o c)))
    2107     (flet ((earliest-out ()
    2108              (reduce #'min (mapcar #'safe-file-write-date out-files)))
    2109            (latest-in ()
    2110              (reduce #'max (mapcar #'safe-file-write-date in-files))))
     2580(defun* format! (stream format &rest args)
     2581  "Just like format, but call finish-outputs before and after the output."
     2582  (finish-outputs stream)
     2583  (apply 'format stream format args)
     2584  (finish-output stream))
     2586(defun* safe-format! (stream format &rest args)
     2587  (with-safe-io-syntax ()
     2588    (ignore-errors (apply 'format! stream format args))
     2589    (finish-outputs stream))) ; just in case format failed
     2592;;; Simple Whole-Stream processing
     2595(defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
     2596  "Copy the contents of the INPUT stream into the OUTPUT stream.
     2597If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
     2598Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
     2599  (with-open-stream (input input)
     2600    (if linewise
     2601        (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
     2602               :while line :do
     2603               (when prefix (princ prefix output))
     2604               (princ line output)
     2605               (unless eof (terpri output))
     2606               (finish-output output)
     2607               (when eof (return)))
     2608        (loop
     2609          :with buffer-size = (or buffer-size 8192)
     2610          :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
     2611          :for end = (read-sequence buffer input)
     2612          :until (zerop end)
     2613          :do (write-sequence buffer output :end end)
     2614              (when (< end buffer-size) (return))))))
     2616(defun* concatenate-files (inputs output)
     2617  (with-open-file (o output :element-type '(unsigned-byte 8)
     2618                            :direction :output :if-exists :rename-and-delete)
     2619    (dolist (input inputs)
     2620      (with-open-file (i input :element-type '(unsigned-byte 8)
     2621                               :direction :input :if-does-not-exist :error)
     2622        (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
     2624(defun* slurp-stream-string (input &key (element-type 'character))
     2625  "Read the contents of the INPUT stream as a string"
     2626  (with-open-stream (input input)
     2627    (with-output-to-string (output)
     2628      (copy-stream-to-stream input output :element-type element-type))))
     2630(defun* slurp-stream-lines (input &key count)
     2631  "Read the contents of the INPUT stream as a list of lines, return those lines.
     2633Read no more than COUNT lines."
     2634  (check-type count (or null integer))
     2635  (with-open-stream (input input)
     2636    (loop :for n :from 0
     2637          :for l = (and (or (not count) (< n count))
     2638                        (read-line input nil nil))
     2639          :while l :collect l)))
     2641(defun* slurp-stream-line (input &key (at 0))
     2642  "Read the contents of the INPUT stream as a list of lines,
     2643then return the ACCESS-AT of that list of lines using the AT specifier.
     2644PATH defaults to 0, i.e. return the first line.
     2645PATH is typically an integer, or a list of an integer and a function.
     2646If PATH is NIL, it will return all the lines in the file.
     2648The stream will not be read beyond the Nth lines,
     2649where N is the index specified by path
     2650if path is either an integer or a list that starts with an integer."
     2651  (access-at (slurp-stream-lines input :count (access-at-count at)) at))
     2653(defun* slurp-stream-forms (input &key count)
     2654"Read the contents of the INPUT stream as a list of forms,
     2655and return those forms.
     2657If COUNT is null, read to the end of the stream;
     2658if COUNT is an integer, stop after COUNT forms were read.
     2660BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     2661  (check-type count (or null integer))
     2662  (loop :with eof = '#:eof
     2663        :for n :from 0
     2664        :for form = (if (and count (>= n count))
     2665                        eof
     2666                        (read-preserving-whitespace input nil eof))
     2667        :until (eq form eof) :collect form))
     2669(defun* slurp-stream-form (input &key (at 0))
     2670"Read the contents of the INPUT stream as a list of forms,
     2671then return the ACCESS-AT of these forms following the AT.
     2672AT defaults to 0, i.e. return the first form.
     2673AT is typically a list of integers.
     2674If AT is NIL, it will return all the forms in the file.
     2676The stream will not be read beyond the Nth form,
     2677where N is the index specified by path,
     2678if path is either an integer or a list that starts with an integer.
     2680BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     2681  (access-at (slurp-stream-forms input :count (access-at-count at)) at))
     2683(defun* read-file-string (file &rest keys)
     2684  "Open FILE with option KEYS, read its contents as a string"
     2685  (apply 'call-with-input-file file 'slurp-stream-string keys))
     2687(defun* read-file-lines (file &rest keys)
     2688  "Open FILE with option KEYS, read its contents as a list of lines
     2689BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     2690  (apply 'call-with-input-file file 'slurp-stream-lines keys))
     2692(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
     2693  "Open input FILE with option KEYS (except COUNT),
     2694and read its contents as per SLURP-STREAM-FORMS with given COUNT.
     2695BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     2696  (apply 'call-with-input-file file
     2697         #'(lambda (input) (slurp-stream-forms input :count count))
     2698         (remove-plist-key :count keys)))
     2700(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
     2701  "Open input FILE with option KEYS (except AT),
     2702and read its contents as per SLURP-STREAM-FORM with given AT specifier.
     2703BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     2704  (apply 'call-with-input-file file
     2705         #'(lambda (input) (slurp-stream-form input :at at))
     2706         (remove-plist-key :at keys)))
     2708(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
     2709  "Reads the specified form from the top of a file using a safe standardized syntax.
     2710Extracts the form using READ-FILE-FORM,
     2711within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
     2712  (with-safe-io-syntax (:package package)
     2713    (apply 'read-file-form pathname (remove-plist-key :package keys))))
     2715(defun* eval-input (input)
     2716  "Portably read and evaluate forms from INPUT, return the last values."
     2717  (with-input (input)
     2718    (loop :with results :with eof ='#:eof
     2719          :for form = (read input nil eof)
     2720          :until (eq form eof)
     2721          :do (setf results (multiple-value-list (eval form)))
     2722          :finally (return (apply 'values results)))))
     2724(defun* eval-thunk (thunk)
     2725  "Evaluate a THUNK of code:
     2726If a function, FUNCALL it without arguments.
     2727If a constant literal and not a sequence, return it.
     2728If a cons or a symbol, EVAL it.
     2729If a string, repeatedly read and evaluate from it, returning the last values."
     2730  (etypecase thunk
     2731    ((or boolean keyword number character pathname) thunk)
     2732    ((or cons symbol) (eval thunk))
     2733    (function (funcall thunk))
     2734    (string (eval-input thunk))))
     2736(defun* standard-eval-thunk (thunk &key (package :cl))
     2737  "Like EVAL-THUNK, but in a more standardized evaluation context."
     2738  ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
     2739  (when thunk
     2740    (with-safe-io-syntax (:package package)
     2741      (let ((*read-eval* t))
     2742        (eval-thunk thunk)))))
     2745;;; Encodings
     2747(defvar *default-encoding* :default
     2748  "Default encoding for source files.
     2749The default value :default preserves the legacy behavior.
     2750A future default might be :utf-8 or :autodetect
     2751reading emacs-style -*- coding: utf-8 -*- specifications,
     2752and falling back to utf-8 or latin1 if nothing is specified.")
     2754(defparameter *utf-8-external-format*
     2755  #+(and asdf-unicode (not clisp)) :utf-8
     2756  #+(and asdf-unicode clisp) charset:utf-8
     2757  #-asdf-unicode :default
     2758  "Default :external-format argument to pass to CL:OPEN and also
     2759CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
     2760On modern implementations, this will decode UTF-8 code points as CL characters.
     2761On legacy implementations, it may fall back on some 8-bit encoding,
     2762with non-ASCII code points being read as several CL characters;
     2763hopefully, if done consistently, that won't affect program behavior too much.")
     2765(defun* always-default-encoding (pathname)
     2766  (declare (ignore pathname))
     2767  *default-encoding*)
     2769(defvar *encoding-detection-hook* #'always-default-encoding
     2770  "Hook for an extension to define a function to automatically detect a file's encoding")
     2772(defun* detect-encoding (pathname)
     2773  (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname))
     2774      (funcall *encoding-detection-hook* pathname)
     2775      *default-encoding*))
     2777(defun* default-encoding-external-format (encoding)
     2778  (case encoding
     2779    (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
     2780    (:utf-8 *utf-8-external-format*)
     2781    (otherwise
     2782     (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
     2783     :default)))
     2785(defvar *encoding-external-format-hook*
     2786  #'default-encoding-external-format
     2787  "Hook for an extension to define a mapping between non-default encodings
     2788and implementation-defined external-format's")
     2790(defun* encoding-external-format (encoding)
     2791  (funcall *encoding-external-format-hook* encoding))
     2793;;;; ---------------------------------------------------------------------------
     2794;;;; Access to the Operating System
     2796(asdf/package:define-package :asdf/os
     2797  (:recycle :asdf/os :asdf)
     2798  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream)
     2799  (:export
     2800   #:featurep #:os-unix-p #:os-windows-p ;; features
     2801   #:getenv #:getenvp ;; environment variables
     2802   #:native-namestring #:parse-native-namestring
     2803   #:inter-directory-separator #:split-native-pathnames-string
     2804   #:getenv-pathname #:getenv-pathnames
     2805   #:getenv-absolute-directory #:getenv-absolute-directories
     2806   #:implementation-identifier ;; implementation identifier
     2807   #:implementation-type #:*implementation-type*
     2808   #:operating-system #:architecture #:lisp-version-string
     2809   #:hostname #:user-homedir #:lisp-implementation-directory
     2810   #:getcwd #:chdir #:call-with-current-directory #:with-current-directory
     2811   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
     2812   #:setup-temporary-directory
     2813   #:call-with-temporary-file #:with-temporary-file))
     2814(in-package :asdf/os)
     2816;;; Features
     2817(eval-when (:compile-toplevel :load-toplevel :execute)
     2818  (defun* featurep (x &optional (*features* *features*))
     2819    (cond
     2820      ((atom x) (and (member x *features*) t))
     2821      ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
     2822      ((eq :or (car x)) (some #'featurep (cdr x)))
     2823      ((eq :and (car x)) (every #'featurep (cdr x)))
     2824      (t (error "Malformed feature specification ~S" x))))
     2826  (defun* os-unix-p ()
     2827    (featurep '(:or :unix :cygwin :darwin)))
     2829  (defun* os-windows-p ()
     2830    (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
     2832  (defun* os-genera-p ()
     2833    (featurep :genera))
     2835  (defun* detect-os ()
     2836    (flet ((yes (yes) (pushnew yes *features*))
     2837           (no (no) (setf *features* (remove no *features*))))
    21112838      (cond
    2112         ((and (not in-files) (not out-files))
    2113          ;; arbitrary decision: an operation that uses nothing to
    2114          ;; produce nothing probably isn't doing much.
    2115          ;; e.g. operations on systems, modules that have no immediate action,
    2116          ;; but are only meaningful through traversed dependencies
    2117          t)
    2118         ((not out-files)
    2119          ;; an operation without output-files is probably meant
    2120          ;; for its side-effects in the current image,
    2121          ;; assumed to be idem-potent,
    2122          ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
    2123          (and op-time (>= op-time (latest-in))))
    2124         ((not in-files)
    2125          ;; an operation with output-files and no input-files
    2126          ;; is probably meant for its side-effects on the file-system,
    2127          ;; assumed to have to be done everytime.
    2128          ;; (I don't think there is any such case in ASDF unless extended)
    2129          nil)
    2130         (t
    2131          ;; an operation with both input and output files is assumed
    2132          ;; as computing the latter from the former,
    2133          ;; assumed to have been done if the latter are all older
    2134          ;; than the former.
    2135          ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
    2136          ;; We use >= instead of > to play nice with generated files.
    2137          ;; This opens a race condition if an input file is changed
    2138          ;; after the output is created but within the same second
    2139          ;; of filesystem time; but the same race condition exists
    2140          ;; whenever the computation from input to output takes more
    2141          ;; than one second of filesystem time (or just crosses the
    2142          ;; second). So that's cool.
    2143          (and
    2144           (every #'probe-file* in-files)
    2145           (every #'probe-file* out-files)
    2146           (>= (earliest-out) (latest-in))))))))
    2150 ;;; For 1.700 I've done my best to refactor TRAVERSE
    2151 ;;; by splitting it up in a bunch of functions,
    2152 ;;; so as to improve the collection and use-detection algorithm. --fare
    2153 ;;; The protocol is as follows: we pass around operation, dependency,
    2154 ;;; bunch of other stuff, and a force argument. Return a force flag.
    2155 ;;; The returned flag is T if anything has changed that requires a rebuild.
    2156 ;;; The force argument is a list of components that will require a rebuild
    2157 ;;; if the flag is T, at which point whoever returns the flag has to
    2158 ;;; mark them all as forced, and whoever recurses again can use a NIL list
    2159 ;;; as a further argument.
    2161 (defvar *forcing* nil
    2162   "This dynamically-bound variable is used to force operations in
    2163 recursive calls to traverse.")
    2165 (defgeneric* do-traverse (operation component collect))
    2167 (defun* resolve-dependency-name (component name &optional version)
    2168   (loop
    2169     (restart-case
    2170         (return
    2171           (let ((comp (find-component (component-parent component) name)))
    2172             (unless comp
    2173               (error 'missing-dependency
    2174                      :required-by component
    2175                      :requires name))
    2176             (when version
    2177               (unless (version-satisfies comp version)
    2178                 (error 'missing-dependency-of-version
    2179                        :required-by component
    2180                        :version version
    2181                        :requires name)))
    2182             comp))
    2183       (retry ()
    2184         :report (lambda (s)
    2185                   (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
    2186         :test
    2187         (lambda (c)
    2188           (or (null c)
    2189               (and (typep c 'missing-dependency)
    2190                    (eq (missing-required-by c) component)
    2191                    (equal (missing-requires c) name))))))))
    2193 (defun* resolve-dependency-spec (component dep-spec)
    2194   (cond
    2195     ((atom dep-spec)
    2196      (resolve-dependency-name component dep-spec))
    2197     ;; Structured dependencies --- this parses keywords.
    2198     ;; The keywords could conceivably be broken out and cleanly (extensibly)
    2199     ;; processed by EQL methods. But for now, here's what we've got.
    2200     ((eq :version (first dep-spec))
    2201      ;;
    2202      (resolve-dependency-name component (second dep-spec) (third dep-spec)))
    2203     ((eq :feature (first dep-spec))
    2204      ;; This particular subform is not documented and
    2205      ;; has always been broken in the past.
    2206      ;; Therefore no one uses it, and I'm cerroring it out,
    2207      ;; after fixing it
    2208      ;; See
    2209      (cerror "Continue nonetheless."
    2210              "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
    2211      (when (find (second dep-spec) *features* :test 'string-equal)
    2212        (resolve-dependency-name component (third dep-spec))))
    2213     (t
    2214      (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
    2216 (defun* do-one-dep (op c collect dep-op dep-c)
    2217   ;; Collects a partial plan for performing dep-op on dep-c
    2218   ;; as dependencies of a larger plan involving op and c.
    2219   ;; Returns t if this should force recompilation of those who depend on us.
    2220   ;; dep-op is an operation class name (not an operation object),
    2221   ;; whereas dep-c is a component object.n
    2222   (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
    2224 (defun* do-dep (op c collect dep-op-spec dep-c-specs)
    2225   ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
    2226   ;; as dependencies of a larger plan involving op and c.
    2227   ;; Returns t if this should force recompilation of those who depend on us.
    2228   ;; dep-op-spec is either an operation class name (not an operation object),
    2229   ;; or the magic symbol asdf:feature.
    2230   ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
    2231   ;; and the plan will succeed if that keyword is present in *feature*,
    2232   ;; or fail if it isn't
    2233   ;; (at which point c's :if-component-dep-fails will kick in).
    2234   ;; If dep-op-spec is an operation class name,
    2235   ;; then dep-c-specs specifies a list of sibling component of c,
    2236   ;; as per resolve-dependency-spec, such that operating op on c
    2237   ;; depends on operating dep-op-spec on each of them.
    2238   (cond ((eq dep-op-spec 'feature)
    2239          (if (member (car dep-c-specs) *features*)
    2240              nil
    2241              (error 'missing-dependency
    2242                     :required-by c
    2243                     :requires (list :feature (car dep-c-specs)))))
    2244         (t
    2245          (let ((flag nil))
    2246            (dolist (d dep-c-specs)
    2247              (when (do-one-dep op c collect dep-op-spec
    2248                                (resolve-dependency-spec c d))
    2249                (setf flag t)))
    2250            flag))))
    2252 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
    2254 (defun* do-collect (collect x)
    2255   (funcall collect x))
    2257 (defmethod do-traverse ((operation operation) (c component) collect)
    2258   (let ((*forcing* *forcing*)
    2259         (flag nil)) ;; return value: must we rebuild this and its dependencies?
    2260     (labels
    2261         ((update-flag (x)
    2262            (orf flag x))
    2263          (dep (op comp)
    2264            (update-flag (do-dep operation c collect op comp))))
    2265       ;; Have we been visited yet? If so, just process the result.
    2266       (aif (component-visited-p operation c)
    2267            (progn
    2268              (update-flag (cdr it))
    2269              (return-from do-traverse flag)))
    2270       ;; dependencies
    2271       (when (component-visiting-p operation c)
    2272         (error 'circular-dependency :components (list c)))
    2273       (setf (visiting-component operation c) t)
    2274       (unwind-protect
    2275            (block nil
    2276              (when (typep c 'system) ;; systems can be forced or forced-not
    2277                (let ((ancestor (operation-ancestor operation)))
    2278                  (flet ((match? (f)
    2279                           (and f (or (not (consp f)) ;; T or :ALL
    2280                                      (member (component-name c) f :test #'equal)))))
    2281                    (cond
    2282                      ((match? (operation-forced ancestor))
    2283                       (setf *forcing* t))
    2284                      ((match? (operation-forced-not ancestor))
    2285                       (return))))))
    2286              ;; first we check and do all the dependencies for the module.
    2287              ;; Operations planned in this loop will show up
    2288              ;; in the results, and are consumed below.
    2289              (let ((*forcing* nil))
    2290                ;; upstream dependencies are never forced to happen just because
    2291                ;; the things that depend on them are....
    2292                (loop
    2293                  :for (required-op . deps) :in (component-depends-on operation c)
    2294                  :do (dep required-op deps)))
    2295              ;; constituent bits
    2296              (let ((module-ops
    2297                     (when (typep c 'module)
    2298                       (let ((at-least-one nil)
    2299                             ;; This is set based on the results of the
    2300                             ;; dependencies and whether we are in the
    2301                             ;; context of a *forcing* call...
    2302                             ;; inter-system dependencies do NOT trigger
    2303                             ;; building components
    2304                             (*forcing*
    2305                              (or *forcing*
    2306                                  (and flag (not (typep c 'system)))))
    2307                             (error nil))
    2308                         (while-collecting (internal-collect)
    2309                           (dolist (kid (module-components c))
    2310                             (handler-case
    2311                                 (update-flag
    2312                                  (do-traverse operation kid #'internal-collect))
    2313                               #-genera
    2314                               (missing-dependency (condition)
    2315                                 (when (eq (module-if-component-dep-fails c)
    2316                                           :fail)
    2317                                   (error condition))
    2318                                 (setf error condition))
    2319                               (:no-error (c)
    2320                                 (declare (ignore c))
    2321                                 (setf at-least-one t))))
    2322                           (when (and (eq (module-if-component-dep-fails c)
    2323                                          :try-next)
    2324                                      (not at-least-one))
    2325                             (error error)))))))
    2326                (update-flag (or *forcing* (not (operation-done-p operation c))))
    2327                  ;; For sub-operations, check whether
    2328                  ;; the original ancestor operation was forced,
    2329                  ;; or names us amongst an explicit list of things to force...
    2330                  ;; except that this check doesn't distinguish
    2331                  ;; between all the things with a given name. Sigh.
    2332                  ;; BROKEN!
    2333                (when flag
    2334                  (let ((do-first (cdr (assoc (class-name (class-of operation))
    2335                                              (component-do-first c)))))
    2336                    (loop :for (required-op . deps) :in do-first
    2337                      :do (do-dep operation c collect required-op deps)))
    2338                  (do-collect collect (vector module-ops))
    2339                  (do-collect collect (cons operation c)))))
    2340         (setf (visiting-component operation c) nil)))
    2341     (visit-component operation c (when flag (incf *visit-count*)))
    2342     flag))
    2344 (defun* flatten-tree (l)
    2345   ;; You collected things into a list.
    2346   ;; Most elements are just things to collect again.
    2347   ;; A (simple-vector 1) indicate that you should recurse into its contents.
    2348   ;; This way, in two passes (rather than N being the depth of the tree),
    2349   ;; you can collect things with marginally constant-time append,
    2350   ;; achieving linear time collection instead of quadratic time.
    2351   (while-collecting (c)
    2352     (labels ((r (x)
    2353                (if (typep x '(simple-vector 1))
    2354                    (r* (svref x 0))
    2355                    (c x)))
    2356              (r* (l)
    2357                (map () #'r l)))
    2358       (r* l))))
    2360 (defmethod traverse ((operation operation) (c component))
    2361   (flatten-tree
    2362    (while-collecting (collect)
    2363      (let ((*visit-count* 0))
    2364        (do-traverse operation c #'collect)))))
    2366 (defmethod perform ((operation operation) (c source-file))
    2367   (sysdef-error
    2368    (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    2369    (class-of operation) (class-of c)))
    2371 (defmethod perform ((operation operation) (c module))
    2372   (declare (ignorable operation c))
    2373   nil)
    2375 (defmethod mark-operation-done ((operation operation) (c component))
    2376   (setf (gethash (type-of operation) (component-operation-times c))
    2377     (reduce #'max
    2378             (cons (get-universal-time)
    2379                   (mapcar #'safe-file-write-date (input-files operation c))))))
    2381 (defmethod perform-with-restarts (operation component)
    2382   ;; TOO verbose, especially as the default. Add your own :before method
    2383   ;; to perform-with-restart or perform if you want that:
    2384   #|(when *asdf-verbose* (explain operation component))|#
    2385   (perform operation component))
    2387 (defmethod perform-with-restarts :around (operation component)
    2388   (loop
    2389     (restart-case
    2390         (return (call-next-method))
    2391       (retry ()
    2392         :report
    2393         (lambda (s)
    2394           (format s (compatfmt "~@<Retry ~A.~@:>")
    2395                   (operation-description operation component))))
    2396       (accept ()
    2397         :report
    2398         (lambda (s)
    2399           (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2400                   (operation-description operation component)))
    2401         (mark-operation-done operation component)
    2402         (return)))))
    2404 (defmethod explain ((operation operation) (component component))
    2405   (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
    2406                 (operation-description operation component)))
    2408 (defmethod operation-description (operation component)
    2409   (format nil (compatfmt "~@<~A on ~A~@:>")
    2410           (class-of operation) component))
    2412 ;;;; -------------------------------------------------------------------------
    2413 ;;;; compile-op
    2415 (defclass compile-op (operation)
    2416   ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    2417    (on-warnings :initarg :on-warnings :accessor operation-on-warnings
    2418                 :initform *compile-file-warnings-behaviour*)
    2419    (on-failure :initarg :on-failure :accessor operation-on-failure
    2420                :initform *compile-file-failure-behaviour*)
    2421    (flags :initarg :flags :accessor compile-op-flags
    2422           :initform nil)))
    2424 (defun* output-file (operation component)
    2425   "The unique output file of performing OPERATION on COMPONENT"
    2426   (let ((files (output-files operation component)))
    2427     (assert (length=n-p files 1))
    2428     (first files)))
    2430 (defun* ensure-all-directories-exist (pathnames)
    2431    (dolist (pathname pathnames)
    2432      (ensure-directories-exist (translate-logical-pathname pathname))))
    2434 (defmethod perform :before ((operation compile-op) (c source-file))
    2435   (ensure-all-directories-exist (output-files operation c)))
    2437 (defmethod perform :after ((operation operation) (c component))
    2438   (mark-operation-done operation c))
    2440 (defgeneric* around-compile-hook (component))
    2441 (defgeneric* call-with-around-compile-hook (component thunk))
    2443 (defmethod around-compile-hook ((c component))
    2444   (cond
    2445     ((slot-boundp c 'around-compile)
    2446      (slot-value c 'around-compile))
    2447     ((component-parent c)
    2448      (around-compile-hook (component-parent c)))))
    2450 (defun ensure-function (fun &key (package :asdf))
    2451   (etypecase fun
    2452     ((or symbol function) fun)
    2453     (cons (eval `(function ,fun)))
    2454     (string (eval `(function ,(with-standard-io-syntax
    2455                                (let ((*package* (find-package package)))
    2456                                  (read-from-string fun))))))))
    2458 (defun call-around-hook (hook function)
    2459   (funcall (or (ensure-function hook) 'funcall) function))
    2461 (defmethod call-with-around-compile-hook ((c component) function)
    2462   (call-around-hook (around-compile-hook c) function))
    2464 ;;; perform is required to check output-files to find out where to put
    2465 ;;; its answers, in case it has been overridden for site policy
    2466 (defmethod perform ((operation compile-op) (c cl-source-file))
    2467   (let ((source-file (component-pathname c))
    2468         ;; on some implementations, there are more than one output-file,
    2469         ;; but the first one should always be the primary fasl that gets loaded.
    2470         (output-file (first (output-files operation c)))
    2471         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
    2472         (*compile-file-failure-behaviour* (operation-on-failure operation)))
    2473     (multiple-value-bind (output warnings-p failure-p)
    2474         (call-with-around-compile-hook
    2475          c #'(lambda (&rest flags)
    2476                (apply *compile-op-compile-file-function* source-file
    2477                       :output-file output-file
    2478                       :external-format (component-external-format c)
    2479                       (append flags (compile-op-flags operation)))))
    2480       (unless output
    2481         (error 'compile-error :component c :operation operation))
    2482       (when failure-p
    2483         (case (operation-on-failure operation)
    2484           (:warn (warn
    2485                   (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
    2486                   operation c))
    2487           (:error (error 'compile-failed :component c :operation operation))
    2488           (:ignore nil)))
    2489       (when warnings-p
    2490         (case (operation-on-warnings operation)
    2491           (:warn (warn
    2492                   (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    2493                   operation c))
    2494           (:error (error 'compile-warned :component c :operation operation))
    2495           (:ignore nil))))))
    2497 (defmethod output-files ((operation compile-op) (c cl-source-file))
    2498   (declare (ignorable operation))
    2499   (let* ((p (lispize-pathname (component-pathname c)))
    2500          (f (compile-file-pathname ;; fasl
    2501              p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
    2502          #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
    2503     #+ecl (if (use-ecl-byte-compiler-p)
    2504               (list f)
    2505               (list (compile-file-pathname p :type :object) f))
    2506     #+mkcl (list o f)
    2507     #-(or ecl mkcl) (list f)))
    2509 (defmethod perform ((operation compile-op) (c static-file))
    2510   (declare (ignorable operation c))
    2511   nil)
    2513 (defmethod output-files ((operation compile-op) (c static-file))
    2514   (declare (ignorable operation c))
    2515   nil)
    2517 (defmethod input-files ((operation compile-op) (c static-file))
    2518   (declare (ignorable operation c))
    2519   nil)
    2521 (defmethod operation-description ((operation compile-op) component)
    2522   (declare (ignorable operation))
    2523   (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
    2525 (defmethod operation-description ((operation compile-op) (component module))
    2526   (declare (ignorable operation))
    2527   (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
    2530 ;;;; -------------------------------------------------------------------------
    2531 ;;;; load-op
    2533 (defclass basic-load-op (operation) ())
    2535 (defclass load-op (basic-load-op) ())
    2537 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    2538   (loop
    2539     (restart-case
    2540         (return (call-next-method))
    2541       (try-recompiling ()
    2542         :report (lambda (s)
    2543                   (format s "Recompile ~a and try loading it again"
    2544                           (component-name c)))
    2545         (perform (make-sub-operation c o c 'compile-op) c)))))
    2547 (defmethod perform ((o load-op) (c cl-source-file))
    2548   (map () #'load
    2549        #-(or ecl mkcl)
    2550        (input-files o c)
    2551        #+(or ecl mkcl)
    2552        (loop :for i :in (input-files o c)
    2553        :unless (string= (pathname-type i) "fas")
    2554        :collect (compile-file-pathname (lispize-pathname i)))))
    2556 (defmethod perform ((operation load-op) (c static-file))
    2557   (declare (ignorable operation c))
    2558   nil)
    2560 (defmethod operation-done-p ((operation load-op) (c static-file))
    2561   (declare (ignorable operation c))
    2562   t)
    2564 (defmethod output-files ((operation operation) (c component))
    2565   (declare (ignorable operation c))
    2566   nil)
    2568 (defmethod component-depends-on ((operation load-op) (c component))
    2569   (declare (ignorable operation))
    2570   (cons (list 'compile-op (component-name c))
    2571         (call-next-method)))
    2573 (defmethod operation-description ((operation load-op) component)
    2574   (declare (ignorable operation))
    2575   (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
    2576           component))
    2578 (defmethod operation-description ((operation load-op) (component cl-source-file))
    2579   (declare (ignorable operation))
    2580   (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
    2581           component))
    2583 (defmethod operation-description ((operation load-op) (component module))
    2584   (declare (ignorable operation))
    2585   (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
    2586           component))
    2588 ;;;; -------------------------------------------------------------------------
    2589 ;;;; load-source-op
    2591 (defclass load-source-op (basic-load-op) ())
    2593 (defmethod perform ((o load-source-op) (c cl-source-file))
    2594   (declare (ignorable o))
    2595   (let ((source (component-pathname c)))
    2596     (setf (component-property c 'last-loaded-as-source)
    2597           (and (call-with-around-compile-hook
    2598                 c #'(lambda () (load source :external-format (component-external-format c))))
    2599                (get-universal-time)))))
    2601 (defmethod perform ((operation load-source-op) (c static-file))
    2602   (declare (ignorable operation c))
    2603   nil)
    2605 (defmethod output-files ((operation load-source-op) (c component))
    2606   (declare (ignorable operation c))
    2607   nil)
    2609 ;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
    2610 (defmethod component-depends-on ((o load-source-op) (c component))
    2611   (declare (ignorable o))
    2612   (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
    2613     :for (op . co) :in what-would-load-op-do
    2614     :when (eq op 'load-op) :collect (cons 'load-source-op co)))
    2616 (defmethod operation-done-p ((o load-source-op) (c source-file))
    2617   (declare (ignorable o))
    2618   (and (component-property c 'last-loaded-as-source)
    2619        (<= (safe-file-write-date (component-pathname c))
    2620            (component-property c 'last-loaded-as-source))))
    2622 (defmethod operation-description ((operation load-source-op) component)
    2623   (declare (ignorable operation))
    2624   (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
    2625           component))
    2627 (defmethod operation-description ((operation load-source-op) (component module))
    2628   (declare (ignorable operation))
    2629   (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
    2632 ;;;; -------------------------------------------------------------------------
    2633 ;;;; test-op
    2635 (defclass test-op (operation) ())
    2637 (defmethod perform ((operation test-op) (c component))
    2638   (declare (ignorable operation c))
    2639   nil)
    2641 (defmethod operation-done-p ((operation test-op) (c system))
    2642   "Testing a system is _never_ done."
    2643   (declare (ignorable operation c))
    2644   nil)
    2646 (defmethod component-depends-on :around ((o test-op) (c system))
    2647   (declare (ignorable o))
    2648   (cons `(load-op ,(component-name c)) (call-next-method)))
    2651 ;;;; -------------------------------------------------------------------------
    2652 ;;;; Invoking Operations
    2654 (defgeneric* operate (operation-class system &key &allow-other-keys))
    2655 (defgeneric* perform-plan (plan &key))
    2656 (defgeneric* plan-operates-on-p (plan component))
    2658 ;;;; Separating this into a different function makes it more forward-compatible
    2659 (defun* cleanup-upgraded-asdf (old-version)
    2660   (let ((new-version (asdf-version)))
    2661     (unless (equal old-version new-version)
    2662       (cond
    2663         ((version-satisfies new-version old-version)
    2664          (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    2665                        old-version new-version))
    2666         ((version-satisfies old-version new-version)
    2667          (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
    2668                old-version new-version))
    2669         (t
    2670          (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    2671                        old-version new-version)))
    2672       (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    2673         ;; Invalidate all systems but ASDF itself.
    2674         (setf *defined-systems* (make-defined-systems-table))