[armedbear-cvs] r12618 - in trunk/abcl: doc/asdf src/org/armedbear/lisp test/lisp/abcl test/lisp/ansi test/lisp/cl-bench
Mark Evenson
mevenson at common-lisp.net
Thu Apr 15 20:23:44 UTC 2010
Author: mevenson
Date: Thu Apr 15 16:23:44 2010
New Revision: 12618
Log:
Incorporate an ASDF2 snapshot as the base ASDF.
Added:
trunk/abcl/doc/asdf/
trunk/abcl/doc/asdf/asdf.texinfo
Removed:
trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp
Modified:
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
trunk/abcl/test/lisp/abcl/file-system-tests.lisp
trunk/abcl/test/lisp/abcl/package.lisp
trunk/abcl/test/lisp/abcl/test-utilities.lisp
trunk/abcl/test/lisp/ansi/package.lisp
trunk/abcl/test/lisp/cl-bench/wrapper.lisp
Added: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- (empty file)
+++ trunk/abcl/doc/asdf/asdf.texinfo Thu Apr 15 16:23:44 2010
@@ -0,0 +1,3120 @@
+\input texinfo @c -*- texinfo -*-
+ at c %**start of header
+ at setfilename asdf.info
+ at settitle ASDF Manual
+ at c %**end of header
+
+ at c We use @&key, etc to escape & from TeX in lambda lists --
+ at c so we need to define them for info as well.
+ at macro &allow-other-keys
+&allow-other-keys
+ at end macro
+ at macro &optional
+&optional
+ at end macro
+ at macro &rest
+&rest
+ at end macro
+ at macro &key
+&key
+ at end macro
+ at macro &body
+&body
+ at end macro
+
+ at c for install-info
+ at dircategory Software development
+ at direntry
+* asdf: (asdf). Another System Definition Facility (for Common Lisp)
+ at end direntry
+
+ at copying
+This manual describes ASDF, a system definition facility
+for Common Lisp programs and libraries.
+
+ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
+
+This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
+
+This manual revised @copyright{} 2009-2010 Robert P. Goldman and Francois-Rene Rideau.
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+``Software''), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+ at end copying
+
+
+
+ at titlepage
+ at title asdf: another system definition facility
+
+ at c The following two commands start the copyright page.
+ at page
+ at vskip 0pt plus 1filll
+ at insertcopying
+ at end titlepage
+
+ at c Output the table of contents at the beginning.
+ at contents
+
+ at c -------------------
+
+ at ifnottex
+
+ at node Top, Introduction, (dir), (dir)
+ at top asdf: another system definition facility
+
+ at insertcopying
+
+ at menu
+* Introduction::
+* Loading ASDF::
+* Configuring ASDF::
+* Using ASDF::
+* Defining systems with defsystem::
+* The object model of ASDF::
+* Controlling where ASDF searches for systems::
+* Controlling where ASDF saves compiled files::
+* Error handling::
+* Miscellaneous additional functionality::
+* Getting the latest version::
+* FAQ::
+* TODO list::
+* Inspiration::
+* Concept Index::
+* Function and Class Index::
+* Variable Index::
+
+ at c @detailmenu
+ at c --- The Detailed Node Listing ---
+
+ at c Defining systems with defsystem
+
+ at c * The defsystem form::
+ at c * A more involved example::
+ at c * The defsystem grammar::
+ at c * Other code in .asd files::
+
+ at c The object model of ASDF
+
+ at c * Operations::
+ at c * Components::
+
+ at c Operations
+
+ at c * Predefined operations of ASDF::
+ at c * Creating new operations::
+
+ at c Components
+
+ at c * Common attributes of components::
+ at c * Pre-defined subclasses of component::
+ at c * Creating new component types::
+
+ at c properties
+
+ at c * Pre-defined subclasses of component::
+ at c * Creating new component types::
+
+ at c @end detailmenu
+ at end menu
+
+ at end ifnottex
+
+ at c -------------------
+
+ at node Introduction, Loading ASDF, Top, Top
+ at comment node-name, next, previous, up
+ at chapter Introduction
+ at cindex ASDF-related features
+ at vindex *features*
+ at cindex Testing for ASDF
+ at cindex ASDF versions
+ at cindex :asdf
+ at cindex :asdf2
+
+ASDF is Another System Definition Facility:
+a tool for specifying how systems of Common Lisp software
+are comprised of components (sub-systems and files),
+and how to operate on these components in the right order
+so that they can be compiled, loaded, tested, etc.
+
+ASDF presents three faces:
+one for users of Common Lisp software who want to reuse other people's code,
+one for writers of Common Lisp software who want to specify how to build their systems,
+one for implementers of Common Lisp extensions who want to extend the build system.
+ at xref{Using ASDF,,Loading a system},
+to learn how to use ASDF to load a system.
+ at xref{Defining systems with defsystem},
+to learn how to define a system of your own.
+ at xref{The object model of ASDF}, for a description of
+the ASDF internals and how to extend ASDF.
+
+ at emph{Nota Bene}:
+We are preparing for a release of ASDF 2,
+which will have version 2.000 and later.
+Current releases, in the 1.600 series and beyond,
+should be considered as release candidates.
+We're still working on polishing the code and documentation.
+ at ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
+
+
+ at node Loading ASDF, Configuring ASDF, Introduction, Top
+ at comment node-name, next, previous, up
+ at chapter Loading ASDF
+ at vindex *central-registry*
+ at cindex link farm
+ at findex load-system
+ at findex compile-system
+ at findex test-system
+ at cindex system directory designator
+ at findex operate
+ at findex oos
+
+ at c @menu
+ at c * Installing ASDF::
+ at c @end menu
+
+
+ at section Loading a pre-installed ASDF
+
+Many Lisp implementations include a copy of ASDF.
+You can usually load this copy using Common Lisp's @code{require} function:
+
+ at lisp
+(require :asdf)
+ at end lisp
+
+Consult your Lisp implementation's documentation for details.
+
+Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
+and you can load it that way.
+
+
+ at section Checking whether ASDF is loaded
+
+To check whether ASDF is properly loaded in your current Lisp image,
+you can run this form:
+
+ at lisp
+(asdf:asdf-version)
+ at end lisp
+
+If it returns a string,
+that is the version of ASDF that is currently installed.
+
+If it raises an error,
+then either ASDF is not loaded, or
+you are using an old version of ASDF.
+
+You can check whether an old version is loaded
+by checking if the ASDF package is present.
+The form below will allow you to programmatically determine
+whether a recent version is loaded, an old version is loaded,
+or none at all:
+
+ at lisp
+(or #+asdf2 (asdf:asdf-version) #+asdf :old)
+ at end lisp
+
+If it returns a version number, that's the version of ASDF installed.
+If it returns the keyword @code{:OLD},
+then you're using an old version of ASDF (from before 1.635).
+If it returns @code{NIL} then ASDF is not installed.
+
+If you are running a version older than 1.678,
+we recommend that you load a newer ASDF using the method below.
+
+
+ at section Upgrading ASDF
+
+If your implementation does provide ASDF 2 or later,
+and you want to upgrade to a more recent version,
+just install ASDF like any other package
+(see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below),
+configure ASDF as usual (see @pxref{Configuring ASDF} below),
+and upgrade with:
+
+ at lisp
+(require :asdf)
+(asdf:load-system :asdf)
+ at end lisp
+
+If on the other hand, your implementation only provides an old ASDF,
+you will require a special configuration step and an old-style loading:
+
+ at lisp
+(require :asdf)
+(push #p"@var{/path/to/new/asdf/}" asdf:*central-registry*)
+(asdf:oos 'asdf:load-op :asdf)
+ at end lisp
+
+Don't forget the trailing @code{/} at the end of your pathname.
+
+Also, note that older versions of ASDF won't redirect their output,
+or at least won't do it according to your usual ASDF 2 configuration.
+You therefore need write access on the directory
+where you install the new ASDF,
+and make sure you're not using it
+for multiple mutually incompatible implementations.
+At worst, you may have to have multiple copies of the new ASDF,
+e.g. one per implementation installation, to avoid clashes.
+
+Finally, note that there are some limitations to upgrading ASDF:
+ at itemize
+ at item
+Any ASDF extension is invalidated, and will need to be reloaded.
+ at item
+It is safer if you upgrade ASDF and its extensions as a special step
+at the very beginning of whatever script you are running,
+before you start using ASDF to load anything else.
+ at end itemize
+
+
+ at section Loading an otherwise installed ASDF
+
+If your implementation doesn't include ASDF,
+if for some reason the upgrade somehow fails,
+does not or cannot apply to your case,
+you will have to install the file @file{asdf.lisp}
+somewhere and load it with:
+
+ at lisp
+(load "/path/to/your/installed/asdf.lisp")
+ at end lisp
+
+The single file @file{asdf.lisp} is all you normally need to use ASDF.
+
+You can extract this file from latest release tarball on the
+ at url{http://common-lisp.net/project/asdf/,ASDF website}.
+If you are daring and willing to report bugs, you can get
+the latest and greatest version of ASDF from its git repository.
+ at xref{Getting the latest version}.
+
+For maximum convenience you might want to have ASDF loaded
+whenever you start your Lisp implementation,
+for example by loading it from the startup script or dumping a custom core
+--- check your Lisp implementation's manual for details.
+
+
+ at node Configuring ASDF, Using ASDF, Loading ASDF, Top
+ at comment node-name, next, previous, up
+
+ at chapter Configuring ASDF
+
+ at section Configuring ASDF to find your systems
+
+So it may compile and load your systems, ASDF must be configured to find
+the @file{.asd} files that contain system definitions.
+
+Since ASDF 2, the preferred way to configure where ASDF finds your systems is
+the @code{source-registry} facility,
+fully described in its own chapter of this manual.
+ at xref{Controlling where ASDF searches for systems}.
+
+The default location for a user to install Common Lisp software is under
+ at file{~/.local/share/common-lisp/source/}.
+If you install software there, you don't need further configuration.
+If you're installing software yourself at a location that isn't standard,
+you have to tell ASDF where you installed it. See below.
+If you're using some tool to install software,
+the authors of that tool should already have configured ASDF.
+
+The simplest way to add a path to your search path,
+say @file{/foo/bar/baz/quux/}
+is to create the directory
+ at file{~/.config/common-lisp/source-registry.conf.d/}
+and there create a file with any name of your choice,
+for instance @file{42-bazquux.conf}
+containing the line:
+
+ at kbd{(:directory "/foo/bar/baz/quux/")}
+
+If you want all the subdirectories under @file{/foo/bar/baz/}
+to be recursively scanned for @file{.asd} files, instead use:
+
+ at kbd{(:tree "/foo/bar/baz/quux/")}
+
+Note that your Operating System distribution or your system administrator
+may already have configured system-managed libraries for you.
+
+Also note that when choosing a filename, the convention is to use
+the @file{.conf} extension
+(and a non-empty extension is required for CLISP compatibility),
+and it is customary to start the filename with two digits
+that specify the order in which the directories will be scanned.
+
+ASDF will automatically read your configuration
+the first time you try to find a system.
+You can reset the source-registry configuration with:
+
+ at lisp
+(asdf:clear-source-registry)
+ at end lisp
+
+And you probably should do so before you dump your Lisp image,
+if the configuration may change
+between the machine where you save it at the time you save it
+and the machine you resume it at the time you resume it.
+
+
+ at section Configuring ASDF to find your systems -- old style
+
+The old way to configure ASDF to find your systems is by
+ at code{push}ing directory pathnames onto the variable
+ at code{asdf:*central-registry*}.
+
+You must configure this variable between the time you load ASDF
+and the time you first try to use it.
+Loading and configuring ASDF presumably happen
+as part of some initialization script that builds or starts
+your Common Lisp software system.
+(For instance, some SBCL users used to put it in their @file{~/.sbclrc}.)
+
+The @code{asdf:*central-registry*} is empty by default in ASDF 2,
+but is still supported for compatibility with ASDF 1.
+When used, it takes precedence over the above source-registry at footnote{
+It is possible to further customize
+the system definition file search.
+That's considered advanced use, and covered later:
+search forward for
+ at code{*system-definition-search-functions*}.
+ at xref{Defining systems with defsystem}.}.
+
+For instance, if you wanted ASDF to find the @file{.asd} file
+ at file{/home/me/src/foo/foo.asd} your initialization script
+could after it loads ASDF with @code{(require :asdf)}
+configure it with:
+
+ at lisp
+(push "/home/me/src/foo/" asdf:*central-registry*)
+ at end lisp
+
+Note the trailing slash: when searching for a system,
+ASDF will evaluate each entry of the central registry
+and coerce the result to a pathname at footnote{
+ASDF will indeed call @code{EVAL} on each entry.
+It will also skip entries that evaluate to @code{NIL}.
+
+Strings and pathname objects are self-evaluating,
+in which case the @code{EVAL} step does nothing;
+but you may push arbitrary SEXP onto the central registry,
+that will be evaluated to compute e.g. things that depend
+on the value of shell variables or the identity of the user.
+
+The variable @code{asdf:*central-registry*} is thus a list of
+``system directory designators''.
+A @dfn{system directory designator} is a form
+which will be evaluated whenever a system is to be found,
+and must evaluate to a directory to look in.
+By ``directory'' here, we mean
+``designator for a pathname with a supplied DIRECTORY component''.
+}
+at which point the presence of the trailing directory name separator
+is necessary to tell Lisp that you're discussing a directory
+rather than a file.
+
+Typically, however, there are a lot of @file{.asd} files, and
+a common idiom was to have to put
+a bunch of @emph{symbolic links} to @file{.asd} files
+in a common directory
+and push @emph{that} directory (the ``link farm'')
+to the
+ at code{asdf:*central-registry*}
+instead of pushing each of the many involved directories
+to the @code{asdf:*central-registry*}.
+ASDF knows how to follow such @emph{symlinks}
+to the actual file location when resolving the paths of system components
+(on Windows, you can use Windows shortcuts instead of POSIX symlinks).
+
+For example, if @code{#p"/home/me/cl/systems/"} (note the trailing slash)
+is a member of @code{*central-registry*}, you could set up the
+system @var{foo} for loading with asdf with the following
+commands at the shell:
+
+ at example
+$ cd /home/me/cl/systems/
+$ ln -s ~/src/foo/foo.asd .
+ at end example
+
+This old style for configuring ASDF is not recommended for new users,
+but it is supported for old users, and for users who want to programmatically
+control what directories are added to the ASDF search path.
+
+
+ at section Configuring where ASDF stores object files
+ at findex clear-output-locations
+
+ASDF lets you configure where object files will be stored.
+Sensible defaults are provided and
+you shouldn't normally have to worry about it.
+
+This allows the same source code repository may be shared
+between several versions of several Common Lisp implementations,
+between several users using different compilation options
+and without write privileges on shared source directories, etc.
+This also allows to keep source directories uncluttered
+by plenty of object files.
+
+Starting with ASDF 2, the @code{asdf-output-translations} facility
+was added to ASDF itself, that controls where object files will be stored.
+This facility is fully described in a chapter of this manual,
+ at ref{Controlling where ASDF saves compiled files}.
+
+The simplest way to add a translation to your search path,
+say from @file{/foo/bar/baz/quux/}
+to @file{/where/i/want/my/fasls/}
+is to create the directory
+ at file{~/.config/common-lisp/asdf-output-translations.conf.d/}
+and there create a file with any name of your choice,
+for instance @file{42-bazquux.conf}
+containing the line:
+
+ at kbd{("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")}
+
+To disable output translations for source under a given directory,
+say @file{/toto/tata/}
+you can create a file @file{40-disable-toto.conf}
+with the line:
+
+ at kbd{("/toto/tata/")}
+
+To wholly disable output translations for all directories,
+you can create a file @file{00-disable.conf}
+with the line:
+
+ at kbd{(t t)}
+
+Note that your Operating System distribution or your system administrator
+may already have configured translations for you.
+In absence of any configuration, the default is to redirect everything
+under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}.
+ at xref{Controlling where ASDF searches for systems}, for full details.
+
+
+Also note that when choosing a filename, the convention is to use
+the @file{.conf} extension
+(and a non-empty extension is required for CLISP compatibility),
+and it is customary to start the filename with two digits
+that specify the order in which the directories will be scanned.
+
+ASDF will automatically read your configuration
+the first time you try to find a system.
+You can reset the source-registry configuration with:
+
+ at lisp
+(asdf:clear-output-translations)
+ at end lisp
+
+And you probably should do so before you dump your Lisp image,
+if the configuration may change
+between the machine where you save it at the time you save it
+and the machine you resume it at the time you resume it.
+
+Finally note that before ASDF 2,
+other ASDF add-ons offered the same functionality,
+each in subtly different and incompatible ways:
+ASDF-Binary-Locations, cl-launch, common-lisp-controller.
+ASDF-Binary-Locations is now not needed anymore and should not be used.
+cl-launch 3.0 and common-lisp-controller 7.1 have been updated
+to just delegate this functionality to ASDF.
+
+ at node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
+ at comment node-name, next, previous, up
+
+ at chapter Using ASDF
+
+ at section Loading a system
+
+The system @var{foo} is loaded (and compiled, if necessary)
+by evaluating the following Lisp form:
+
+ at example
+(asdf:load-system :@var{foo})
+ at end example
+
+On some implementations (namely, SBCL and Clozure CL),
+ASDF hooks into the @code{CL:REQUIRE} facility
+and you can just use:
+
+ at example
+(require :@var{foo})
+ at end example
+
+In older versions of ASDF, you needed to use
+ at code{(asdf:oos 'asdf:load-op :@var{foo})}.
+If your ASDF is too old to provide @code{asdf:load-system} though
+we recommend that you upgrade to ASDF 2.
+ at xref{Loading ASDF,,Loading an otherwise installed ASDF}.
+
+
+ at section Other Operations
+
+ASDF provides three commands for the most common system operations:
+ at code{load-system}, @code{compile-system} or @code{test-system}.
+
+Because ASDF is an extensible system
+for defining @emph{operations} on @emph{components},
+it also provides a generic function @code{operate}
+(which is usually abbreviated by @code{oos}).
+You'll use @code{oos} whenever you want to do something beyond
+compiling, loading and testing.
+
+Output from ASDF and ASDF extensions are supposed to be sent
+to the CL stream @code{*standard-output*},
+and so rebinding that stream around calls to @code{asdf:operate}
+should redirect all output from ASDF operations.
+
+Reminder: before ASDF can operate on a system, however,
+it must be able to find and load that system's definition.
+ at xref{Configuring ASDF,,Configuring ASDF to find your systems}.
+
+
+ at section Summary
+
+To use ASDF:
+
+ at itemize
+ at item
+Load ASDF itself into your Lisp image, either through
+ at code{(require :asdf)} or else through
+ at code{(load "/path/to/asdf.lisp")}.
+
+ at item
+Make sure ASDF can find system definitions
+thanks to proper source-registry configuration.
+
+ at item
+Load a system with @code{(load-system :my-system)}
+or use some other operation on some system of your choice.
+
+ at end itemize
+
+ at section Moving on
+
+That's all you need to know to use ASDF to load systems written by others.
+The rest of this manual deals with writing system definitions
+for Common Lisp software you write yourself,
+including how to extend ASDF to define new operation and component types.
+
+
+ at node Defining systems with defsystem, The object model of ASDF, Using ASDF, Top
+ at comment node-name, next, previous, up
+ at chapter Defining systems with defsystem
+
+This chapter describes how to use asdf to define systems and develop
+software.
+
+
+ at menu
+* The defsystem form::
+* A more involved example::
+* The defsystem grammar::
+* Other code in .asd files::
+ at end menu
+
+ at node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem
+ at comment node-name, next, previous, up
+ at section The defsystem form
+
+Systems can be constructed programmatically
+by instantiating components using @code{make-instance}.
+Most of the time, however, it is much more practical to use
+a static @code{defsystem} form.
+This section begins with an example of a system definition,
+then gives the full grammar of @code{defsystem}.
+
+Let's look at a simple system.
+This is a complete file that would
+usually be saved as @file{hello-lisp.asd}:
+
+ at lisp
+(in-package :asdf)
+
+(defsystem "hello-lisp"
+ :description "hello-lisp: a sample Lisp system."
+ :version "0.2"
+ :author "Joe User <joe@@example.com>"
+ :licence "Public Domain"
+ :components ((:file "packages")
+ (:file "macros" :depends-on ("packages"))
+ (:file "hello" :depends-on ("macros"))))
+ at end lisp
+
+Some notes about this example:
+
+ at itemize
+
+ at item
+The file starts with an @code{in-package} form
+to use package @code{asdf}.
+You could instead start your definition by using
+a qualified name @code{asdf:defsystem}.
+
+ at item
+If in addition to simply using @code{defsystem},
+you are going to define functions,
+create ASDF extension, globally bind symbols, etc.,
+it is recommended that to avoid namespace pollution between systems,
+you should create your own package for that purpose,
+for instance replacing the above @code{(in-package :asdf)} with:
+
+ at lisp
+(defpackage :foo-system
+ (:use :cl :asdf))
+
+(in-package :foo-system)
+ at end lisp
+
+ at item
+The @code{defsystem} form defines a system named @code{hello-lisp}
+that contains three source files:
+ at file{packages}, @file{macros} and @file{hello}.
+
+ at item
+The file @file{macros} depends on @file{packages}
+(presumably because the package it's in is defined in @file{packages}),
+and the file @file{hello} depends on @file{macros}
+(and hence, transitively on @file{packages}).
+This means that ASDF will compile and load @file{packages} and @file{macros}
+before starting the compilation of file @file{hello}.
+
+ at item
+The files are located in the same directory
+as the file with the system definition.
+ASDF resolves symbolic links (or Windows shortcuts)
+before loading the system definition file and
+stores its location in the resulting system at footnote{
+It is possible, though almost never necessary, to override this behaviour.}.
+This is a good thing because the user can move the system sources
+without having to edit the system definition.
+
+ at end itemize
+
+ at node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem
+ at comment node-name, next, previous, up
+ at section A more involved example
+
+Let's illustrate some more involved uses of @code{defsystem} via a
+slightly convoluted example:
+
+ at lisp
+(defsystem "foo"
+ :version "1.0"
+ :components ((:module "foo" :components ((:file "bar") (:file"baz")
+ (:file "quux"))
+ :perform (compile-op :after (op c)
+ (do-something c))
+ :explain (compile-op :after (op c)
+ (explain-something c)))
+ (:file "blah")))
+ at end lisp
+
+The method-form tokens need explaining: essentially, this part:
+
+ at lisp
+ :perform (compile-op :after (op c)
+ (do-something c))
+ :explain (compile-op :after (op c)
+ (explain-something c))
+ at end lisp
+
+has the effect of
+
+ at lisp
+(defmethod perform :after ((op compile-op) (c (eql ...)))
+ (do-something c))
+(defmethod explain :after ((op compile-op) (c (eql ...)))
+ (explain-something c))
+ at end lisp
+
+where @code{...} is the component in question;
+note that although this also supports @code{:before} methods,
+they may not do what you want them to ---
+a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
+will run after all the dependencies and sub-components have been processed,
+but before the component in question has been compiled.
+
+ at node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
+ at comment node-name, next, previous, up
+ at section The defsystem grammar
+
+ at example
+system-definition := ( defsystem system-designator @var{option}* )
+
+option := :components component-list
+ | :pathname pathname-specifier
+ | :default-component-class
+ | :perform method-form
+ | :explain method-form
+ | :output-files method-form
+ | :operation-done-p method-form
+ | :depends-on ( @var{dependency-def}* )
+ | :serial [ t | nil ]
+ | :in-order-to ( @var{dependency}+ )
+
+component-list := ( @var{component-def}* )
+
+component-def := ( component-type simple-component-name @var{option}* )
+
+component-type := :system | :module | :file | :static-file | other-component-type
+
+other-component-type := symbol-by-name (@pxref{The defsystem grammar,,Component types})
+
+dependency-def := simple-component-name
+ | ( :feature name )
+ | ( :version simple-component-name version-specifier)
+
+dependency := (dependent-op @var{requirement}+)
+requirement := (required-op @var{required-component}+)
+ | (feature feature-name)
+dependent-op := operation-name
+required-op := operation-name | feature
+
+simple-component-name := string
+ | symbol
+
+pathname-specifier := pathname | string | symbol
+
+method-form := (operation-name qual lambda-list @&rest body)
+qual := method qualifier
+ at end example
+
+ at subsection Component names
+
+Component names (@code{simple-component-name})
+may be either strings or symbols.
+
+ at subsection Component types
+
+Component type names, even if expressed as keywords, will be looked up
+by name in the current package and in the asdf package, if not found in
+the current package. So a component type @code{my-component-type}, in
+the current package @code{my-system-asd} can be specified as
+ at code{:my-component-type}, or @code{my-component-type}.
+
+ at subsection Pathname specifiers
+
+A pathname specifier (@code{pathname-specifier})
+may be a pathname, a string or a symbol.
+When no pathname specifier is given for a component,
+which is the usual case, the component name itself is used.
+
+If a string is given, which is the usual case,
+the string will be interpreted as a Unix-style pathname
+where @code{/} characters will be interpreted as directory separators.
+Usually, Unix-style relative pathnames are used
+(i.e. not starting with @code{/}, as opposed to absolute pathnames);
+they are relative to the path of the parent component.
+Finally, depending on the @code{component-type},
+the pathname may be interpreted as either a file or a directory,
+and if it's a file,
+a file type may be added corresponding to the @code{component-type},
+or else it will be extracted from the string itself (if applicable).
+
+For instance, the @code{component-type} @code{:module}
+wants a directory pathname, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar/"}.
+On the other hand, the @code{component-type} @code{:file}
+wants a file of type @code{lisp}, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar.lisp"},
+and a string @code{"foo/bar.quux"}
+will be interpreted as the pathname @file{#p"foo/bar.quux.lisp"}.
+Finally, the @code{component-type} @code{:static-file}
+wants a file without specifying a type, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar"},
+and a string @code{"foo/bar.quux"}
+will be interpreted as the pathname @file{#p"foo/bar.quux"}.
+
+If a symbol is given, it will be translated into a string,
+and downcased in the process.
+The downcasing of symbols is unconventional,
+but was selected after some consideration.
+Observations suggest that the type of systems we want to support
+either have lowercase as customary case (Unix, Mac, windows)
+or silently convert lowercase to uppercase (lpns),
+so this makes more sense than attempting to use @code{:case :common}
+as argument to @code{make-pathname},
+which is reported not to work on some implementations.
+
+Pathnames objects may be given to override the path for a component.
+Such objects are typically specified using reader macros such as @code{#p}
+or @code{#.(make-pathname ...)}.
+Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)}
+and that the behavior @code{parse-namestring} is completely non-portable,
+unless you are using Common Lisp @code{logical-pathname}s.
+(@xref{The defsystem grammar,,Warning about logical pathnames}, below.)
+Pathnames made with @code{#.(make-pathname ...)}
+can usually be done more easily with the string syntax above.
+The only case that you really need a pathname object is to override
+the component-type default file type for a given component.
+Therefore, it is a rare case that pathname objects should be used at all.
+Unhappily, ASDF 1 didn't properly support
+parsing component names as strings specifying paths with directories,
+and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
+Note that when specifying pathname objects, no magic interpretation of the pathname
+is made depending on the component type.
+On the one hand, you have to be careful to provide a pathname that correctly
+fulfills whatever constraints are required from that component type
+(e.g. naming a directory or a file with appropriate type);
+on the other hand, you can circumvent the file type that would otherwise
+be forced upon you if you were specifying a string.
+
+
+ at subsection Warning about logical pathnames
+
+To use logical pathnames,
+you will have to provide a pathname object as a @code{:pathname} specifier
+to components that use it, using such syntax as
+ at code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}.
+
+You only have to specify such logical pathname for your system or
+some top-level component, as sub-components using the usual string syntax
+for names will be properly merged with the pathname of their parent.
+The specification of a logical pathname host however is @emph{not}
+otherwise directly supported in the ASDF syntax
+for pathname specifiers as strings.
+
+Logical pathnames are not specifically recommended to newcomers,
+but are otherwise supported.
+Moreover, the @code{asdf-output-translation} layer will
+avoid trying to resolve and translate logical-pathnames,
+so you can define yourself what translations you want to use
+with the logical pathname facility.
+
+The user of logical pathnames will have to configure logical pathnames himself,
+before they may be used, and ASDF provides no specific support for that.
+
+
+ at subsection Serial dependencies
+
+If the @code{:serial t} option is specified for a module,
+ASDF will add dependencies for each each child component,
+on all the children textually preceding it.
+This is done as if by @code{:depends-on}.
+
+ at lisp
+:components ((:file "a") (:file "b") (:file "c"))
+:serial t
+ at end lisp
+
+is equivalent to
+
+ at lisp
+:components ((:file "a")
+ (:file "b" :depends-on ("a"))
+ (:file "c" :depends-on ("a" "b")))
+ at end lisp
+
+
+ at subsection Source location
+
+The @code{:pathname} option is optional in all cases for systems
+defined via @code{defsystem},
+and in the usual case the user is recommended not to supply it.
+
+Instead, ASDF follows a hairy set of rules that are designed so that
+ at enumerate
+ at item
+ at code{find-system}
+will load a system from disk
+and have its pathname default to the right place.
+ at item
+This pathname information will not be overwritten with
+ at code{*default-pathname-defaults*}
+(which could be somewhere else altogether)
+if the user loads up the @file{.asd} file into his editor
+and interactively re-evaluates that form.
+ at end enumerate
+
+If a system is being loaded for the first time,
+its top-level pathname will be set to:
+
+ at itemize
+ at item
+The host/device/directory parts of @code{*load-truename*},
+if it is bound.
+ at item
+ at code{*default-pathname-defaults*}, otherwise.
+ at end itemize
+
+If a system is being redefined, the top-level pathname will be
+
+ at itemize
+ at item
+changed, if explicitly supplied or obtained from @code{*load-truename*}
+(so that an updated source location is reflected in the system definition)
+ at item
+changed if it had previously been set from @code{*default-pathname-defaults*}
+ at item
+left as before, if it had previously been set from @code{*load-truename*}
+and @code{*load-truename*} is currently unbound
+(so that a developer can evaluate a @code{defsystem} form
+from within an editor without clobbering its source location)
+ at end itemize
+
+ at node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem
+ at section Other code in .asd files
+
+Files containing @code{defsystem} forms
+are regular Lisp files that are executed by @code{load}.
+Consequently, you can put whatever Lisp code you like into these files
+(e.g., code that examines the compile-time environment
+and adds appropriate features to @code{*features*}).
+However, some conventions should be followed,
+so that users can control certain details of execution
+of the Lisp in @file{.asd} files:
+
+ at itemize
+ at item
+Any informative output
+(other than warnings and errors,
+which are the condition system's to dispose of)
+should be sent to the standard CL stream @code{*standard-output*},
+so that users can easily control the disposition
+of output from ASDF operations.
+ at end itemize
+
+
+ at node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top
+ at comment node-name, next, previous, up
+ at chapter The object model of ASDF
+
+ASDF is designed in an object-oriented way from the ground up.
+Both a system's structure and the operations that can be performed on systems
+follow a protocol.
+ASDF is extensible to new operations and to new component types.
+This allows the addition of behaviours:
+for example, a new component could be added for Java JAR archives,
+and methods specialised on @code{compile-op} added for it
+that would accomplish the relevant actions.
+
+This chapter deals with @emph{components}, the building blocks of a system,
+and @emph{operations}, the actions that can be performed on a system.
+
+
+
+ at menu
+* Operations::
+* Components::
+ at end menu
+
+ at node Operations, Components, The object model of ASDF, The object model of ASDF
+ at comment node-name, next, previous, up
+ at section Operations
+ at cindex operation
+
+An @dfn{operation} object of the appropriate type is instantiated
+whenever the user wants to do something with a system like
+
+ at itemize
+ at item compile all its files
+ at item load the files into a running lisp environment
+ at item copy its source files somewhere else
+ at end itemize
+
+Operations can be invoked directly, or examined
+to see what their effects would be without performing them.
+ at emph{FIXME: document how!}
+There are a bunch of methods specialised on operation and component type
+that actually do the grunt work.
+
+The operation object contains whatever state is relevant for this purpose
+(perhaps a list of visited nodes, for example)
+but primarily is a nice thing to specialise operation methods on
+and easier than having them all be @code{EQL} methods.
+
+Operations are invoked on systems via @code{operate}.
+ at anchor{operate}
+ at deffn {Generic function} @code{operate} @var{operation} @var{system} @&rest @var{initargs}
+ at deffnx {Generic function} @code{oos} @var{operation} @var{system} @&rest @var{initargs}
+ at code{operate} invokes @var{operation} on @var{system}.
+ at code{oos} is a synonym for @code{operate}.
+
+ at var{operation} is a symbol that is passed, along with the supplied
+ at var{initargs}, to @code{make-instance} to create the operation object.
+ at var{system} is a system designator.
+
+The @var{initargs} are passed to the @code{make-instance} call
+when creating the operation object.
+Note that dependencies may cause the operation
+to invoke other operations on the system or its components:
+the new operations will be created
+with the same @var{initargs} as the original one.
+
+ at end deffn
+
+ at menu
+* Predefined operations of ASDF::
+* Creating new operations::
+ at end menu
+
+ at node Predefined operations of ASDF, Creating new operations, Operations, Operations
+ at comment node-name, next, previous, up
+ at subsection Predefined operations of ASDF
+
+All the operations described in this section are in the @code{asdf} package.
+They are invoked via the @code{operate} generic function.
+
+ at lisp
+(asdf:operate 'asdf:@var{operation-name} :@var{system-name} @{@var{operation-options ...}@})
+ at end lisp
+
+ at deffn Operation @code{compile-op} @&key @code{proclamations}
+
+This operation compiles the specified component.
+If proclamations are supplied, they will be proclaimed.
+This is a good place to specify optimization settings.
+
+When creating a new component type,
+you should provide methods for @code{compile-op}.
+
+When @code{compile-op} is invoked,
+component dependencies often cause some parts of the system
+to be loaded as well as compiled.
+Invoking @code{compile-op}
+does not necessarily load all the parts of the system, though;
+use @code{load-op} to load a system.
+ at end deffn
+
+ at deffn Operation @code{load-op} @&key @code{proclamations}
+
+This operation loads a system.
+
+The default methods for @code{load-op} compile files before loading them.
+For parity, your own methods on new component types should probably do so too.
+ at end deffn
+
+ at deffn Operation @code{load-source-op}
+
+This operation will load the source for the files in a module
+even if the source files have been compiled.
+Systems sometimes have knotty dependencies
+which require that sources are loaded
+before they can be compiled.
+This is how you do that.
+
+If you are creating a component type,
+you need to implement this operation --- at least, where meaningful.
+ at end deffn
+
+ at anchor{test-op}
+ at deffn Operation @code{test-op}
+
+This operation will perform some tests on the module.
+The default method will do nothing.
+The default dependency is to require
+ at code{load-op} to be performed on the module first.
+The default @code{operation-done-p} is that the operation is @emph{never} done
+---
+we assume that if you invoke the @code{test-op},
+you want to test the system, even if you have already done so.
+
+The results of this operation are not defined by ASDF.
+It has proven difficult to define how the test operation
+should signal its results to the user
+in a way that is compatible with all of the various test libraries
+and test techniques in use in the community.
+ at end deffn
+
+ at c @deffn Operation test-system-version @&key minimum
+
+ at c Asks the system whether it satisfies a version requirement.
+
+ at c The default method accepts a string, which is expected to contain of a
+ at c number of integers separated by #\. characters. The method is not
+ at c recursive. The component satisfies the version dependency if it has
+ at c the same major number as required and each of its sub-versions is
+ at c greater than or equal to the sub-version number required.
+
+ at c @lisp
+ at c (defun version-satisfies (x y)
+ at c (labels ((bigger (x y)
+ at c (cond ((not y) t)
+ at c ((not x) nil)
+ at c ((> (car x) (car y)) t)
+ at c ((= (car x) (car y))
+ at c (bigger (cdr x) (cdr y))))))
+ at c (and (= (car x) (car y))
+ at c (or (not (cdr y)) (bigger (cdr x) (cdr y))))))
+ at c @end lisp
+
+ at c If that doesn't work for your system, you can override it. I hope
+ at c you have as much fun writing the new method as @verb{|#lisp|} did
+ at c reimplementing this one.
+ at c @end deffn
+
+ at c @deffn Operation feature-dependent-op
+
+ at c An instance of @code{feature-dependent-op} will ignore any components
+ at c which have a @code{features} attribute, unless the feature combination
+ at c it designates is satisfied by @code{*features*}. This operation is
+ at c not intended to be instantiated directly, but other operations may
+ at c inherit from it.
+
+ at c @end deffn
+
+ at node Creating new operations, , Predefined operations of ASDF, Operations
+ at comment node-name, next, previous, up
+ at subsection Creating new operations
+
+ASDF was designed to be extensible in an object-oriented fashion.
+To teach ASDF new tricks, a programmer can implement the behaviour he wants
+by creating a subclass of @code{operation}.
+
+ASDF's pre-defined operations are in no way ``privileged'',
+but it is requested that developers never use the @code{asdf} package
+for operations they develop themselves.
+The rationale for this rule is that we don't want to establish a
+``global asdf operation name registry'',
+but also want to avoid name clashes.
+
+An operation must provide methods for the following generic functions
+when invoked with an object of type @code{source-file}:
+ at emph{FIXME describe this better}
+
+ at itemize
+
+ at item @code{output-files}
+The @code{output-files} method determines where the method will put its files.
+It returns two values, a list of pathnames, and a boolean.
+If the boolean is @code{T} then the pathnames are marked
+not be translated by enclosing @code{:around} methods.
+If the boolean is @code{NIL} then enclosing @code{:around} methods
+may translate these pathnames, e.g. to ensure object files
+are somehow stored in some implementation-dependent cache.
+ at item @code{perform}
+The @code{perform} method must call @code{output-files}
+to find out where to put its files,
+because the user is allowed to override.
+ at item @code{output-files}
+for local policy @code{explain}
+ at item @code{operation-done-p},
+if you don't like the default one
+
+ at end itemize
+
+Operations that print output should send that output to the standard
+CL stream @code{*standard-output*}, as the Lisp compiler and loader do.
+
+ at node Components, , Operations, The object model of ASDF
+ at comment node-name, next, previous, up
+ at section Components
+ at cindex component
+ at cindex system
+ at cindex system designator
+ at vindex *system-definition-search-functions*
+
+A @dfn{component} represents a source file or
+(recursively) a collection of components.
+A @dfn{system} is (roughly speaking) a top-level component
+that can be found via @code{find-system}.
+
+A @dfn{system designator} is a string or symbol
+and behaves just like any other component name
+(including with regard to the case conversion rules for component names).
+
+
+ at defun find-system system-designator &optional (error-p t)
+
+Given a system designator, @code{find-system} finds and returns a system.
+If no system is found, an error of type
+ at code{missing-component} is thrown,
+or @code{nil} is returned if @code{error-p} is false.
+
+To find and update systems, @code{find-system} funcalls each element
+in the @code{*system-definition-search-functions*} list,
+expecting a pathname to be returned.
+The resulting pathname is loaded if either of the following conditions is true:
+
+ at itemize
+ at item
+there is no system of that name in memory
+ at item
+the file's @code{last-modified} time exceeds the @code{last-modified} time
+of the system in memory
+ at end itemize
+
+When system definitions are loaded from @file{.asd} files,
+a new scratch package is created for them to load into,
+so that different systems do not overwrite each others operations.
+The user may also wish to (and is recommended to)
+include @code{defpackage} and @code{in-package} forms
+in his system definition files, however,
+so that they can be loaded manually if need be.
+
+The default value of @code{*system-definition-search-functions*}
+is a list of two functions.
+The first function looks in each of the directories given
+by evaluating members of @code{*central-registry*}
+for a file whose name is the name of the system and whose type is @file{asd}.
+The first such file is returned,
+whether or not it turns out to actually define the appropriate system.
+The second function does something similar,
+for the directories specified in the @code{source-registry}.
+Hence, it is strongly advised to define a system
+ at var{foo} in the corresponding file @var{foo.asd}.
+ at end defun
+
+
+ at menu
+* Common attributes of components::
+* Pre-defined subclasses of component::
+* Creating new component types::
+ at end menu
+
+ at node Common attributes of components, Pre-defined subclasses of component, Components, Components
+ at comment node-name, next, previous, up
+ at subsection Common attributes of components
+
+All components, regardless of type, have the following attributes.
+All attributes except @code{name} are optional.
+
+ at subsubsection Name
+
+A component name is a string or a symbol.
+If a symbol, its name is taken and lowercased.
+
+Unless overridden by a @code{:pathname} attribute,
+the name will be interpreted as a pathname specifier according
+to a Unix-style syntax.
+ at xref{The defsystem grammar,,Pathname specifiers}.
+
+ at subsubsection Version identifier
+
+This optional attribute is used by the @code{test-system-version} operation.
+ at xref{Predefined operations of ASDF}.
+For the default method of @code{test-system-version},
+the version should be a string of integers separated by dots,
+for example @samp{1.0.11}.
+
+ at emph{Nota Bene}:
+This operation, planned for ASDF 1,
+is still not implement yet as of ASDF 2.
+Don't hold your breath.
+
+
+ at subsubsection Required features
+
+ at emph{FIXME: This subsection seems to contradict the
+ at code{defsystem} grammar subsection,
+which doesn't provide any obvious way to specify required features.
+Furthermore, in 2009, discussions on the
+ at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+suggested that the specification of required features may be broken,
+and that no one may have been using them for a while.
+Please contact the
+ at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+if you are interested in getting this features feature fixed.}
+
+Traditionally defsystem users have used reader conditionals
+to include or exclude specific per-implementation files.
+This means that any single implementation cannot read the entire system,
+which becomes a problem if it doesn't wish to compile it,
+but instead for example to create an archive file containing all the sources,
+as it will omit to process the system-dependent sources for other systems.
+
+Each component in an asdf system may therefore specify features using
+the same syntax as @code{#+} does, and it will (somehow) be ignored for
+certain operations unless the feature conditional is a member of
+ at code{*features*}.
+
+
+ at subsubsection Dependencies
+
+This attribute specifies dependencies of the component on its siblings.
+It is optional but often necessary.
+
+There is an excitingly complicated relationship between the initarg
+and the method that you use to ask about dependencies
+
+Dependencies are between (operation component) pairs.
+In your initargs for the component, you can say
+
+ at lisp
+:in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
+ (load-op (load-op "foo")))
+ at end lisp
+
+This means the following things:
+ at itemize
+ at item
+before performing compile-op on this component, we must perform
+load-op on @var{a} and @var{b}, and compile-op on @var{c},
+ at item
+before performing @code{load-op}, we have to load @var{foo}
+ at end itemize
+
+The syntax is approximately
+
+ at verbatim
+(this-op {(other-op required-components)}+)
+
+required-components := component-name
+ | (required-components required-components)
+
+component-name := string
+ | (:version string minimum-version-object)
+ at end verbatim
+
+Side note:
+
+This is on a par with what ACL defsystem does.
+mk-defsystem is less general: it has an implied dependency
+
+ at verbatim
+ for all x, (load x) depends on (compile x)
+ at end verbatim
+
+and using a @code{:depends-on} argument to say that @var{b} depends on
+ at var{a} @emph{actually} means that
+
+ at verbatim
+ (compile b) depends on (load a)
+ at end verbatim
+
+This is insufficient for e.g. the McCLIM system, which requires that
+all the files are loaded before any of them can be compiled ]
+
+End side note
+
+In ASDF, the dependency information for a given component and operation
+can be queried using @code{(component-depends-on operation component)},
+which returns a list
+
+ at lisp
+((load-op "a") (load-op "b") (compile-op "c") ...)
+ at end lisp
+
+ at code{component-depends-on} can be subclassed for more specific
+component/operation types: these need to @code{(call-next-method)}
+and append the answer to their dependency, unless
+they have a good reason for completely overriding the default dependencies.
+
+If it weren't for CLISP, we'd be using @code{LIST} method
+combination to do this transparently.
+But, we need to support CLISP.
+If you have the time for some CLISP hacking,
+I'm sure they'd welcome your fixes.
+ at c Doesn't CLISP now support LIST method combination?
+
+ at subsubsection pathname
+
+This attribute is optional and if absent (which is the usual case),
+the component name will be used.
+
+ at xref{The defsystem grammar,,Pathname specifiers},
+for an explanation of how this attribute is interpreted.
+
+Note that the @code{defsystem} macro (used to create a ``top-level'' system)
+does additional processing to set the filesystem location of
+the top component in that system.
+This is detailed elsewhere. @xref{Defining systems with defsystem}.
+
+The answer to the frequently asked question
+``how do I create a system definition
+where all the source files have a @file{.cl} extension''
+is thus
+
+ at lisp
+(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys))))
+ "cl")
+ at end lisp
+
+ at subsubsection properties
+
+This attribute is optional.
+
+Packaging systems often require information about files or systems
+in addition to that specified by ASDF's pre-defined component attributes.
+Programs that create vendor packages out of ASDF systems therefore
+have to create ``placeholder'' information to satisfy these systems.
+Sometimes the creator of an ASDF system may know the additional
+information and wish to provide it directly.
+
+ at code{(component-property component property-name)} and
+associated @code{setf} method will allow
+the programmatic update of this information.
+Property names are compared as if by @code{EQL},
+so use symbols or keywords or something.
+
+ at menu
+* Pre-defined subclasses of component::
+* Creating new component types::
+ at end menu
+
+ at node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components
+ at comment node-name, next, previous, up
+ at subsection Pre-defined subclasses of component
+
+ at deffn Component source-file
+
+A source file is any file that the system does not know how to
+generate from other components of the system.
+
+Note that this is not necessarily the same thing as
+``a file containing data that is typically fed to a compiler''.
+If a file is generated by some pre-processor stage
+(e.g. a @file{.h} file from @file{.h.in} by autoconf)
+then it is not, by this definition, a source file.
+Conversely, we might have a graphic file
+that cannot be automatically regenerated,
+or a proprietary shared library that we received as a binary:
+these do count as source files for our purposes.
+
+Subclasses of source-file exist for various languages.
+ at emph{FIXME: describe these.}
+ at end deffn
+
+ at deffn Component module
+
+A module is a collection of sub-components.
+
+A module component has the following extra initargs:
+
+ at itemize
+ at item
+ at code{:components} the components contained in this module
+
+ at item
+ at code{:default-component-class}
+All children components which don't specify their class explicitly
+are inferred to be of this type.
+
+ at item
+ at code{:if-component-dep-fails}
+This attribute takes one of the values
+ at code{:fail}, @code{:try-next}, @code{:ignore},
+its default value is @code{:fail}.
+The other values can be used for implementing conditional compilation
+based on implementation @code{*features*},
+for the case where it is not necessary for all files in a module to be
+compiled.
+ at emph{FIXME: such conditional compilation has been reported
+to be broken in 2009.}
+
+ at item
+ at code{:serial} When this attribute is set,
+each subcomponent of this component is assumed to depend on all subcomponents
+before it in the list given to @code{:components}, i.e.
+all of them are loaded before a compile or load operation is performed on it.
+
+ at end itemize
+
+The default operation knows how to traverse a module, so
+most operations will not need to provide methods specialised on modules.
+
+ at code{module} may be subclassed to represent components such as
+foreign-language linked libraries or archive files.
+ at end deffn
+
+ at deffn Component system
+
+ at code{system} is a subclass of @code{module}.
+
+A system is a module with a few extra attributes for documentation
+purposes; these are given elsewhere.
+ at xref{The defsystem grammar}.
+
+Users can create new classes for their systems:
+the default @code{defsystem} macro takes a @code{:class} keyword argument.
+ at end deffn
+
+ at node Creating new component types, , Pre-defined subclasses of component, Components
+ at comment node-name, next, previous, up
+ at subsection Creating new component types
+
+New component types are defined by subclassing one of the existing
+component classes and specializing methods on the new component class.
+
+ at emph{FIXME: this should perhaps be explained more throughly,
+not only by example ...}
+
+As an example, suppose we have some implementation-dependent
+functionality that we want to isolate
+in one subdirectory per Lisp implementation our system supports.
+We create a subclass of
+ at code{cl-source-file}:
+
+ at lisp
+(defclass unportable-cl-source-file (cl-source-file)
+ ())
+ at end lisp
+
+A hypothetical function @code{system-dependent-dirname}
+gives us the name of the subdirectory.
+All that's left is to define how to calculate the pathname
+of an @code{unportable-cl-source-file}.
+
+ at lisp
+(defmethod component-pathname ((component unportable-cl-source-file))
+ (let ((pathname (call-next-method))
+ (name (string-downcase (system-dependent-dirname))))
+ (merge-pathnames*
+ (make-pathname :directory (list :relative name))
+ pathname)))
+ at end lisp
+
+The new component type is used in a @code{defsystem} form in this way:
+
+ at lisp
+(defsystem :foo
+ :components
+ ((:file "packages")
+ ...
+ (:unportable-cl-source-file "threads"
+ :depends-on ("packages" ...))
+ ...
+ )
+ at end lisp
+
+ at node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top
+ at comment node-name, next, previous, up
+ at chapter Controlling where ASDF searches for systems
+
+ at section Configurations
+
+Configurations specify paths where to find system files.
+
+ at enumerate
+
+ at item
+The search registry may use some hardcoded wrapping registry specification.
+This allows some implementations (notably SBCL) to specify where to find
+some special implementation-provided systems that
+need to precisely match the version of the implementation itself.
+
+ at item
+An application may explicitly initialize the source-registry configuration
+using the configuration API
+(@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below)
+in which case this takes precedence.
+It may itself compute this configuration from the command-line,
+from a script, from its own configuration file, etc.
+
+ at item
+The source registry will be configured from
+the environment variable @code{CL_SOURCE_REGISTRY} if it exists.
+
+ at item
+The source registry will be configured from
+user configuration file
+ at file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf}
+(which defaults to
+ at file{~/.config/common-lisp/source-registry.conf})
+if it exists.
+
+ at item
+The source registry will be configured from
+user configuration directory
+ at file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/}
+(which defaults to
+ at file{~/.config/common-lisp/source-registry.conf.d/})
+if it exists.
+
+ at item
+The source registry will be configured from
+system configuration file
+ at file{/etc/common-lisp/source-registry.conf}
+if it exists/
+
+ at item
+The source registry will be configured from
+system configuration directory
+ at file{/etc/common-lisp/source-registry.conf.d/}
+if it exists.
+
+ at item
+The source registry will be configured from a default configuration.
+This configuration may allow for implementation-specific systems
+to be found, for systems to be found the current directory
+(at the time that the configuration is initialized) as well as
+ at code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
+ at code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}.
+
+ at end enumerate
+
+Each of these configuration is specified as a SEXP
+in a trival domain-specific language (defined below).
+Additionally, a more shell-friendly syntax is available
+for the environment variable (defined yet below).
+
+Each of these configurations is only used if the previous
+configuration explicitly or implicitly specifies that it
+includes its inherited configuration.
+
+Additionally, some implementation-specific directories
+may be automatically prepended to whatever directories are specified
+in configuration files, no matter if the last one inherits or not.
+
+ at section XDG base directory
+
+Note that we purport to respect the XDG base directory specification
+as to where configuration files are located,
+where data files are located,
+where output file caches are located.
+Mentions of XDG variables refer to that document.
+
+ at uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
+
+This specification allows the user to specify some environment variables
+to customize how applications behave to his preferences.
+
+On Windows platforms, when not using Cygwin,
+instead of the XDG base directory specification,
+we try to use folder configuration from the registry regarding
+ at code{Common AppData} and similar directories.
+However, support querying the Windows registry is limited as of ASDF 2,
+and on many implementations, we may fall back to always using the defaults
+without consulting the registry.
+Patches welcome.
+
+ at section Backward Compatibility
+
+For backward compatibility as well as for a practical backdoor for hackers,
+ASDF will first search for @code{.asd} files in the directories specified in
+ at code{asdf:*central-registry*}
+before it searches in the source registry above.
+
+ at xref{Configuring ASDF,,Configuring ASDF to find your systems -- old style}.
+
+By default, @code{asdf:*central-registry*} will be empty.
+
+This old mechanism will therefore not affect you if you don't use it,
+but will take precedence over the new mechanism if you do use it.
+
+ at section Configuration DSL
+
+Here is the grammar of the SEXP DSL for source-registry configuration:
+
+ at example
+;; A configuration is single SEXP starting with keyword :source-registry
+;; followed by a list of directives.
+CONFIGURATION := (:source-registry DIRECTIVE ...)
+
+;; A directive is one of the following:
+DIRECTIVE :=
+ ;; add a single directory to be scanned (no recursion)
+ (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
+
+ ;; add a directory hierarchy, recursing but excluding specified patterns
+ (:tree DIRECTORY-PATHNAME-DESIGNATOR) |
+
+ ;; override the default defaults for exclusion patterns
+ (:exclude PATTERN ...) |
+
+ ;; splice the parsed contents of another config file
+ (:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
+
+ ;; Your configuration expression MUST contain
+ ;; exactly one of either of these:
+ :inherit-configuration | ; splices contents of inherited configuration
+ :ignore-inherited-configuration | ; drop contents of inherited configuration
+
+ ;; This directive specifies that some default must be spliced.
+ :default-registry
+
+PATTERN := a string without wildcards, that will be matched exactly
+ against the name of a any subdirectory in the directory component
+ of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
+ at end example
+
+
+ at section Configuration Directories
+
+Configuration directories consist in files each contains
+a list of directives without any enclosing @code{(:source-registry ...)} form.
+The files will be sorted by namestring as if by @code{string<} and
+the lists of directives of these files with be concatenated in order.
+An implicit @code{:inherit-configuration} will be included
+at the end of the list.
+
+This allows for packaging software that has file granularity
+(e.g. Debian's @code{dpkg} or some future version of @code{clbuild})
+to easily include configuration information about distributed software.
+
+The convention is that, for sorting purposes,
+the names of files in such a directory begin with two digits
+that determine the order in which these entries will be read.
+Also, the type of these files is conventionally @code{"conf"}
+and as a limitation to some implementations (e.g. GNU clisp),
+the type cannot be @code{NIL}.
+
+Directories may be included by specifying a directory pathname
+or namestring in an @code{:include} directive, e.g.:
+
+ at example
+ (:include "/foo/bar/")
+ at end example
+
+
+ at section Shell-friendly syntax for configuration
+
+When considering environment variable @code{CL_SOURCE_REGISTRY}
+ASDF will skip to next configuration if it's an empty string.
+It will @code{READ} the string as a SEXP in the DSL
+if it begins with a paren @code{(}
+and it will be interpreted much like @code{TEXINPUTS}
+list of paths, where
+
+ * paths are separated
+ by a @code{:} (colon) on Unix platforms (including cygwin),
+ by a @code{;} (semicolon) on other platforms (mainly, Windows).
+
+ * each entry is a directory to add to the search path.
+
+ * if the entry ends with a double slash @code{//}
+ then it instead indicates a tree in the subdirectories
+ of which to recurse.
+
+ * if the entry is the empty string (which may only appear once),
+ then it indicates that the inherited configuration should be
+ spliced there.
+
+
+ at section Search Algorithm
+
+In case that isn't clear, the semantics of the configuration is that
+when searching for a system of a given name,
+directives are processed in order.
+
+When looking in a directory, if the system is found, the search succeeds,
+otherwise it continues.
+
+When looking in a tree, if one system is found, the search succeeds.
+If multiple systems are found, the consequences are unspecified:
+the search may succeed with any of the found systems,
+or an error may be raised.
+ASDF currently returns the first system found,
+XCVB currently raised an error.
+If none is found, the search continues.
+
+Exclude statements specify patterns of subdirectories the systems of which
+to ignore. Typically you don't want to use copies of files kept by such
+version control systems as Darcs.
+
+Include statements cause the search to recurse with the path specifications
+from the file specified.
+
+An inherit-configuration statement cause the search to recurse with the path
+specifications from the next configuration
+(@pxref{Controlling where ASDF searches for systems,,Configurations} above).
+
+
+ at section Caching Results
+
+The implementation is allowed to either eagerly compute the information
+from the configurations and file system, or to lazily re-compute it
+every time, or to cache any part of it as it goes.
+To explicitly flush any information cached by the system, use the API below.
+
+
+ at section Configuration API
+
+The specified functions are exported from your build system's package.
+Thus for ASDF the corresponding functions are in package ASDF,
+and for XCVB the corresponding functions are in package XCVB.
+
+ at defun initialize-source-registry @&optional PARAMETER
+ will read the configuration and initialize all internal variables.
+ You may extend or override configuration
+ from the environment and configuration files
+ with the given @var{PARAMETER}, which can be
+ @code{NIL} (no configuration override),
+ or a SEXP (in the SEXP DSL),
+ a string (as in the string DSL),
+ a pathname (of a file or directory with configuration),
+ or a symbol (fbound to function that when called returns one of the above).
+ at end defun
+
+ at defun clear-source-registry
+ undoes any source registry configuration
+ and clears any cache for the search algorithm.
+ You might want to call that before you
+ dump an image that would be resumed with a different configuration,
+ and return an empty configuration.
+ Note that this does not include clearing information about
+ systems defined in the current image, only about
+ where to look for systems not yet defined.
+ at end defun
+
+ at defun ensure-source-registry @&optional PARAMETER
+ checks whether a source registry has been initialized.
+ If not, initialize it with the given @var{PARAMETER}.
+ at end defun
+
+
+ at section Future
+
+If this mechanism is successful, in the future, we may declare
+ at code{asdf:*central-registry*} obsolete and eventually remove it.
+Any hook into implementation-specific search mechanisms will by then
+have been integrated in the @code{:default-configuration} which everyone
+should either explicitly use or implicit inherit. Some shell syntax
+for it should probably be added somehow.
+
+But we're not there yet. For now, let's see how practical this new
+source-registry is.
+
+
+ at section Rejected ideas
+
+Alternatives I considered and rejected included:
+
+ at enumerate
+ at item Keep @code{asdf:*central-registry*} as the master with its current semantics,
+ and somehow the configuration parser expands the new configuration
+ language into a expanded series of directories of subdirectories to
+ lookup, pre-recursing through specified hierarchies. This is kludgy,
+ and leaves little space of future cleanups and extensions.
+
+ at item Keep @code{asdf:*central-registry*} remains the master but extend its semantics
+ in completely new ways, so that new kinds of entries may be implemented
+ as a recursive search, etc. This seems somewhat backwards.
+
+ at item Completely remove @code{asdf:*central-registry*}
+ and break backwards compatibility.
+ Hopefully this will happen in a few years after everyone migrate to
+ a better ASDF and/or to XCVB, but it would be very bad to do it now.
+
+ at item Replace @code{asdf:*central-registry*} by a symbol-macro with appropriate magic
+ when you dereference it or setf it. Only the new variable with new
+ semantics is handled by the new search procedure.
+ Complex and still introduces subtle semantic issues.
+ at end enumerate
+
+
+I've been suggested the below features, but have rejected them,
+for the sake of keeping ASDF no more complex than strictly necessary.
+
+ at itemize
+ at item
+ More syntactic sugar: synonyms for the configuration directives, such as
+ @code{(:add-directory X)} for @code{(:directory X)}, or @code{(:add-directory-hierarchy X)}
+ or @code{(:add-directory X :recurse t)} for @code{(:tree X)}.
+
+ at item
+ The possibility to register individual files instead of directories.
+
+ at item
+ Integrate Xach Beane's tilde expander into the parser,
+ or something similar that is shell-friendly or shell-compatible.
+ I'd rather keep ASDF minimal. But maybe this precisely keeps it
+ minimal by removing the need for evaluated entries that ASDF has?
+ i.e. uses of @code{USER-HOMEDIR-PATHNAME} and @code{$SBCL_HOME}
+ Hopefully, these are already superseded by the @code{:default-registry}
+
+ at item
+ Using the shell-unfriendly syntax @code{/**} instead of @code{//} to specify recursion
+ down a filesystem tree in the environment variable.
+ It isn't that Lisp friendly either.
+ at end itemize
+
+ at section TODO
+
+ at itemize
+ at item Add examples
+ at end itemize
+
+
+ at section Credits for the source-registry
+
+Thanks a lot to Stelian Ionescu for the initial idea.
+
+Thanks to Rommel Martinez for the initial implementation attempt.
+
+All bad design ideas and implementation bugs are to mine, not theirs.
+But so are good design ideas and elegant implementation tricks.
+
+ --- Francois-Rene Rideau @email{fare@@tunes.org}, Mon, 22 Feb 2010 00:07:33 -0500
+
+
+
+ at node Controlling where ASDF saves compiled files, Error handling, Controlling where ASDF searches for systems, Top
+ at comment node-name, next, previous, up
+ at chapter Controlling where ASDF saves compiled files
+ at cindex asdf-output-translations
+ at vindex ASDF_OUTPUT_TRANSLATIONS
+
+Each Common Lisp implementation has its own format
+for compiled files (fasls for short, short for ``fast loading'').
+If you use multiple implementations
+(or multiple versions of the same implementation),
+you'll soon find your source directories
+littered with various @file{fasl}s, @file{dfsl}s, @file{cfsl}s and so on.
+Worse yet, some implementations use the same file extension
+while changing formats from version to version (or platform to platform)
+which means that you'll have to recompile binaries
+as you switch from one implementation to the next.
+
+ASDF 2 includes the @code{asdf-output-translations} facility
+to mitigate the problem.
+
+ at section Configurations
+
+Configurations specify mappings from input locations to output locations.
+Once again we rely on the XDG base directory specification for configuration.
+ at xref{Controlling where ASDF searches for systems,,XDG base directory}.
+
+ at enumerate
+
+ at item
+Some hardcoded wrapping output translations configuration may be used.
+This allows special output translations (or usually, invariant directories)
+to be specified corresponding to the similar special entries in the source registry.
+
+ at item
+An application may explicitly initialize the output-translations
+configuration using the Configuration API
+in which case this takes precedence.
+(@pxref{Controlling where ASDF saves compiled files,,Configuration API}.)
+It may itself compute this configuration from the command-line,
+from a script, from its own configuration file, etc.
+
+ at item
+The source registry will be configured from
+the environment variable @code{ASDF_OUTPUT_TRANSLATIONS} if it exists.
+
+ at item
+The source registry will be configured from
+user configuration file
+ at file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf}
+(which defaults to
+ at file{~/.config/common-lisp/asdf-output-translations.conf})
+if it exists.
+
+ at item
+The source registry will be configured from
+user configuration directory
+ at file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/}
+(which defaults to
+ at file{~/.config/common-lisp/asdf-output-translations.conf.d/})
+if it exists.
+
+ at item
+The source registry will be configured from
+system configuration file
+ at file{/etc/common-lisp/asdf-output-translations.conf}
+if it exists.
+
+ at item
+The source registry will be configured from
+system configuration directory
+ at file{/etc/common-lisp/asdf-output-translations.conf.d/}
+if it exists.
+
+ at end enumerate
+
+Each of these configurations is specified as a SEXP
+in a trival domain-specific language (defined below).
+Additionally, a more shell-friendly syntax is available
+for the environment variable (defined yet below).
+
+Each of these configurations is only used if the previous
+configuration explicitly or implicitly specifies that it
+includes its inherited configuration.
+
+Note that by default, a per-user cache is used for output files.
+This allows the seamless use of shared installations of software
+between several users, and takes files out of the way of the developers
+when they browse source code,
+at the expense of taking a small toll when developers have to clean up
+output files and find they need to get familiar with output-translations first.
+
+
+ at section Backward Compatibility
+
+ at c FIXME -- I think we should provide an easy way
+ at c to get behavior equivalent to A-B-L and
+ at c I will propose a technique for doing this.
+
+We purposefully do NOT provide backward compatibility with earlier versions of
+ at code{ASDF-Binary-Locations} (8 Sept 2009),
+ at code{common-lisp-controller} (7.0) or
+ at code{cl-launch} (2.35),
+each of which had similar general capabilities.
+The previous APIs of these programs were not designed
+for configuration by the end-user
+in an easy way with configuration files.
+Recent versions of same packages use
+the new @code{asdf-output-translations} API as defined below:
+ at code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00);
+ at code{ASDF-Binary-Locations} is fully superseded and not to be used anymore.
+
+This incompatibility shouldn't inconvenience many people.
+Indeed, few people use and customize these packages;
+these few people are experts who can trivially adapt to the new configuration.
+Most people are not experts, could not properly configure these features
+(except inasmuch as the default configuration of
+ at code{common-lisp-controller} and/or @code{cl-launch}
+might have been doing the right thing for some users),
+and yet will experience software that ``just works'',
+as configured by the system distributor, or by default.
+
+Nevertheless, if you are a fan of @code{ASDF-Binary-Locations},
+we provide a limited emulation mode:
+
+ at defun asdf:enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
+This function will initialize the new @code{asdf-output-translations} facility in a way
+that emulates the behavior of the old @code{ASDF-Binary-Locations} facility.
+Where you would previously set global variables
+ at var{*centralize-lisp-binaries*},
+ at var{*default-toplevel-directory*},
+ at var{*include-per-user-information*},
+ at var{*map-all-source-files*} or @var{*source-to-target-mappings*}
+you will now have to pass the same values as keyword arguments to this function.
+Note however that as an extension the @code{:source-to-target-mappings} keyword argument
+will accept any valid pathname designator for @code{asdf-output-translations}
+instead of just strings and pathnames.
+ at end defun
+
+If you insist, you can also keep using the old @code{ASDF-Binary-Locations}
+(the one available as an extension to load of top of ASDF,
+not the one built into a few old versions of ASDF),
+but first you must disable @code{asdf-output-translations}
+with @code{(asdf:disable-output-translations)},
+or you might experience ``interesting'' issues.
+
+Also, note that output translation is enabled by default.
+To disable it, use @code{(asdf:disable-output-translations)}.
+
+
+ at section Configuration DSL
+
+Here is the grammar of the SEXP DSL
+for @code{asdf-output-translations} configuration:
+
+ at verbatim
+;; A configuration is single SEXP starting with keyword :source-registry
+;; followed by a list of directives.
+CONFIGURATION := (:output-translations DIRECTIVE ...)
+
+;; A directive is one of the following:
+DIRECTIVE :=
+ ;; include a configuration file or directory
+ (:include PATHNAME-DESIGNATOR) |
+
+ ;; Your configuration expression MUST contain
+ ;; exactly one of either of these:
+ :inherit-configuration | ; splices contents of inherited configuration
+ :ignore-inherited-configuration | ; drop contents of inherited configuration
+
+ ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
+ :enable-user-cache |
+ ;; Disable global cache. Map / to /
+ :disable-cache |
+
+ ;; add a single directory to be scanned (no recursion)
+ (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR)
+
+ ;; use a function to return the translation of a directory designator
+ (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))
+
+DIRECTORY-DESIGNATOR :=
+ T | ;; as source matches anything, as destination leaves pathname unmapped.
+ ABSOLUTE-COMPONENT-DESIGNATOR |
+ (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
+
+ABSOLUTE-COMPONENT-DESIGNATOR :=
+ NULL | ;; As source: skip this entry. As destination: same as source
+ :ROOT | ;; magic: paths that are relative to the root of the source host and device
+ STRING | ;; namestring (directory is assumed, better be absolute or bust, ``/**/*.*'' added)
+ PATHNAME | ;; pathname (better be an absolute directory or bust)
+ :HOME | ;; designates the user-homedir-pathname ~/
+ :USER-CACHE | ;; designates the default location for the user cache
+ :SYSTEM-CACHE | ;; designates the default location for the system cache
+ :CURRENT-DIRECTORY ;; the current directory
+
+RELATIVE-COMPONENT-DESIGNATOR :=
+ STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
+ PATHNAME | ;; pathname unless last component, directory is assumed.
+ :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+ :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
+ :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute
+ :UID | ;; current UID -- not available on Windows
+ :USER ;; current USER name -- NOT IMPLEMENTED(!)
+
+TRANSLATION-FUNCTION :=
+ SYMBOL | ;; symbol of a function that takes two arguments,
+ ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR
+ LAMBDA ;; A form which evalutates to a function taking two arguments consisting of
+ ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR
+
+ at end verbatim
+
+Relative components better be either relative
+or subdirectories of the path before them, or bust.
+
+The last component, if not a pathname, is notionally completed by @file{/**/*.*}.
+You can specify more fine-grained patterns
+by using a pathname object as the last component
+e.g. @file{#p"some/path/**/foo*/bar-*.fasl"}
+
+You may use @code{#+features} to customize the configuration file.
+
+The second designator of a mapping may be @code{NIL}, indicating that files are not mapped
+to anything but themselves (same as if the second designator was the same as the first).
+
+When the first designator is @code{t},
+the mapping always matches.
+When the first designator starts with @code{:root},
+the mapping matches any host and device.
+In either of these cases, if the second designator
+isn't @code{t} and doesn't start with @code{:root},
+then strings indicating the host and pathname are somehow copied
+in the beginning of the directory component of the source pathname
+before it is translated.
+
+When the second designator is @code{t}, the mapping is the identity.
+When the second designator starts with @code{root},
+the mapping preserves the host and device of the original pathname.
+
+ at code{:include} statements cause the search to recurse with the path specifications
+from the file specified.
+
+If the @code{translate-pathname} mechanism cannot achieve a desired
+translation, the user may provide a function which provides the
+required algorithim. Such a translation function is specified by
+supplying a list as the second @code{directory-designator}
+the first element of which is the keyword @code{:function},
+and the second element of which is
+either a symbol which designates a function or a lambda expression.
+The function designated by the second argument must take two arguments,
+the first being the pathname of the source file,
+the second being the wildcard that was matched.
+The result of the function invocation should be the translated pathname.
+
+An @code{:inherit-configuration} statement cause the search to recurse with the path
+specifications from the next configuration.
+ at xref{Controlling where ASDF saves compiled files,,Configurations}, above.
+
+ at itemize
+ at item
+ at code{:enable-user-cache} is the same as @code{(t :user-cache)}.
+ at item
+ at code{:disable-cache} is the same as @code{(t t)}.
+ at item
+ at code{:user-cache} uses the contents of variable @code{asdf::*user-cache*}
+which by default is the same as using
+ at code{(:home ".cache" "common-lisp" :implementation)}.
+ at item
+ at code{:system-cache} uses the contents of variable @code{asdf::*system-cache*}
+which by default is the same as using
+ at code{("/var/cache/common-lisp" :uid :implementation-type)}
+(on Unix and cygwin), or something semi-sensible on Windows.
+ at end itemize
+
+
+ at section Configuration Directories
+
+Configuration directories consist in files each contains
+a list of directives without any enclosing
+ at code{(:output-translations ...)} form.
+The files will be sorted by namestring as if by @code{string<} and
+the lists of directives of these files with be concatenated in order.
+An implicit @code{:inherit-configuration} will be included
+at the end of the list.
+
+This allows for packaging software that has file granularity
+(e.g. Debian's @command{dpkg} or some future version of @command{clbuild})
+to easily include configuration information about software being distributed.
+
+The convention is that, for sorting purposes,
+the names of files in such a directory begin with two digits
+that determine the order in which these entries will be read.
+Also, the type of these files is conventionally @code{"conf"}
+and as a limitation of some implementations, the type cannot be @code{NIL}.
+
+Directories may be included by specifying a directory pathname
+or namestring in an @code{:include} directive, e.g.:
+ at verbatim
+ (:include "/foo/bar/")
+ at end verbatim
+
+ at section Shell-friendly syntax for configuration
+
+When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS}
+ASDF will skip to next configuration if it's an empty string.
+It will @code{READ} the string as an SEXP in the DSL
+if it begins with a paren @code{(}
+and it will be interpreted as a list of directories.
+Directories should come by pairs, indicating a mapping directive.
+Entries are separated
+by a @code{:} (colon) on Unix platforms (including cygwin),
+by a @code{;} (semicolon) on other platforms (mainly, Windows).
+
+The magic empty entry,
+if it comes in what would otherwise be the first entry in a pair,
+indicates the splicing of inherited configuration.
+If it comes as the second entry in a pair,
+it indicates that the directory specified first is to be left untranslated
+(which has the same effect as if the directory had been repeated).
+
+
+ at section Semantics of Output Translations
+
+From the specified configuration,
+a list of mappings is extracted in a straightforward way:
+mappings are collected in order, recursing through
+included or inherited configuration as specified.
+To this list is prepended some implementation-specific mappings,
+and is appended a global default.
+
+The list is then compiled to a mapping table as follows:
+for each entry, in order, resolve the first designated directory
+into an actual directory pathname for source locations.
+If no mapping was specified yet for that location,
+resolve the second designated directory to an output location directory
+add a mapping to the table mapping the source location to the output location,
+and add another mapping from the output location to itself
+(unless a mapping already exists for the output location).
+
+Based on the table, a mapping function is defined,
+mapping source pathnames to output pathnames:
+given a source pathname, locate the longest matching prefix
+in the source column of the mapping table.
+Replace that prefix by the corresponding output column
+in the same row of the table, and return the result.
+If no match is found, return the source pathname.
+(A global default mapping the filesystem root to itself
+may ensure that there will always be a match,
+with same fall-through semantics).
+
+ at section Caching Results
+
+The implementation is allowed to either eagerly compute the information
+from the configurations and file system, or to lazily re-compute it
+every time, or to cache any part of it as it goes.
+To explicitly flush any information cached by the system, use the API below.
+
+
+ at section Output location API
+
+The specified functions are exported from package ASDF.
+
+ at defun initialize-output-translations @&optional PARAMETER
+ will read the configuration and initialize all internal variables.
+ You may extend or override configuration
+ from the environment and configuration files
+ with the given @var{PARAMETER}, which can be
+ @code{NIL} (no configuration override),
+ or a SEXP (in the SEXP DSL),
+ a string (as in the string DSL),
+ a pathname (of a file or directory with configuration),
+ or a symbol (fbound to function that when called returns one of the above).
+ at end defun
+
+ at defun disable-output-translations
+ will initialize output translations in a way
+ that maps every pathname to itself,
+ effectively disabling the output translation facility.
+ at end defun
+
+ at defun clear-output-translations
+ undoes any output translation configuration
+ and clears any cache for the mapping algorithm.
+ You might want to call that before you
+ dump an image that would be resumed with a different configuration,
+ and return an empty configuration.
+ Note that this does not include clearing information about
+ systems defined in the current image, only about
+ where to look for systems not yet defined.
+ at end defun
+
+ at defun ensure-output-translations @&optional PARAMETER
+ checks whether output translations have been initialized.
+ If not, initialize them with the given @var{PARAMETER}.
+ This function will be called before any attempt to operate on a system.
+ at end defun
+
+ at defun apply-output-translations PATHNAME
+ Applies the configured output location translations to @var{PATHNAME}
+ (calls @code{ensure-output-translations} for the translations).
+ at end defun
+
+
+ at section Credits for output translations
+
+Thanks a lot to Bjorn Lindberg and Gary King for @code{ASDF-Binary-Locations},
+and to Peter van Eynde for @code{Common Lisp Controller}.
+
+All bad design ideas and implementation bugs are to mine, not theirs.
+But so are good design ideas and elegant implementation tricks.
+
+ --- Francois-Rene Rideau @email{fare@@tunes.org}
+
+ at c @section Default locations
+ at c @findex output-files-for-system-and-operation
+
+ at c The default binary location for each Lisp implementation
+ at c is a subdirectory of each source directory.
+ at c To account for different Lisps, Operating Systems, Implementation versions,
+ at c and so on, ASDF borrows code from SLIME
+ at c to create reasonable custom directory names.
+ at c Here are some examples:
+
+ at c @itemize
+ at c @item
+ at c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86}
+
+ at c @item
+ at c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86}
+
+ at c @item
+ at c Franz Allegro, version 8.1, Modern (case sensitive) Common Lisp: @code{allegro-8.1m-macosx-x86}
+ at c @end itemize
+
+ at c By default, all output file pathnames will be relocated
+ at c to some thus-named subdirectory of @file{~/.cache/common-lisp/}.
+
+ at c See the document @file{README.asdf-output-translations}
+ at c for a full specification on how to configure @code{asdf-output-translations}.
+
+ at node Error handling, Miscellaneous additional functionality, Controlling where ASDF saves compiled files, Top
+ at comment node-name, next, previous, up
+ at chapter Error handling
+ at findex SYSTEM-DEFINITION-ERROR
+ at findex OPERATION-ERROR
+
+ at section ASDF errors
+
+If ASDF detects an incorrect system definition, it will signal a generalised instance of
+ at code{SYSTEM-DEFINITION-ERROR}.
+
+Operations may go wrong (for example when source files contain errors).
+These are signalled using generalised instances of
+ at code{OPERATION-ERROR}.
+
+ at section Compilation error and warning handling
+ at vindex *compile-file-warnings-behaviour*
+ at vindex *compile-file-errors-behavior*
+
+ASDF checks for warnings and errors when a file is compiled.
+The variables @var{*compile-file-warnings-behaviour*} and
+ at var{*compile-file-errors-behavior*}
+control the handling of any such events.
+The valid values for these variables are
+ at code{:error}, @code{:warn}, and @code{:ignore}.
+
+ at node Miscellaneous additional functionality, Getting the latest version, Error handling, Top
+ at comment node-name, next, previous, up
+ at chapter Miscellaneous additional functionality
+
+ at emph{FIXME: Add discussion of @code{run-shell-command}? Others?}
+
+ASDF includes several additional features that are generally
+useful for system definition and development. These include:
+
+ at defun system-relative-pathname system name @&key type
+
+It's often handy to locate a file relative to some system.
+The @code{system-relative-pathname} function meets this need.
+It takes two arguments: the name of a system and a relative pathname.
+It returns a pathname built from the location of the system's source file
+and the relative pathname. For example
+
+ at lisp
+> (asdf:system-relative-pathname 'cl-ppcre #p"regex.data")
+#P"/repository/other/cl-ppcre/regex.data"
+ at end lisp
+
+Instead of a pathname, you can provide a symbol or a string,
+and optionally a keyword argument @code{type}.
+The arguments will then be interpreted in the same way
+as pathname specifiers for components.
+ at xref{The defsystem grammar,,Pathname specifiers}.
+ at end defun
+
+ at defun system-source-directory system-designator
+
+ASDF does not provide a turnkey solution for locating data (or other
+miscellaneous) files that are distributed together with the source code
+of a system. Programmers can use @code{system-source-directory} to find
+such files. Returns a pathname object. The @var{system-designator} may
+be a string, symbol, or ASDF system object.
+ at end defun
+
+
+ at node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
+ at comment node-name, next, previous, up
+ at chapter Getting the latest version
+
+Decide which version you want.
+HEAD is the newest version and usually OK, whereas
+RELEASE is for cautious people
+(e.g. who already have systems using ASDF that they don't want broken),
+a slightly older version about which none of the HEAD users have complained.
+There is also a STABLE version, which is earlier than release.
+
+You may get the ASDF source repository using git:
+ at kbd{git clone http://common-lisp.net/project/asdf/asdf.git}
+
+You will find the above referenced tags in this repository.
+You can also browse the repository on
+ at url{http://common-lisp.net/gitweb?p=projects/asdf/asdf.git}.
+
+Discussion of ASDF development is conducted on the
+mailing list
+ at kbd{asdf-devel@@common-lisp.net}.
+ at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
+
+
+ at node FAQ, TODO list, Getting the latest version, Top
+ at comment node-name, next, previous, up
+ at chapter FAQ
+
+ at section ``Where do I report a bug?''
+
+ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
+
+If you're unsure about whether something is a bug, of for general discussion,
+use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+
+
+ at section ``What has changed between ASDF 1 and ASDF 2?''
+
+ at subsection What are ASDF 1 and ASDF 2?
+
+We are preparing for a release of ASDF 2,
+which will have version 2.000 and later.
+While the code and documentation are essentially complete
+we are still working on polishing them before release.
+
+Releases in the 1.600 series and beyond
+should be considered as release candidates.
+For all practical purposes,
+ASDF 2 refers to releases later than 1.656,
+and ASDF 1 to any release earlier than 1.369 or so.
+If your ASDF doesn't have a version, it's old.
+
+ASDF 2 release candidates and beyond will have
+ at code{:asdf2} onto @code{*features*} so that if you are writing
+ASDF-dependent code you may check for this feature
+to see if the new API is present.
+ at emph{All} versions of ASDF should have the @code{:asdf} feature.
+
+If you are experiencing problems or limitations of any sort with ASDF 1,
+we recommend that you should upgrade to ASDF 2 or its latest release candidate.
+
+
+ at subsection ASDF can portably name files inside systems and components
+
+Common Lisp namestrings are not portable,
+except maybe for logical pathnamestrings,
+that themselves require a lot of setup that is itself ultimately non-portable.
+The only portable ways to refer to pathnames inside systems and components
+were very awkward, using @code{#.(make-pathname ...)} and
+ at code{#.(merge-pathnames ...)}.
+Even the above were themselves were inadequate in the general case
+due to host and device issues, unless horribly complex patterns were used.
+Plenty of simple cases that looked portable actually weren't,
+leading to much confusion and greavance.
+
+ASDF 2 implements its own portable syntax for strings as pathname specifiers.
+Naming files within a system definition becomes easy and portable again.
+ at xref{Miscellaneous additional functionality,asdf:system-relative-pathname},
+ at code{asdf-utilities:merge-pathnames*},
+ at code{asdf::merge-component-name-type}.
+
+ at xref{The defsystem grammar,,Pathname specifiers}.
+
+ at subsection Output translations
+
+A popular feature added to ASDF was output pathname translation:
+ at code{asdf-binary-locations}, @code{common-lisp-controller},
+ at code{cl-launch} and other hacks were all implementing it in ways
+both mutually incompatible and difficult to configure.
+
+Output pathname translation is essential to share
+source directories of portable systems across multiple implementations
+or variants thereof,
+or source directories of shared installations of systems across multiple users,
+or combinations of the above.
+
+In ASDF 2, a standard mechanism is provided for that,
+ at code{asdf-output-translations},
+with sensible defaults, adequate configuration languages,
+a coherent set of configuration files and hooks,
+and support for non-Unix platforms.
+
+ at xref{Controlling where ASDF saves compiled files}.
+
+ at subsection Source Registry Configuration
+
+Configuring ASDF used to require special magic
+to be applied just at the right moment,
+between the moment ASDF is loaded and the moment it is used,
+in a way that is specific to the user,
+the implementation he is using and the application he is building.
+
+This made for awkward configuration files and startup scripts
+that could not be shared between users, managed by administrators
+or packaged by distributions.
+
+ASDF 2 provides a well-documented way to configure ASDF,
+with sensible defaults, adequate configuration languages,
+and a coherent set of configuration files and hooks.
+
+At the same time, ASDF 2 remains compatible
+with the old magic you may have in your build scripts
+to tailor the ASDF configuration to your build automation needs,
+and also allows for new magic, simpler and more powerful magic.
+
+ at xref{Controlling where ASDF searches for systems}.
+
+ at subsection Usual operations are made easier to the user
+
+In ASDF 1, you had to use the awkward syntax
+ at code{(asdf:oos 'asdf:load-op :foo)}
+to load a system,
+and similarly for @code{compile-op}, @code{test-op}.
+
+In ASDF 2, you can use shortcuts for the usual operations:
+ at code{(asdf:load-system :foo)}, and
+similarly for @code{compile-system}, @code{test-system}.
+
+
+ at subsection Many bugs have been fixed
+
+These issues and many others have been fixed,
+including the following:
+
+Dependencies were not correctly propagated
+across submodules within a system.
+
+Many features used to not be portable,
+especially where pathnames were involved.
+
+The internal test suite used to massively fail
+in many implementations.
+
+Support was broken for some implementations (notably ABCL).
+
+The documentation was grossly out of date.
+
+ECL extensions were not integrated in the ASDF release.
+
+
+ at subsection ASDF itself is versioned
+
+Between new features, old bugs fixed, and new bugs introduced,
+there were various releases of ASDF in the wild,
+and no simple way to check which release had which feature set.
+People using or writing systems had to either make worst-case assumptions
+as to what features were available and worked,
+or take great pains to have the correct version of ASDF installed.
+
+With ASDF 2, we provide a new stable set of working features
+that everyone can rely on from now on.
+Use @code{#+asdf2} to detect presence of ASDF 2,
+ at code{(asdf:version-satisfies (asdf:asdf-version) "1.678")}
+to check the availability of a version no earlier than required.
+
+ at subsection ASDF can be upgraded
+
+When an old version of ASDF was loaded,
+it was very hard to upgrade ASDF in your current image
+without breaking everything.
+Instead you have to exit the Lisp process and
+somehow arrange to start a new one from a simpler image.
+Something that can't be done from within Lisp,
+making automation of it difficult,
+which compounded with difficulty in configuration,
+made the task quite hard.
+Yet as we saw before, the task would have been required
+to not have to live with the worst case or non-portable
+subset of ASDF features.
+
+With ASDF 2, it is easy to upgrade
+from ASDF 2 to later versions from within Lisp,
+and not too hard to upgrade from ASDF 1 to ASDF 2 from within Lisp.
+We support hot upgrade of ASDF and any breakage is a bug
+that we will do our best to fix.
+There are still limitations on upgrade, though,
+most notably the fact that after you upgrade ASDF,
+you must also reload or upgrade all ASDF extensions.
+
+ at subsection Decoupled release cycle
+
+When vendors were releasing their Lisp implementations with ASDF,
+they had to basically never change version
+because neither upgrade nor downgrade was possible
+without breaking something for someone,
+and no obvious upgrade path was visible and recommendable.
+
+With ASDF 2, upgrade is possible, easy and can be recommended.
+This means that vendors can safely ship a recent version of ASDF,
+confident that if a user isn't fully satisfied,
+he can easily upgrade ASDF and deal
+with a supported recent version of it.
+This means that release cycles will be causally decoupled,
+the practical consequence of which will mean faster convergence
+towards the latest version for everyone.
+
+ at section Issues with installing the proper version of ASDF
+
+ at subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?''
+
+We recommend you upgrade ASDF.
+ at xref{Loading ASDF,,Upgrading ASDF}.
+
+If this does not work, it is a bug, and you should report it.
+ at xref{FAQ, report-bugs, Where do I report a bug}.
+In the meantime, you can load @file{asdf.lisp} directly.
+ at xref{Loading ASDF,Loading an otherwise installed ASDF}.
+
+
+ at subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?''
+
+Starting with current candidate releases of ASDF 2,
+it should always be a good time to upgrade to a recent version of ASDF.
+You may consult with the maintainer for which specific version they recommend,
+but the latest RELEASE should be correct.
+We trust you to thoroughly test it with your implementation before you release it.
+If there are any issues with the current release,
+it's a bug that you should report upstream and that we will fix ASAP.
+
+As to how to include ASDF, we recommend that
+if you do have a few magic systems in your implementation path,
+that are specially treated in @code{wrapping-source-registry},
+like SBCL does.
+In this case, we explicitly ask you to @emph{NOT} distribute
+ at file{asdf.asd} together with your implementation's ASDF,
+least you separate it from the other systems in this path,
+or otherwise rename the system and its @file{asd} file
+to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}.
+
+If you do not have any such magic systems, or have other non-magic systems
+that you want to bundle with your implementation,
+then you may add them to the @code{default-source-registry},
+and you are welcome to include @file{asdf.asd} amongst them.
+
+Please send upstream any patches you make to ASDF itself,
+so we can merge them back in for the benefit of your users
+when they upgrade to the upstream version.
+
+
+ at section Issues with configuring ASDF
+
+ at subsection ``How can I customize where fasl files are stored?''
+
+ at xref{Controlling where ASDF saves compiled files}.
+
+Note that in the past there was an add-on to ASDF called
+ at code{ASDF-binary-locations}, developed by Gary King.
+That add-on has been merged into ASDF proper,
+then superseded by the @code{asdf-output-translations} facility.
+
+Note that use of @code{asdf-output-translations}
+can interfere with one aspect of your systems
+--- if your system uses @code{*load-truename*} to find files
+(e.g., if you have some data files stored with your program),
+then the relocation that this ASDF customization performs
+is likely to interfere.
+Use @code{asdf:system-relative-pathname} to locate a file
+in the source directory of some system, and
+use @code{asdf:apply-output-translations} to locate a file
+whose pathname has been translated by the facility.
+
+ at subsection ``How can I wholly disable the compiler output cache?''
+
+To permanently disable the compiler output cache
+for all future runs of ASDF, you can:
+
+ at example
+mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/
+echo ':disable-cache' > ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf
+ at end example
+
+This assumes that you didn't otherwise configure the ASDF files
+(if you did, edit them again),
+and don't somehow override the configuration at runtime
+with a shell variable (see below) or some other runtime command
+(e.g. some call to @code{asdf:initialize-output-translations}).
+
+To disable the compiler output cache in Lisp processes
+run by your current shell, try (assuming @code{bash} or @code{zsh})
+(on Unix and cygwin only):
+
+ at example
+export ASDF_OUTPUT_TRANSLATIONS=/:
+ at end example
+
+To disable the compiler output cache just in the current Lisp process,
+use (after loading ASDF but before using it):
+
+ at example
+(asdf:disable-output-translations)
+ at end example
+
+ at section Issues with using and extending ASDF to define systems
+
+ at subsection ``How can I cater for unit-testing in my system?''
+
+ASDF provides a predefined test operation, @code{test-op}.
+ at xref{Predefined operations of ASDF, test-op}.
+The test operation, however, is largely left to the system definer to specify.
+ at code{test-op} has been
+a topic of considerable discussion on the
+ at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
+and on the
+ at uref{https://launchpad.net/asdf,launchpad bug-tracker}.
+
+Here are some guidelines:
+
+ at itemize
+ at item
+For a given system, @var{foo}, you will want to define a corresponding
+test system, such as @var{foo-test}. The reason that you will want this
+separate system is that ASDF does not out of the box supply components
+that are conditionally loaded. So if you want to have source files
+(with the test definitions) that will not be loaded except when testing,
+they should be put elsewhere.
+
+ at item
+The @var{foo-test} system can be defined in an asd file of its own or
+together with @var{foo}. An aesthetic preference against cluttering up
+the filesystem with extra asd files should be balanced against the
+question of whether one might want to directly load @var{foo-test}.
+Typically one would not want to do this except in early stages of
+debugging.
+
+ at item
+Record that testing is implemented by @var{foo-test}. For example:
+ at example
+(defsystem @var{foo}
+ :in-order-to ((test-op (test-op @var{foo-test})))
+ ....)
+
+(defsystem @var{foo-test}
+ :depends-on (@var{foo} @var{my-test-library} ...)
+ ....)
+ at end example
+ at end itemize
+
+This procedure will allow you to support users who do not wish to
+install your test framework.
+
+One oddity of ASDF is that @code{operate} (@pxref{Operations,operate})
+does not return a value. So in current versions of ASDF there is no
+reliable programmatic means of determining whether or not a set of tests
+has passed, or which tests have failed. The user must simply read the
+console output. This limitation has been the subject of much
+discussion.
+
+ at subsection ``How can I cater for documentation generation in my system?''
+
+The ASDF developers are currently working to add a @code{doc-op}
+to the set of predefined ASDF operations.
+ at xref{Predefined operations of ASDF}.
+See also @url{https://bugs.launchpad.net/asdf/+bug/479470}.
+
+
+
+ at subsection ``How can I maintain non-Lisp (e.g. C) source files?''
+
+See @code{cffi}'s @code{cffi-grovel}.
+
+ at anchor{report-bugs}
+
+
+ at subsection ``I want to put my module's files at the top level. How do I do this?''
+
+By default, the files contained in an asdf module go
+in a subdirectory with the same name as the module.
+However, this can be overridden by adding a @code{:pathname ""} argument
+to the module description.
+For example, here is how it could be done
+in the spatial-trees ASDF system definition for ASDF 2:
+
+ at example
+(asdf:defsystem :spatial-trees
+ :components
+ ((:module base
+ :pathname ""
+ :components
+ ((:file "package")
+ (:file "basedefs" :depends-on ("package"))
+ (:file "rectangles" :depends-on ("package"))))
+ (:module tree-impls
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:file "r-trees")
+ (:file "greene-trees" :depends-on ("r-trees"))
+ (:file "rstar-trees" :depends-on ("r-trees"))
+ (:file "rplus-trees" :depends-on ("r-trees"))
+ (:file "x-trees" :depends-on ("r-trees" "rstar-trees"))))
+ (:module viz
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:static-file "spatial-tree-viz.lisp")))
+ (:module tests
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:static-file "spatial-tree-test.lisp")))
+ (:static-file "LICENCE")
+ (:static-file "TODO")))
+ at end example
+
+All of the files in the @code{tree-impls} module are at the top level,
+instead of in a @file{tree-impls/} subdirectory.
+
+Note that the argument to @code{:pathname} can be either a pathname object or a string.
+A pathname object can be constructed with the @file{#p"foo/bar/"} syntax,
+but this is discouraged because the results of parsing a namestring are not portable.
+A pathname can only be portably constructed with such syntax as
+ at code{#.(make-pathname :directory '(:relative "foo" "bar"))},
+and similarly the current directory can only be portably specified as
+ at code{#.(make-pathname :directory '(:relative))}.
+However, as of ASDF 2, you can portably use a string to denote a pathname.
+The string will be parsed as a @code{/}-separated path from the current directory,
+such that the empty string @code{""} denotes the current directory, and
+ at code{"foo/bar"} (no trailing @code{/} required in the case of modules)
+portably denotes the same subdirectory as above.
+When files are specified, the last @code{/}-separated component is interpreted
+either as the name component of a pathname
+(if the component class specifies a pathname type),
+or as a name component plus optional dot-separated type component
+(if the component class doesn't specifies a pathname type).
+
+
+ at node TODO list, Inspiration, FAQ, Top
+ at comment node-name, next, previous, up
+ at chapter TODO list
+
+Here is an old list of things to do,
+in addition to the bugs that are now tracked on launchpad:
+ at url{https://launchpad.net/asdf}.
+
+ at section Outstanding spec questions, things to add
+
+** packaging systems
+
+*** manual page component?
+
+** style guide for .asd files
+
+You should either use keywords or be careful
+with the package that you evaluate defsystem forms in.
+Otherwise @code{(defsystem partition ...)}
+being read in the @code{cl-user} package
+will intern a @code{cl-user:partition} symbol,
+which will then collide with the @code{partition:partition} symbol.
+
+Actually there's a hairier packages problem to think about too.
+ at code{in-order-to} is not a keyword:
+if you read @code{defsystem} forms in a package that doesn't use ASDF,
+odd things might happen.
+
+
+** extending defsystem with new options
+
+You might not want to write a whole parser,
+but just to add options to the existing syntax.
+Reinstate @code{parse-option} or something akin.
+
+
+** document all the error classes
+
+** what to do with compile-file failure
+
+Should check the primary return value from compile-file and see if
+that gets us any closer to a sensible error handling strategy
+
+** foreign files
+
+lift unix-dso stuff from db-sockets
+
+** Diagnostics
+
+A ``dry run'' of an operation can be made with the following form:
+
+ at lisp
+(traverse (make-instance '<operation-name>)
+ (find-system <system-name>)
+ 'explain)
+ at end lisp
+
+This uses unexported symbols.
+What would be a nice interface for this functionality?
+
+ at section Missing bits in implementation
+
+** all of the above
+
+** reuse the same scratch package whenever a system is reloaded from disk
+
+** rules for system pathname defaulting are not yet implemented properly
+
+** proclamations probably aren't
+
+** when a system is reloaded with fewer components than it previously had, odd things happen
+
+We should do something inventive when processing a @code{defsystem} form,
+like take the list of kids and @code{setf} the slot to @code{nil},
+then transfer children from old to new list as they're found.
+
+** traverse may become a normal function
+
+If you're defining methods on @code{traverse}, speak up.
+
+
+** a lot of load-op methods can be rewritten to use input-files
+
+so should be.
+
+
+** (stuff that might happen later)
+
+*** Propagation of the @code{:force} option.
+
+``I notice that
+
+ @code{(asdf:compile-system :araneida :force t)}
+
+also forces compilation of every other system the @code{:araneida} system depends on.
+This is rarely useful to me;
+usually, when I want to force recompilation of something more than a single source file,
+I want to recompile only one system.
+So it would be more useful to have @code{make-sub-operation}
+refuse to propagate @code{:force t} to other systems, and
+propagate only something like @code{:force :recursively}.
+
+Ideally what we actually want is some kind of criterion that says
+to which systems (and which operations) a @code{:force} switch will propagate.
+
+The problem is perhaps that ``force'' is a pretty meaningless concept.
+How obvious is it that @code{load :force t} should force @emph{compilation}?
+But we don't really have the right dependency setup
+for the user to compile @code{:force t} and expect it to work
+(files will not be loaded after compilation, so the compile
+environment for subsequent files will be emptier than it needs to be)
+
+What does the user actually want to do when he forces?
+Usually, for me, update for use with a new version of the Lisp compiler.
+Perhaps for recovery when he suspects that something has gone wrong.
+Or else when he's changed compilation options or configuration
+in some way that's not reflected in the dependency graph.
+
+Other possible interface: have a ``revert'' function akin to @code{make clean}.
+
+ at lisp
+(asdf:revert 'asdf:compile-op 'araneida)
+ at end lisp
+
+would delete any files produced by @code{(compile-system :araneida)}.
+Of course, it wouldn't be able to do much about stuff in the image itself.
+
+How would this work?
+
+ at code{traverse}
+
+There's a difference between a module's dependencies (peers)
+and its components (children).
+Perhaps there's a similar difference in operations?
+For example, @code{(load "use") depends-on (load "macros")} is a peer,
+whereas @code{(load "use") depends-on (compile "use")}
+is more of a ``subservient'' relationship.
+
+ at node Inspiration, Concept Index, TODO list, Top
+ at comment node-name, next, previous, up
+ at chapter Inspiration
+
+ at section mk-defsystem (defsystem-3.x)
+
+We aim to solve basically the same problems as @code{mk-defsystem} does.
+However, our architecture for extensibility
+better exploits CL language features (and is documented),
+and we intend to be portable rather than just widely-ported.
+No slight on the @code{mk-defsystem} authors and maintainers is intended here;
+that implementation has the unenviable task
+of supporting pre-ANSI implementations, which is no longer necessary.
+
+The surface defsystem syntax of asdf is more-or-less compatible with
+ at code{mk-defsystem}, except that we do not support
+the @code{source-foo} and @code{binary-foo} prefixes
+for separating source and binary files, and
+we advise the removal of all options to specify pathnames.
+
+The @code{mk-defsystem} code for topologically sorting
+a module's dependency list was very useful.
+
+ at section defsystem-4 proposal
+
+Marco and Peter's proposal for defsystem 4 served as the driver for
+many of the features in here. Notable differences are:
+
+ at itemize
+ at item
+We don't specify output files or output file extensions
+as part of the system.
+
+If you want to find out what files an operation would create,
+ask the operation.
+
+ at item
+We don't deal with CL packages
+
+If you want to compile in a particular package, use an @code{in-package} form
+in that file (ilisp / SLIME will like you more if you do this anyway)
+
+ at item
+There is no proposal here that @code{defsystem} does version control.
+
+A system has a given version which can be used to check dependencies,
+but that's all.
+ at end itemize
+
+The defsystem 4 proposal tends to look more at the external features,
+whereas this one centres on a protocol for system introspection.
+
+ at section kmp's ``The Description of Large Systems'', MIT AI Memu 801
+
+Available in updated-for-CL form on the web at
+ at url{http://nhplace.com/kent/Papers/Large-Systems.html}
+
+In our implementation we borrow kmp's overall @code{PROCESS-OPTIONS}
+and concept to deal with creating component trees
+from @code{defsystem} surface syntax.
+[ this is not true right now, though it used to be and
+probably will be again soon ]
+
+
+ at c -------------------
+
+
+ at node Concept Index, Function and Class Index, Inspiration, Top
+ at unnumbered Concept Index
+
+ at printindex cp
+
+ at node Function and Class Index, Variable Index, Concept Index, Top
+ at unnumbered Function and Class Index
+
+ at printindex fn
+
+ at node Variable Index, , Function and Class Index, Top
+ at unnumbered Variable Index
+
+ at printindex vr
+
+ at bye
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Apr 15 16:23:44 2010
@@ -1,19 +1,25 @@
-;;; This is asdf: Another System Definition Facility. $Revision: 1.3 $
+;;; -*- mode: common-lisp; package: asdf; -*-
+;;; This is ASDF: Another System Definition Facility.
;;;
-;;; Feedback, bug reports, and patches are all welcome: please mail to
-;;; <cclan-list at lists.sf.net>. But note first that the canonical
-;;; source for asdf is presently the cCLan CVS repository at
-;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
+;;; Feedback, bug reports, and patches are all welcome:
+;;; please mail to <asdf-devel at common-lisp.net>.
+;;; Note first that the canonical source for ASDF is presently
+;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the CVS HEAD
+;;; bugs. There are usually two "supported" revisions - the git HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'
-;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;; -- LICENSE START
+;;; (This is the MIT / X Consortium license as taken from
+;;; http://www.opensource.org/licenses/mit-license.html on or about
+;;; Monday; July 13, 2009)
+;;;
+;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
@@ -33,112 +39,682 @@
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;;
+;;; -- LICENSE END
-;;; the problem with writing a defsystem replacement is bootstrapping:
-;;; we can't use defsystem to compile it. Hence, all in one file
+;;; The problem with writing a defsystem replacement is bootstrapping:
+;;; we can't use defsystem to compile it. Hence, all in one file.
-(defpackage #:asdf
- (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
- #:system-definition-pathname #:find-component ; miscellaneous
- #:hyperdocumentation #:hyperdoc
-
- #:compile-op #:load-op #:load-source-op #:test-system-version
- #:test-op
- #:operation ; operations
- #:feature ; sort-of operation
- #:version ; metaphorically sort-of an operation
-
- #:input-files #:output-files #:perform ; operation methods
- #:operation-done-p #:explain
-
- #:component #:source-file
- #:c-source-file #:cl-source-file #:java-source-file
- #:static-file
- #:doc-file
- #:html-file
- #:text-file
- #:source-file-type
- #:module ; components
- #:system
- #:unix-dso
-
- #:module-components ; component accessors
- #:component-pathname
- #:component-relative-pathname
- #:component-name
- #:component-version
- #:component-parent
- #:component-property
- #:component-system
-
- #:component-depends-on
-
- #:system-description
- #:system-long-description
- #:system-author
- #:system-maintainer
- #:system-license
-
- #:operation-on-warnings
- #:operation-on-failure
-
- ;#:*component-parent-pathname*
- #:*system-definition-search-functions*
- #:*central-registry* ; variables
- #:*compile-file-warnings-behaviour*
- #:*compile-file-failure-behaviour*
- #:*asdf-revision*
-
- #:operation-error #:compile-failed #:compile-warned #:compile-error
- #:error-component #:error-operation
- #:system-definition-error
- #:missing-component
- #:missing-dependency
- #:circular-dependency ; errors
- #:duplicate-names
-
- #:retry
- #:accept ; restarts
-
- )
- (:use :cl))
+#+xcvb (module ())
-#+nil
-(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
+(cl:in-package :cl-user)
+(declaim (optimize (speed 2) (debug 2) (safety 3)))
+
+#+ecl (require 'cmp)
+
+;;;; Create packages in a way that is compatible with hot-upgrade.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;; See more at the end of the file.
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (let* ((asdf-version
+ ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
+ (subseq "VERSION:1.679" (1+ (length "VERSION"))))
+ #+allegro (excl::*autoload-package-name-alist* nil)
+ (existing-asdf (find-package :asdf))
+ (versym '#:*asdf-version*)
+ (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
+ (redefined-functions
+ '(#:perform #:explain #:output-files #:operation-done-p
+ #:perform-with-restarts #:component-relative-pathname
+ #:system-source-file)))
+ (unless (equal asdf-version existing-version)
+ (labels ((rename-away (package)
+ (loop :with name = (package-name package)
+ :for i :from 1 :for new = (format nil "~A.~D" name i)
+ :unless (find-package new) :do
+ (rename-package-name package name new)))
+ (rename-package-name (package old new)
+ (let* ((old-names (cons (package-name package) (package-nicknames package)))
+ (new-names (subst new old old-names :test 'equal))
+ (new-name (car new-names))
+ (new-nicknames (cdr new-names)))
+ (rename-package package new-name new-nicknames)))
+ (ensure-exists (name nicknames use)
+ (let* ((previous
+ (remove-duplicates
+ (remove-if
+ #'null
+ (mapcar #'find-package (cons name nicknames)))
+ :from-end t)))
+ (cond
+ (previous
+ (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
+ (let ((p (car previous))) ;; previous package with same name
+ (rename-package p name nicknames)
+ (ensure-use p use)
+ p))
+ (t
+ (make-package name :nicknames nicknames :use use)))))
+ (find-sym (symbol package)
+ (find-symbol (string symbol) package))
+ (remove-symbol (symbol package)
+ (let ((sym (find-sym symbol package)))
+ (when sym
+ (unexport sym package)
+ (unintern sym package))))
+ (ensure-unintern (package symbols)
+ (dolist (sym symbols) (remove-symbol sym package)))
+ (ensure-shadow (package symbols)
+ (shadow symbols package))
+ (ensure-use (package use)
+ (dolist (used (reverse use))
+ (do-external-symbols (sym used)
+ (unless (eq sym (find-sym sym package))
+ (remove-symbol sym package)))
+ (use-package used package)))
+ (ensure-fmakunbound (package symbols)
+ (loop :for name :in symbols
+ :for sym = (find-sym name package)
+ :when sym :do (fmakunbound sym)))
+ (ensure-export (package export)
+ (let ((syms (loop :for x :in export :collect
+ (intern (string x) package))))
+ (do-external-symbols (sym package)
+ (unless (member sym syms)
+ (remove-symbol sym package)))
+ (dolist (sym syms)
+ (export sym package))))
+ (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
+ (let ((p (ensure-exists name nicknames use)))
+ (ensure-unintern p unintern)
+ (ensure-shadow p shadow)
+ (ensure-export p export)
+ (ensure-fmakunbound p fmakunbound)
+ p)))
+ (ensure-package
+ ':asdf-utilities
+ :nicknames '(#:asdf-extensions)
+ :use '(#:common-lisp)
+ :unintern '(#:split #:make-collector)
+ :export
+ '(#:absolute-pathname-p
+ #:aif
+ #:appendf
+ #:asdf-message
+ #:coerce-name
+ #:directory-pathname-p
+ #:ends-with
+ #:ensure-directory-pathname
+ #:getenv
+ #:get-uid
+ #:length=n-p
+ #:merge-pathnames*
+ #:pathname-directory-pathname
+ #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
+ #:read-file-forms
+ #:remove-keys
+ #:remove-keyword
+ #:resolve-symlinks
+ #:split-string
+ #:component-name-to-pathname-components
+ #:split-name-type
+ #:system-registered-p
+ #:truenamize
+ #:while-collecting))
+ (ensure-package
+ ':asdf
+ :use '(:common-lisp :asdf-utilities)
+ :unintern `(#-ecl , at redefined-functions
+ #:*asdf-revision* #:around #:asdf-method-combination
+ #:split #:make-collector)
+ :fmakunbound `(#+ecl , at redefined-functions
+ #:system-source-file
+ #:component-relative-pathname #:system-relative-pathname
+ #:process-source-registry
+ #:inherit-source-registry #:process-source-registry-directive)
+ :export
+ '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
+ #:system-definition-pathname #:find-component ; miscellaneous
+ #:compile-system #:load-system #:test-system
+ #:compile-op #:load-op #:load-source-op
+ #:test-op
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
+ #:version-satisfies
+
+ #:input-files #:output-files #:perform ; operation methods
+ #:operation-done-p #:explain
+
+ #:component #:source-file
+ #:c-source-file #:cl-source-file #:java-source-file
+ #:static-file
+ #:doc-file
+ #:html-file
+ #:text-file
+ #:source-file-type
+ #:module ; components
+ #:system
+ #:unix-dso
+
+ #:module-components ; component accessors
+ #:component-pathname
+ #:component-relative-pathname
+ #:component-name
+ #:component-version
+ #:component-parent
+ #:component-property
+ #:component-system
+
+ #:component-depends-on
+
+ #:system-description
+ #:system-long-description
+ #:system-author
+ #:system-maintainer
+ #:system-license
+ #:system-licence
+ #:system-source-file
+ #:system-source-directory
+ #:system-relative-pathname
+ #:map-systems
+
+ #:operation-on-warnings
+ #:operation-on-failure
+ ;#:*component-parent-pathname*
+ #:*system-definition-search-functions*
+ #:*central-registry* ; variables
+ #:*compile-file-warnings-behaviour*
+ #:*compile-file-failure-behaviour*
+ #:*resolve-symlinks*
+
+ #:asdf-version
+
+ #:operation-error #:compile-failed #:compile-warned #:compile-error
+ #:error-name
+ #:error-pathname
+ #:load-system-definition-error
+ #:error-component #:error-operation
+ #:system-definition-error
+ #:missing-component
+ #:missing-component-of-version
+ #:missing-dependency
+ #:missing-dependency-of-version
+ #:circular-dependency ; errors
+ #:duplicate-names
+
+ #:try-recompiling
+ #:retry
+ #:accept ; restarts
+ #:coerce-entry-to-directory
+ #:remove-entry-from-registry
+
+ #:initialize-output-translations
+ #:disable-output-translations
+ #:clear-output-translations
+ #:ensure-output-translations
+ #:apply-output-translations
+ #:compile-file-pathname*
+ #:enable-asdf-binary-locations-compatibility
+
+ #:*default-source-registries*
+ #:initialize-source-registry
+ #:compute-source-registry
+ #:clear-source-registry
+ #:ensure-source-registry
+ #:process-source-registry))
+ (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "$Revision: 1.3 $")
- (colon (or (position #\: v) -1))
- (dot (position #\. v)))
- (and v colon dot
- (list (parse-integer v :start (1+ colon)
- :junk-allowed t)
- (parse-integer v :start (1+ dot)
- :junk-allowed t)))))
+;;;; -------------------------------------------------------------------------
+;;;; User-visible parameters
+;;;;
+(defun asdf-version ()
+ "Exported interface to the version of ASDF currently installed. A string.
+You can compare this string with e.g.:
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
+ *asdf-version*)
+
+(defvar *resolve-symlinks* t
+ "Determine whether or not ASDF resolves symlinks when defining systems.
+
+Defaults to `t`.")
(defvar *compile-file-warnings-behaviour* :warn)
+
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
(defvar *verbose-out* nil)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; utility stuff
+(defparameter +asdf-methods+
+ '(perform-with-restarts perform explain output-files operation-done-p))
+
+#+allegro
+(eval-when (:compile-toplevel :execute)
+ (defparameter *acl-warn-save*
+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
+ excl:*warn-on-nested-reader-conditionals*))
+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
+ (setf excl:*warn-on-nested-reader-conditionals* nil)))
+
+;;;; -------------------------------------------------------------------------
+;;;; Cleanups before hot-upgrade.
+;;;; Things to do in case we're upgrading from a previous version of ASDF.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+;;;; for each of the classes we define that has changed incompatibly.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+ecl
+ (when (find-class 'compile-op nil)
+ (defmethod update-instance-for-redefined-class :after
+ ((c compile-op) added deleted plist &key)
+ (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
+ (let ((system-p (getf plist 'system-p)))
+ (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
+
+;;;; -------------------------------------------------------------------------
+;;;; ASDF Interface, in terms of generic functions.
+
+(defgeneric perform-with-restarts (operation component))
+(defgeneric perform (operation component))
+(defgeneric operation-done-p (operation component))
+(defgeneric explain (operation component))
+(defgeneric output-files (operation component))
+(defgeneric input-files (operation component))
+
+(defgeneric system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
+
+(defgeneric component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defgeneric component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defgeneric component-relative-pathname (component)
+ (:documentation "Returns a pathname for the component argument intended to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+
+(defgeneric component-property (component property))
+
+(defgeneric (setf component-property) (new-value component property))
+
+(defgeneric version-satisfies (component version))
+
+(defgeneric find-component (module name &optional version)
+ (:documentation "Finds the component with name NAME present in the
+MODULE module; if MODULE is nil, then the component is assumed to be a
+system."))
+
+(defgeneric source-file-type (component system))
+
+(defgeneric operation-ancestor (operation)
+ (:documentation
+ "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
+
+(defgeneric component-visited-p (operation component)
+ (:documentation "Returns the value stored by a call to
+VISIT-COMPONENT, if that has been called, otherwise NIL.
+This value stored will be a cons cell, the first element
+of which is a computed key, so not interesting. The
+CDR wil be the DATA value stored by VISIT-COMPONENT; recover
+it as \(cdr \(component-visited-p op c\)\).
+ In the current form of ASDF, the DATA value retrieved is
+effectively a boolean, indicating whether some operations are
+to be performed in order to do OPERATION X COMPONENT. If the
+data value is NIL, the combination had been explored, but no
+operations needed to be performed."))
+
+(defgeneric visit-component (operation component data)
+ (:documentation "Record DATA as being associated with OPERATION
+and COMPONENT. This is a side-effecting function: the association
+will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
+OPERATION\).
+ No evidence that DATA is ever interesting, beyond just being
+non-NIL. Using the data field is probably very risky; if there is
+already a record for OPERATION X COMPONENT, DATA will be quietly
+discarded instead of recorded."))
+
+(defgeneric (setf visiting-component) (new-value operation component))
+
+(defgeneric component-visiting-p (operation component))
+
+(defgeneric component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defgeneric component-self-dependencies (operation component))
+
+(defgeneric traverse (operation component)
+ (:documentation
+"Generate and return a plan for performing `operation` on `component`.
+
+The plan returned is a list of dotted-pairs. Each pair is the `cons`
+of ASDF operation object and a `component` object. The pairs will be
+processed in order by `operate`."))
+
+
+;;;; -------------------------------------------------------------------------
+;;;; General Purpose Utilities
+
+(defmacro while-collecting ((&rest collectors) &body body)
+ (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
+ (initial-values (mapcar (constantly nil) collectors)))
+ `(let ,(mapcar #'list vars initial-values)
+ (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
+ , at body
+ (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
(defun pathname-sans-name+type (pathname)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME and TYPE components"
+and NIL NAME and TYPE components.
+Issue: doesn't override the VERSION component.
+
+Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
(make-pathname :name nil :type nil :defaults pathname))
-(define-modify-macro appendf (&rest args)
- append "Append onto list")
+(defun pathname-directory-pathname (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+ (make-pathname :name nil :type nil :version nil :defaults pathname))
+
+(defun current-directory ()
+ (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; classes, condiitons
+(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
+ "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
+does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+Also, if either argument is NIL, then the other argument is returned unmodified."
+ (when (null specified) (return-from merge-pathnames* defaults))
+ (when (null defaults) (return-from merge-pathnames* specified))
+ (let* ((specified (pathname specified))
+ (defaults (pathname defaults))
+ (directory (pathname-directory specified))
+ (directory (if (stringp directory) `(:absolute ,directory) directory))
+ (name (or (pathname-name specified) (pathname-name defaults)))
+ (type (or (pathname-type specified) (pathname-type defaults)))
+ (version (or (pathname-version specified) (pathname-version defaults))))
+ (labels ((ununspecific (x)
+ (if (eq x :unspecific) nil x))
+ (unspecific-handler (p)
+ (if (typep p 'logical-pathname) #'ununspecific #'identity)))
+ (multiple-value-bind (host device directory unspecific-handler)
+ (ecase (first directory)
+ ((nil)
+ (values (pathname-host defaults)
+ (pathname-device defaults)
+ (pathname-directory defaults)
+ (unspecific-handler defaults)))
+ ((:absolute)
+ (values (pathname-host specified)
+ (pathname-device specified)
+ directory
+ (unspecific-handler specified)))
+ ((:relative)
+ (values (pathname-host defaults)
+ (pathname-device defaults)
+ (append (pathname-directory defaults) (cdr directory))
+ (unspecific-handler defaults))))
+ (make-pathname :host host :device device :directory directory
+ :name (funcall unspecific-handler name)
+ :type (funcall unspecific-handler type)
+ :version (funcall unspecific-handler version))))))
+
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
+
+(defun asdf-message (format-string &rest format-args)
+ (declare (dynamic-extent format-args))
+ (apply #'format *verbose-out* format-string format-args))
+
+(defun split-string (string &key max (separator '(#\Space #\Tab)))
+ "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
+return a list.
+If MAX is specified, then no more than max(1,MAX) components will be returned,
+starting the separation from the end, e.g. when called with arguments
+ \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
+ (block nil
+ (let ((list nil) (words 0) (end (length string)))
+ (flet ((separatorp (char) (find char separator))
+ (done () (return (cons (subseq string 0 end) list))))
+ (loop
+ :for start = (if (and max (>= words (1- max)))
+ (done)
+ (position-if #'separatorp string :end end :from-end t)) :do
+ (when (null start)
+ (done))
+ (push (subseq string (1+ start) end) list)
+ (incf words)
+ (setf end start))))))
+
+(defun split-name-type (filename)
+ (let ((unspecific
+ ;; Giving :unspecific as argument to make-pathname is not portable.
+ ;; See CLHS make-pathname and 19.2.2.2.3.
+ ;; We only use it on implementations that support it.
+ (or #+(or sbcl ccl ecl lispworks) :unspecific)))
+ (destructuring-bind (name &optional (type unspecific))
+ (split-string filename :max 2 :separator ".")
+ (if (equal name "")
+ (values filename unspecific)
+ (values name type)))))
+
+(defun component-name-to-pathname-components (s &optional force-directory)
+ "Splits the path string S, returning three values:
+A flag that is either :absolute or :relative, indicating
+ how the rest of the values are to be interpreted.
+A directory path --- a list of strings, suitable for
+ use with MAKE-PATHNAME when prepended with the flag
+ value.
+A filename with type extension, possibly NIL in the
+ case of a directory pathname.
+FORCE-DIRECTORY forces S to be interpreted as a directory
+pathname \(third return value will be NIL, final component
+of S will be treated as part of the directory path.
+
+The intention of this function is to support structured component names,
+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
+pathnames."
+ (check-type s string)
+ (let* ((components (split-string s :separator "/"))
+ (last-comp (car (last components))))
+ (multiple-value-bind (relative components)
+ (if (equal (first components) "")
+ (if (and (plusp (length s)) (eql (char s 0) #\/))
+ (values :absolute (cdr components))
+ (values :relative nil))
+ (values :relative components))
+ (cond
+ ((equal last-comp "")
+ (values relative (butlast components) nil))
+ (force-directory
+ (values relative components nil))
+ (t
+ (values relative (butlast components) last-comp))))))
+
+(defun remove-keys (key-names args)
+ (loop :for (name val) :on args :by #'cddr
+ :unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ :append (list name val)))
+
+(defun remove-keyword (key args)
+ (loop :for (k v) :on args :by #'cddr
+ :unless (eq k key)
+ :append (list k v)))
+
+(defun resolve-symlinks (path)
+ #-allegro (truenamize path)
+ #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun getenv (x)
+ #+abcl
+ (ext:getenv x)
+ #+sbcl
+ (sb-ext:posix-getenv x)
+ #+clozure
+ (ccl::getenv x)
+ #+clisp
+ (ext:getenv x)
+ #+cmu
+ (cdr (assoc (intern x :keyword) ext:*environment-list*))
+ #+lispworks
+ (lispworks:environment-variable x)
+ #+allegro
+ (sys:getenv x)
+ #+gcl
+ (system:getenv x)
+ #+ecl
+ (si:getenv x))
+
+(defun directory-pathname-p (pathname)
+ "Does `pathname` represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be `nil`,
+`:unspecific` or the empty string.
+
+Note that this does _not_ check to see that `pathname` points to an
+actually-existing directory."
+ (flet ((check-one (x)
+ (member x '(nil :unspecific "") :test 'equal)))
+ (and (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname))
+ t)))
+
+(defun ensure-directory-pathname (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to directory form."
+ (cond
+ ((stringp pathspec)
+ (ensure-directory-pathname (pathname pathspec)))
+ ((not (pathnamep pathspec))
+ (error "Invalid pathname designator ~S" pathspec))
+ ((wild-pathname-p pathspec)
+ (error "Can't reliably convert wild pathnames."))
+ ((directory-pathname-p pathspec)
+ pathspec)
+ (t
+ (make-pathname :directory (append (or (pathname-directory pathspec)
+ (list :relative))
+ (list (file-namestring pathspec)))
+ :name nil :type nil :version nil
+ :defaults pathspec))))
+
+(defun absolute-pathname-p (pathspec)
+ (eq :absolute (car (pathname-directory (pathname pathspec)))))
+
+(defun length=n-p (x n) ;is it that (= (length x) n) ?
+ (check-type n (integer 0 *))
+ (loop
+ :for l = x :then (cdr l)
+ :for i :downfrom n :do
+ (cond
+ ((zerop i) (return (null l)))
+ ((not (consp l)) (return nil)))))
+
+(defun ends-with (s suffix)
+ (check-type s string)
+ (check-type suffix string)
+ (let ((start (- (length s) (length suffix))))
+ (and (<= 0 start)
+ (string-equal s suffix :start1 start))))
+
+(defun read-file-forms (file)
+ (with-open-file (in file)
+ (loop :with eof = (list nil)
+ :for form = (read in nil eof)
+ :until (eq form eof)
+ :collect form)))
+
+#-windows
+(progn
+#+clisp (defun get-uid () (posix:uid))
+#+sbcl (defun get-uid () (sb-unix:unix-getuid))
+#+cmu (defun get-uid () (unix:unix-getuid))
+#+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>")
+#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
+#+allegro (defun get-uid () (excl.osi:getuid))
+#-(or cmu sbcl clisp allegro ecl)
+(defun get-uid ()
+ (let ((uid-string
+ (with-output-to-string (asdf::*VERBOSE-OUT*)
+ (asdf:run-shell-command "id -ur"))))
+ (with-input-from-string (stream uid-string)
+ (read-line stream)
+ (handler-case (parse-integer (read-line stream))
+ (error () (error "Unable to find out user ID")))))))
+
+(defun pathname-root (pathname)
+ (make-pathname :host (pathname-host pathname)
+ :device (pathname-device pathname)
+ :directory '(:absolute)
+ :name nil :type nil :version nil))
+
+(defun truenamize (p)
+ "Resolve as much of a pathname as possible"
+ (block nil
+ (when (typep p 'logical-pathname) (return p))
+ (let* ((p (merge-pathnames* p))
+ (directory (pathname-directory p)))
+ (when (typep p 'logical-pathname) (return p))
+ (ignore-errors (return (truename p)))
+ (when (stringp directory)
+ (return p))
+ (when (not (eq :absolute (car directory)))
+ (return p))
+ (let ((sofar (ignore-errors (truename (pathname-root p)))))
+ (unless sofar (return p))
+ (loop :for component :in (cdr directory)
+ :for rest :on (cdr directory)
+ :for more = (ignore-errors
+ (truename
+ (merge-pathnames*
+ (make-pathname :directory `(:relative ,component))
+ sofar))) :do
+ (if more
+ (setf sofar more)
+ (return
+ (merge-pathnames*
+ (make-pathname :host nil :device nil
+ :directory `(:relative , at rest)
+ :defaults p)
+ sofar)))
+ :finally
+ (return
+ (merge-pathnames*
+ (make-pathname :host nil :device nil
+ :directory nil
+ :defaults p)
+ sofar)))))))
+
+(defun lispize-pathname (input-file)
+ (make-pathname :type "lisp" :defaults input-file))
+
+;;;; -------------------------------------------------------------------------
+;;;; Classes, Conditions
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
@@ -153,39 +729,58 @@
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
- (apply #'format s (format-control c) (format-arguments c)))))
+ (apply #'format s (format-control c) (format-arguments c)))))
+
+(define-condition load-system-definition-error (system-definition-error)
+ ((name :initarg :name :reader error-name)
+ (pathname :initarg :pathname :reader error-pathname)
+ (condition :initarg :condition :reader error-condition))
+ (:report (lambda (c s)
+ (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
+ (error-name c) (error-pathname c) (error-condition c)))))
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components)))
(define-condition duplicate-names (system-definition-error)
- ((name :initarg :name :reader duplicate-names-name)))
+ ((name :initarg :name :reader duplicate-names-name))
+ (:report (lambda (c s)
+ (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
+ (duplicate-names-name c)))))
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
- (version :initform nil :reader missing-version :initarg :version)
(parent :initform nil :reader missing-parent :initarg :parent)))
+(define-condition missing-component-of-version (missing-component)
+ ((version :initform nil :reader missing-version :initarg :version)))
+
(define-condition missing-dependency (missing-component)
((required-by :initarg :required-by :reader missing-required-by)))
+(define-condition missing-dependency-of-version (missing-dependency
+ missing-component-of-version)
+ ())
+
(define-condition operation-error (error)
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
- (format s "~@<erred while invoking ~A on ~A~@:>"
- (error-operation c) (error-component c)))))
+ (format s "~@<erred while invoking ~A on ~A~@:>"
+ (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defclass component ()
((name :accessor component-name :initarg :name :documentation
- "Component name: designator for a string composed of portable pathname characters")
+ "Component name: designator for a string composed of portable pathname characters")
(version :accessor component-version :initarg :version)
- (in-order-to :initform nil :initarg :in-order-to)
- ;;; XXX crap name
- (do-first :initform nil :initarg :do-first)
+ (in-order-to :initform nil :initarg :in-order-to
+ :accessor component-in-order-to)
+ ;; XXX crap name
+ (do-first :initform nil :initarg :do-first
+ :accessor component-do-first)
;; methods defined using the "inline" style inside a defsystem form:
;; need to store them somewhere so we can delete them when the system
;; is re-evaluated
@@ -194,36 +789,41 @@
;; no direct accessor for pathname, we do this as a method to allow
;; it to default in funky ways if not supplied
(relative-pathname :initarg :pathname)
- (operation-times :initform (make-hash-table )
- :accessor component-operation-times)
+ (absolute-pathname)
+ (operation-times :initform (make-hash-table)
+ :accessor component-operation-times)
;; XXX we should provide some atomic interface for updating the
;; component properties
(properties :accessor component-properties :initarg :properties
- :initform nil)))
+ :initform nil)))
;;;; methods: conditions
(defmethod print-object ((c missing-dependency) s)
(format s "~@<~A, required by ~A~@:>"
- (call-next-method c nil) (missing-required-by c)))
+ (call-next-method c nil) (missing-required-by c)))
(defun sysdef-error (format &rest arguments)
- (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
+ (error 'formatted-system-definition-error :format-control
+ format :format-arguments arguments))
;;;; methods: components
(defmethod print-object ((c missing-component) s)
- (format s "~@<component ~S not found~
- ~@[ or does not match version ~A~]~
+ (format s "~@<component ~S not found~
~@[ in ~A~]~@:>"
- (missing-requires c)
- (missing-version c)
- (when (missing-parent c)
- (component-name (missing-parent c)))))
+ (missing-requires c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
+
+(defmethod print-object ((c missing-component-of-version) s)
+ (format s "~@<component ~S does not match version ~A~
+ ~@[ in ~A~]~@:>"
+ (missing-requires c)
+ (missing-version c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
-(defgeneric component-system (component)
- (:documentation "Find the top-level system containing COMPONENT"))
-
(defmethod component-system ((component component))
(aif (component-parent component)
(component-system it)
@@ -239,45 +839,42 @@
;; what to do if we can't satisfy a dependency of one of this module's
;; components. This allows a limited form of conditional processing
(if-component-dep-fails :initform :fail
- :accessor module-if-component-dep-fails
- :initarg :if-component-dep-fails)
+ :accessor module-if-component-dep-fails
+ :initarg :if-component-dep-fails)
(default-component-class :accessor module-default-component-class
:initform 'cl-source-file :initarg :default-component-class)))
-(defgeneric component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular component."))
-
(defun component-parent-pathname (component)
- (aif (component-parent component)
- (component-pathname it)
- *default-pathname-defaults*))
-
-(defgeneric component-relative-pathname (component)
- (:documentation "Extracts the relative pathname applicable for a particular component."))
-
-(defmethod component-relative-pathname ((component module))
- (or (slot-value component 'relative-pathname)
- (make-pathname
- :directory `(:relative ,(component-name component))
- :host (pathname-host (component-parent-pathname component)))))
+ ;; No default anymore (in particular, no *default-pathname-defaults*).
+ ;; If you force component to have a NULL pathname, you better arrange
+ ;; for any of its children to explicitly provide a proper absolute pathname
+ ;; wherever a pathname is actually wanted.
+ (let ((parent (component-parent component)))
+ (when parent
+ (component-pathname parent))))
(defmethod component-pathname ((component component))
- (let ((*default-pathname-defaults* (component-parent-pathname component)))
- (merge-pathnames (component-relative-pathname component))))
-
-(defgeneric component-property (component property))
+ (if (slot-boundp component 'absolute-pathname)
+ (slot-value component 'absolute-pathname)
+ (let ((pathname
+ (merge-pathnames*
+ (component-relative-pathname component)
+ (component-parent-pathname component))))
+ (unless (or (null pathname) (absolute-pathname-p pathname))
+ (error "Invalid relative pathname ~S for component ~S" pathname component))
+ (setf (slot-value component 'absolute-pathname) pathname)
+ pathname)))
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
-(defgeneric (setf component-property) (new-value component property))
-
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties))))))
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties)))))
+ new-value)
(defclass system (module)
((description :accessor system-description :initarg :description)
@@ -285,185 +882,296 @@
:accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence)))
-
-;;; version-satisfies
+ (licence :accessor system-licence :initarg :licence
+ :accessor system-license :initarg :license)
+ (source-file :reader system-source-file :initarg :source-file
+ :writer %set-system-source-file)))
-;;; with apologies to christophe rhodes ...
-(defun split (string &optional max (ws '(#\Space #\Tab)))
- (flet ((is-ws (char) (find char ws)))
- (nreverse
- (let ((list nil) (start 0) (words 0) end)
- (loop
- (when (and max (>= words (1- max)))
- (return (cons (subseq string start) list)))
- (setf end (position-if #'is-ws string :start start))
- (push (subseq string start end) list)
- (incf words)
- (unless end (return list))
- (setf start (1+ end)))))))
-
-(defgeneric version-satisfies (component version))
+;;;; -------------------------------------------------------------------------
+;;;; version-satisfies
(defmethod version-satisfies ((c component) version)
(unless (and version (slot-boundp c 'version))
(return-from version-satisfies t))
+ (version-satisfies (component-version c) version))
+
+(defmethod version-satisfies ((cver string) version)
(let ((x (mapcar #'parse-integer
- (split (component-version c) nil '(#\.))))
- (y (mapcar #'parse-integer
- (split version nil '(#\.)))))
+ (split-string cver :separator ".")))
+ (y (mapcar #'parse-integer
+ (split-string version :separator "."))))
(labels ((bigger (x y)
- (cond ((not y) t)
- ((not x) nil)
- ((> (car x) (car y)) t)
- ((= (car x) (car y))
- (bigger (cdr x) (cdr y))))))
+ (cond ((not y) t)
+ ((not x) nil)
+ ((> (car x) (car y)) t)
+ ((= (car x) (car y))
+ (bigger (cdr x) (cdr y))))))
(and (= (car x) (car y))
- (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+ (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding systems
+;;;; -------------------------------------------------------------------------
+;;;; Finding systems
+
+(defun make-defined-systems-table ()
+ (make-hash-table :test 'equal))
+
+(defvar *defined-systems* (make-defined-systems-table)
+ "This is a hash table whose keys are strings, being the
+names of the systems, and whose values are pairs, the first
+element of which is a universal-time indicating when the
+system definition was last updated, and the second element
+of which is a system object.")
-(defvar *defined-systems* (make-hash-table :test 'equal))
(defun coerce-name (name)
- (typecase name
- (component (component-name name))
- (symbol (string-downcase (symbol-name name)))
- (string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+
+(defun system-registered-p (name)
+ (gethash (coerce-name name) *defined-systems*))
+
+(defun map-systems (fn)
+ "Apply `fn` to each defined system.
+
+`fn` should be a function of one argument. It will be
+called with an object of type asdf:system."
+ (maphash (lambda (_ datum)
+ (declare (ignore _))
+ (destructuring-bind (_ . def) datum
+ (declare (ignore _))
+ (funcall fn def)))
+ *defined-systems*))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
-(defvar *system-definition-search-functions*
- '(sysdef-central-registry-search))
+(defparameter *system-definition-search-functions*
+ '(sysdef-central-registry-search sysdef-source-registry-search))
(defun system-definition-pathname (system)
- (some (lambda (x) (funcall x system))
- *system-definition-search-functions*))
-
-(defvar *central-registry*
- '(*default-pathname-defaults*
- #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
- #+nil "telent:asdf;systems;"))
+ (let ((system-name (coerce-name system)))
+ (or
+ (some (lambda (x) (funcall x system-name))
+ *system-definition-search-functions*)
+ (let ((system-pair (system-registered-p system-name)))
+ (and system-pair
+ (system-source-file (cdr system-pair)))))))
+
+(defvar *central-registry* nil
+"A list of 'system directory designators' ASDF uses to find systems.
+
+A 'system directory designator' is a pathname or an expression
+which evaluates to a pathname. For example:
+
+ (setf asdf:*central-registry*
+ (list '*default-pathname-defaults*
+ #p\"/home/me/cl/systems/\"
+ #p\"/usr/share/common-lisp/systems/\"))
+
+This is for backward compatibilily.
+Going forward, we recommend new users should be using the source-registry.
+")
(defun sysdef-central-registry-search (system)
- (let ((name (coerce-name system)))
+ (let ((name (coerce-name system))
+ (to-remove nil)
+ (to-replace nil))
(block nil
- (dolist (dir *central-registry*)
- (let* ((defaults (eval dir))
- (file (and defaults
- (make-pathname
- :defaults defaults :version :newest
- :name name :type "asd" :case :local))))
- (if (and file (probe-file file))
- (return file)))))))
+ (unwind-protect
+ (dolist (dir *central-registry*)
+ (let ((defaults (eval dir)))
+ (when defaults
+ (cond ((directory-pathname-p defaults)
+ (let ((file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local)))
+ #+(and (or win32 windows) (not :clisp))
+ (shortcut (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd.lnk" :case :local)))
+ (if (and file (probe-file file))
+ (return file))
+ #+(and (or win32 windows) (not :clisp))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target)))))))
+ (t
+ (restart-case
+ (let* ((*print-circle* nil)
+ (message
+ (format nil
+ "~@<While searching for system `~a`: `~a` evaluated ~
+to `~a` which is not a directory.~@:>"
+ system dir defaults)))
+ (error message))
+ (remove-entry-from-registry ()
+ :report "Remove entry from *central-registry* and continue"
+ (push dir to-remove))
+ (coerce-entry-to-directory ()
+ :report (lambda (s)
+ (format s "Coerce entry to ~a, replace ~a and continue."
+ (ensure-directory-pathname defaults) dir))
+ (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
+ ;; cleanup
+ (dolist (dir to-remove)
+ (setf *central-registry* (remove dir *central-registry*)))
+ (dolist (pair to-replace)
+ (let* ((current (car pair))
+ (new (cdr pair))
+ (position (position current *central-registry*)))
+ (setf *central-registry*
+ (append (subseq *central-registry* 0 position)
+ (list new)
+ (subseq *central-registry* (1+ position))))))))))
(defun make-temporary-package ()
(flet ((try (counter)
(ignore-errors
- (make-package (format nil "ASDF~D" counter)
- :use '(:cl :asdf)))))
+ (make-package (format nil "~a~D" 'asdf counter)
+ :use '(:cl :asdf)))))
(do* ((counter 0 (+ counter 1))
(package (try counter) (try counter)))
(package package))))
+(defun safe-file-write-date (pathname)
+ ;; if FILE-WRITE-DATE returns NIL, it's possible that the
+ ;; user or some other agent has deleted an input file. If
+ ;; that's the case, well, that's not good, but as long as
+ ;; the operation is otherwise considered to be done we
+ ;; could continue and survive.
+ (or (and pathname (file-write-date pathname))
+ (progn
+ (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+ pathname)
+ 0)))
+
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
- (in-memory (gethash name *defined-systems*))
- (on-disk (system-definition-pathname name)))
+ (in-memory (system-registered-p name))
+ (on-disk (system-definition-pathname name)))
(when (and on-disk
- (or (not in-memory)
- (< (car in-memory) (file-write-date on-disk))))
+ (or (not in-memory)
+ (< (car in-memory) (safe-file-write-date on-disk))))
(let ((package (make-temporary-package)))
(unwind-protect
- (let ((*package* package))
- (format
- *verbose-out*
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- ;; FIXME: This wants to be (ENOUGH-NAMESTRING
- ;; ON-DISK), but CMUCL barfs on that.
- on-disk
- *package*)
- (load on-disk))
+ (handler-bind
+ ((error (lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname on-disk
+ :condition condition))))
+ (let ((*package* package))
+ (asdf-message
+ "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ ;; FIXME: This wants to be (ENOUGH-NAMESTRING
+ ;; ON-DISK), but CMUCL barfs on that.
+ on-disk
+ *package*)
+ (load on-disk)))
(delete-package package))))
- (let ((in-memory (gethash name *defined-systems*)))
+ (let ((in-memory (system-registered-p name)))
(if in-memory
- (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
- (cdr in-memory))
- (if error-p (error 'missing-component :requires name))))))
+ (progn (when on-disk (setf (car in-memory)
+ (safe-file-write-date on-disk)))
+ (cdr in-memory))
+ (when error-p (error 'missing-component :requires name))))))
(defun register-system (name system)
- (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
- (setf (gethash (coerce-name name) *defined-systems*)
- (cons (get-universal-time) system)))
+ (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
+ (setf (gethash (coerce-name name) *defined-systems*)
+ (cons (get-universal-time) system)))
-(defun system-registered-p (name)
- (gethash (coerce-name name) *defined-systems*))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding components
-
-(defgeneric find-component (module name &optional version)
- (:documentation "Finds the component with name NAME present in the
-MODULE module; if MODULE is nil, then the component is assumed to be a
-system."))
+;;;; -------------------------------------------------------------------------
+;;;; Finding components
(defmethod find-component ((module module) name &optional version)
(if (slot-boundp module 'components)
(let ((m (find name (module-components module)
- :test #'equal :key #'component-name)))
- (if (and m (version-satisfies m version)) m))))
-
+ :test #'equal :key #'component-name)))
+ (if (and m (version-satisfies m version)) m))))
+
;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name &optional version)
+ (declare (ignorable module))
(let ((m (find-system name nil)))
(if (and m (version-satisfies m version)) m)))
;;; component subclasses
-(defclass source-file (component) ())
+(defclass source-file (component)
+ ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
-(defclass cl-source-file (source-file) ())
-(defclass c-source-file (source-file) ())
-(defclass java-source-file (source-file) ())
+(defclass cl-source-file (source-file)
+ ((type :initform "lisp")))
+(defclass c-source-file (source-file)
+ ((type :initform "c")))
+(defclass java-source-file (source-file)
+ ((type :initform "java")))
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
-(defclass html-file (doc-file) ())
+(defclass html-file (doc-file)
+ ((type :initform "html")))
-(defgeneric source-file-type (component system))
-(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
-(defmethod source-file-type ((c c-source-file) (s module)) "c")
-(defmethod source-file-type ((c java-source-file) (s module)) "java")
-(defmethod source-file-type ((c html-file) (s module)) "html")
-(defmethod source-file-type ((c static-file) (s module)) nil)
-
-(defmethod component-relative-pathname ((component source-file))
- (let ((relative-pathname (slot-value component 'relative-pathname)))
- (if relative-pathname
- (merge-pathnames
- relative-pathname
- (make-pathname
- :type (source-file-type component (component-system component))))
- (let* ((*default-pathname-defaults*
- (component-parent-pathname component))
- (name-type
- (make-pathname
- :name (component-name component)
- :type (source-file-type component
- (component-system component)))))
- name-type))))
+(defmethod source-file-type ((component module) (s module)) :directory)
+(defmethod source-file-type ((component source-file) (s module))
+ (source-file-explicit-type component))
+
+(defun merge-component-name-type (name &key type defaults)
+ ;; The defaults are required notably because they provide the default host
+ ;; to the below make-pathname, which may crucially matter to people using
+ ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
+ ;; NOTE that the host and device slots will be taken from the defaults,
+ ;; but that should only matter if you either (a) use absolute pathnames, or
+ ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
+ ;; ASDF-UTILITIES:MERGE-PATHNAMES*
+ (etypecase name
+ (pathname
+ name)
+ (symbol
+ (merge-component-name-type (string-downcase name) :type type :defaults defaults))
+ (string
+ (multiple-value-bind (relative path filename)
+ (component-name-to-pathname-components name (eq type :directory))
+ (multiple-value-bind (name type)
+ (cond
+ ((or (eq type :directory) (null filename))
+ (values nil nil))
+ (type
+ (values filename type))
+ (t
+ (split-name-type filename)))
+ (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
+ (host (pathname-host defaults))
+ (device (pathname-device defaults)))
+ (make-pathname :directory `(,relative , at path)
+ :name name :type type
+ :host host :device device)))))))
+
+(defmethod component-relative-pathname ((component component))
+ (merge-component-name-type
+ (or (slot-value component 'relative-pathname)
+ (component-name component))
+ :type (source-file-type component (component-system component))
+ :defaults (component-parent-pathname component)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; operations
+;;;; -------------------------------------------------------------------------
+;;;; Operations
-;;; one of these is instantiated whenever (operate ) is called
+;;; one of these is instantiated whenever #'operate is called
(defclass operation ()
- ((forced :initform nil :initarg :force :accessor operation-forced)
+ (
+ ;; what is the TYPE of this slot? seems like it should be boolean,
+ ;; but TRAVERSE checks to see if it's a list of component names...
+ ;; [2010/02/07:rpg]
+ (forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
- :accessor operation-original-initargs)
+ :accessor operation-original-initargs)
(visited-nodes :initform nil :accessor operation-visited-nodes)
(visiting-nodes :initform nil :accessor operation-visiting-nodes)
(parent :initform nil :initarg :parent :accessor operation-parent)))
@@ -474,24 +1182,15 @@
(prin1 (operation-original-initargs o) stream))))
(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
- &allow-other-keys)
- (declare (ignore slot-names force))
+ &key force
+ &allow-other-keys)
+ (declare (ignorable operation slot-names force))
;; empty method to disable initarg validity checking
- )
-
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+ (values))
(defun node-for (o c)
(cons (class-name (class-of o)) c))
-(defgeneric operation-ancestor (operation)
- (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
-
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
(operation-ancestor it)
@@ -499,210 +1198,308 @@
(defun make-sub-operation (c o dep-c dep-o)
+ "C is a component, O is an operation, DEP-C is another
+component, and DEP-O, confusingly enough, is an operation
+class specifier, not an operation."
(let* ((args (copy-list (operation-original-initargs o)))
- (force-p (getf args :force)))
+ (force-p (getf args :force)))
;; note explicit comparison with T: any other non-NIL force value
;; (e.g. :recursive) will pass through
(cond ((and (null (component-parent c))
- (null (component-parent dep-c))
- (not (eql c dep-c)))
- (when (eql force-p t)
- (setf (getf args :force) nil))
- (apply #'make-instance dep-o
- :parent o
- :original-initargs args args))
- ((subtypep (type-of o) dep-o)
- o)
- (t
- (apply #'make-instance dep-o
- :parent o :original-initargs args args)))))
-
+ (null (component-parent dep-c))
+ (not (eql c dep-c)))
+ (when (eql force-p t)
+ (setf (getf args :force) nil))
+ (apply #'make-instance dep-o
+ :parent o
+ :original-initargs args args))
+ ((subtypep (type-of o) dep-o)
+ o)
+ (t
+ (apply #'make-instance dep-o
+ :parent o :original-initargs args args)))))
-(defgeneric visit-component (operation component data))
(defmethod visit-component ((o operation) (c component) data)
(unless (component-visited-p o c)
(push (cons (node-for o c) data)
- (operation-visited-nodes (operation-ancestor o)))))
-
-(defgeneric component-visited-p (operation component))
+ (operation-visited-nodes (operation-ancestor o)))))
(defmethod component-visited-p ((o operation) (c component))
(assoc (node-for o c)
- (operation-visited-nodes (operation-ancestor o))
- :test 'equal))
-
-(defgeneric (setf visiting-component) (new-value operation component))
+ (operation-visited-nodes (operation-ancestor o))
+ :test 'equal))
(defmethod (setf visiting-component) (new-value operation component)
;; MCL complains about unused lexical variables
- (declare (ignorable new-value operation component)))
+ (declare (ignorable operation component))
+ new-value)
(defmethod (setf visiting-component) (new-value (o operation) (c component))
(let ((node (node-for o c))
- (a (operation-ancestor o)))
+ (a (operation-ancestor o)))
(if new-value
- (pushnew node (operation-visiting-nodes a) :test 'equal)
- (setf (operation-visiting-nodes a)
- (remove node (operation-visiting-nodes a) :test 'equal)))))
-
-(defgeneric component-visiting-p (operation component))
+ (pushnew node (operation-visiting-nodes a) :test 'equal)
+ (setf (operation-visiting-nodes a)
+ (remove node (operation-visiting-nodes a) :test 'equal))))
+ new-value)
(defmethod component-visiting-p ((o operation) (c component))
- (let ((node (cons o c)))
+ (let ((node (node-for o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
- :test 'equal)))
+ :test 'equal)))
-(defgeneric component-depends-on (operation component))
+(defmethod component-depends-on ((op-spec symbol) (c component))
+ (component-depends-on (make-instance op-spec) c))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
- (slot-value c 'in-order-to))))
-
-(defgeneric component-self-dependencies (operation component))
+ (component-in-order-to c))))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
(remove-if-not (lambda (x)
- (member (component-name c) (cdr x) :test #'string=))
- all-deps)))
-
+ (member (component-name c) (cdr x) :test #'string=))
+ all-deps)))
+
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
- (self-deps (component-self-dependencies operation c)))
+ (self-deps (component-self-dependencies operation c)))
(if self-deps
- (mapcan (lambda (dep)
- (destructuring-bind (op name) dep
- (output-files (make-instance op)
- (find-component parent name))))
- self-deps)
- ;; no previous operations needed? I guess we work with the
- ;; original source file, then
- (list (component-pathname c)))))
+ (mapcan (lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
+ self-deps)
+ ;; no previous operations needed? I guess we work with the
+ ;; original source file, then
+ (list (component-pathname c)))))
(defmethod input-files ((operation operation) (c module)) nil)
(defmethod operation-done-p ((o operation) (c component))
- (flet ((fwd-or-return-t (file)
- ;; if FILE-WRITE-DATE returns NIL, it's possible that the
- ;; user or some other agent has deleted an input file. If
- ;; that's the case, well, that's not good, but as long as
- ;; the operation is otherwise considered to be done we
- ;; could continue and survive.
- (let ((date (file-write-date file)))
- (cond
- (date)
- (t
- (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
- operation ~S on component ~S as done.~@:>"
- file o c)
- (return-from operation-done-p t))))))
- (let ((out-files (output-files o c))
- (in-files (input-files o c)))
- (cond ((and (not in-files) (not out-files))
- ;; arbitrary decision: an operation that uses nothing to
- ;; produce nothing probably isn't doing much
- t)
- ((not out-files)
- (let ((op-done
- (gethash (type-of o)
- (component-operation-times c))))
- (and op-done
- (>= op-done
- (apply #'max
- (mapcar #'fwd-or-return-t in-files))))))
- ((not in-files) nil)
- (t
- (and
- (every #'probe-file out-files)
- (> (apply #'min (mapcar #'file-write-date out-files))
- (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c))
+ (op-time (gethash (type-of o) (component-operation-times c))))
+ (flet ((earliest-out ()
+ (reduce #'min (mapcar #'safe-file-write-date out-files)))
+ (latest-in ()
+ (reduce #'max (mapcar #'safe-file-write-date in-files))))
+ (cond
+ ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much.
+ ;; e.g. operations on systems, modules that have no immediate action,
+ ;; but are only meaningful through traversed dependencies
+ t)
+ ((not out-files)
+ ;; an operation without output-files is probably meant
+ ;; for its side-effects in the current image,
+ ;; assumed to be idem-potent,
+ ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
+ (and op-time (>= op-time (latest-in))))
+ ((not in-files)
+ ;; an operation without output-files and no input-files
+ ;; is probably meant for its side-effects on the file-system,
+ ;; assumed to have to be done everytime.
+ ;; (I don't think there is any such case in ASDF unless extended)
+ nil)
+ (t
+ ;; an operation with both input and output files is assumed
+ ;; as computing the latter from the former,
+ ;; assumed to have been done if the latter are all older
+ ;; than the former.
+ ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
+ ;; We use >= instead of > to play nice with generated files.
+ ;; This opens a race condition if an input file is changed
+ ;; after the output is created but within the same second
+ ;; of filesystem time; but the same race condition exists
+ ;; whenever the computation from input to output takes more
+ ;; than one second of filesystem time (or just crosses the
+ ;; second). So that's cool.
+ (and
+ (every #'probe-file in-files)
+ (every #'probe-file out-files)
+ (>= (earliest-out) (latest-in))))))))
+
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes. And CLISP doesn't have non-standard method
-;;; combinations, so let's keep it simple and aspire to portability
+;;; for our purposes.
+
+(defvar *forcing* nil
+ "This dynamically-bound variable is used to force operations in
+recursive calls to traverse.")
-(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
- (let ((forced nil))
- (labels ((do-one-dep (required-op required-c required-v)
- (let* ((dep-c (or (find-component
- (component-parent c)
- ;; XXX tacky. really we should build the
- ;; in-order-to slot with canonicalized
- ;; names instead of coercing this late
- (coerce-name required-c) required-v)
- (error 'missing-dependency :required-by c
- :version required-v
- :requires required-c)))
- (op (make-sub-operation c operation dep-c required-op)))
- (traverse op dep-c)))
- (do-dep (op dep)
- (cond ((eq op 'feature)
- (or (member (car dep) *features*)
- (error 'missing-dependency :required-by c
- :requires (car dep) :version nil)))
- (t
- (dolist (d dep)
+ (let ((forced nil)) ;return value -- everyone side-effects onto this
+ (labels ((%do-one-dep (required-op required-c required-v)
+ ;; returns a partial plan that results from performing required-op
+ ;; on required-c, possibly with a required-vERSION
+ (let* ((dep-c (or (find-component
+ (component-parent c)
+ ;; XXX tacky. really we should build the
+ ;; in-order-to slot with canonicalized
+ ;; names instead of coercing this late
+ (coerce-name required-c) required-v)
+ (if required-v
+ (error 'missing-dependency-of-version
+ :required-by c
+ :version required-v
+ :requires required-c)
+ (error 'missing-dependency
+ :required-by c
+ :requires required-c))))
+ (op (make-sub-operation c operation dep-c required-op)))
+ (traverse op dep-c)))
+ (do-one-dep (required-op required-c required-v)
+ ;; this function is a thin, error-handling wrapper around
+ ;; %do-one-dep. Returns a partial plan per that function.
+ (loop
+ (restart-case
+ (return (%do-one-dep required-op required-c required-v))
+ (retry ()
+ :report (lambda (s)
+ (format s "~@<Retry loading component ~S.~@:>"
+ required-c))
+ :test
+ (lambda (c)
+#|
+ (print (list :c1 c (typep c 'missing-dependency)))
+ (when (typep c 'missing-dependency)
+ (print (list :c2 (missing-requires c) required-c
+ (equalp (missing-requires c)
+ required-c))))
+|#
+ (or (null c)
+ (and (typep c 'missing-dependency)
+ (equalp (missing-requires c)
+ required-c))))))))
+ (do-dep (op dep)
+ ;; type of arguments uncertain: op seems to at least potentially be a
+ ;; symbol, rather than an operation
+ ;; dep is either a list of component names (?) or (we hope) a single
+ ;; component name.
+ ;; handle a single dependency, returns nothing of interest --- side-
+ ;; effects onto the FORCED variable, which is scoped over TRAVERSE
+ (cond ((eq op 'feature)
+ (or (member (car dep) *features*)
+ (error 'missing-dependency
+ :required-by c
+ :requires (car dep))))
+ (t
+ (dolist (d dep)
+ ;; structured dependencies --- this parses keywords
+ ;; the keywords could be broken out and cleanly (extensibly)
+ ;; processed by EQL methods, but for the pervasive side-effecting
+ ;; onto FORCED
(cond ((consp d)
- (assert (string-equal
- (symbol-name (first d))
- "VERSION"))
- (appendf forced
- (do-one-dep op (second d) (third d))))
+ (cond ((string-equal
+ (symbol-name (first d))
+ "VERSION")
+ ;; https://bugs.launchpad.net/asdf/+bug/527788
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ ;; this particular subform is not documented, indeed
+ ;; clashes with the documentation, since it assumes a
+ ;; third component.
+ ;; See https://bugs.launchpad.net/asdf/+bug/518467
+ ((and (string-equal
+ (symbol-name (first d))
+ "FEATURE")
+ (find (second d) *features*
+ :test 'string-equal))
+ (appendf
+ forced
+ (do-one-dep op (third d) nil)))
+ (t
+ (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
- (return-from traverse
- (if (cdr it) (list (cons 'pruned-op c)) nil)))
+ (return-from traverse
+ (if (cdr it) (list (cons 'pruned-op c)) nil)))
;; dependencies
(if (component-visiting-p operation c)
- (error 'circular-dependency :components (list c)))
+ (error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
- (loop for (required-op . deps) in (component-depends-on operation c)
- do (do-dep required-op deps))
- ;; constituent bits
- (let ((module-ops
- (when (typep c 'module)
- (let ((at-least-one nil)
- (forced nil)
- (error nil))
- (loop for kid in (module-components c)
- do (handler-case
- (appendf forced (traverse operation kid ))
- (missing-dependency (condition)
- (if (eq (module-if-component-dep-fails c) :fail)
- (error condition))
- (setf error condition))
- (:no-error (c)
- (declare (ignore c))
- (setf at-least-one t))))
- (when (and (eq (module-if-component-dep-fails c) :try-next)
- (not at-least-one))
- (error error))
- forced))))
- ;; now the thing itself
- (when (or forced module-ops
- (not (operation-done-p operation c))
- (let ((f (operation-forced (operation-ancestor operation))))
- (and f (or (not (consp f))
- (member (component-name
- (operation-ancestor operation))
- (mapcar #'coerce-name f)
- :test #'string=)))))
- (let ((do-first (cdr (assoc (class-name (class-of operation))
- (slot-value c 'do-first)))))
- (loop for (required-op . deps) in do-first
- do (do-dep required-op deps)))
- (setf forced (append (delete 'pruned-op forced :key #'car)
- (delete 'pruned-op module-ops :key #'car)
- (list (cons operation c))))))
- (setf (visiting-component operation c) nil)
+ (unwind-protect
+ (progn
+ ;; first we check and do all the dependencies for the
+ ;; module. Operations planned in this loop will show up
+ ;; in the contents of the FORCED variable, and are consumed
+ ;; downstream (watch out for the shadowing FORCED variable
+ ;; around the DOLIST below!)
+ (let ((*forcing* nil))
+ ;; upstream dependencies are never forced to happen just because
+ ;; the things that depend on them are....
+ (loop :for (required-op . deps) :in
+ (component-depends-on operation c)
+ :do (do-dep required-op deps)))
+ ;; constituent bits
+ (let ((module-ops
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ ;; this is set based on the results of the
+ ;; dependencies and whether we are in the
+ ;; context of a *forcing* call...
+ (must-operate (or *forcing*
+ ;; inter-system dependencies do NOT trigger
+ ;; building components
+ (and
+ (not (typep c 'system))
+ forced)))
+ (error nil))
+ (dolist (kid (module-components c))
+ (handler-case
+ (let ((*forcing* must-operate))
+ (appendf forced (traverse operation kid)))
+ (missing-dependency (condition)
+ (when (eq (module-if-component-dep-fails c)
+ :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c)
+ :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ ;; the test here is a bit oddly written. FORCED here doesn't
+ ;; mean that this operation is forced on this component, but that
+ ;; something upstream of this component has been forced.
+ (when (or forced module-ops
+ *forcing*
+ (not (operation-done-p operation c))
+ (let ((f (operation-forced
+ (operation-ancestor operation))))
+ ;; does anyone fully understand the following condition?
+ ;; if so, please add a comment to explain it...
+ (and f (or (not (consp f))
+ (member (component-name
+ (operation-ancestor operation))
+ (mapcar #'coerce-name f)
+ ;; this was string=, but for the benefit
+ ;; of mlisp, we use string-equal for this
+ ;; purpose.
+ :test #'string-equal)))))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (component-do-first c)))))
+ (loop :for (required-op . deps) :in do-first
+ :do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c)))))))
+ (setf (visiting-component operation c) nil))
(visit-component operation c (and forced t))
forced)))
-
+
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
@@ -714,54 +1511,68 @@
nil)
(defmethod explain ((operation operation) (component component))
- (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
+ (asdf-message "~&;;; ~A on ~A~%" operation component))
-;;; compile-op
+;;;; -------------------------------------------------------------------------
+;;;; compile-op
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
(on-warnings :initarg :on-warnings :accessor operation-on-warnings
- :initform *compile-file-warnings-behaviour*)
+ :initform *compile-file-warnings-behaviour*)
(on-failure :initarg :on-failure :accessor operation-on-failure
- :initform *compile-file-failure-behaviour*)))
+ :initform *compile-file-failure-behaviour*)
+ (flags :initarg :flags :accessor compile-op-flags
+ :initform #-ecl nil #+ecl '(:system-p t))))
(defmethod perform :before ((operation compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
+#+ecl
+(defmethod perform :after ((o compile-op) (c cl-source-file))
+ ;; Note how we use OUTPUT-FILES to find the binary locations
+ ;; This allows the user to override the names.
+ (let* ((input (output-files o c))
+ (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
+ (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
+
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
- (get-universal-time)))
+ (get-universal-time)))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
#-:broken-fasl-loader
(let ((source-file (component-pathname c))
- (output-file (car (output-files operation c))))
+ (output-file (car (output-files operation c))))
(multiple-value-bind (output warnings-p failure-p)
- (compile-file source-file
- :output-file output-file)
- ;(declare (ignore output))
+ (apply #'compile-file source-file :output-file output-file
+ (compile-op-flags operation))
(when warnings-p
- (case (operation-on-warnings operation)
- (:warn (warn
- "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
- operation c))
- (:error (error 'compile-warned :component c :operation operation))
- (:ignore nil)))
+ (case (operation-on-warnings operation)
+ (:warn (warn
+ "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
+ operation c))
+ (:error (error 'compile-warned :component c :operation operation))
+ (:ignore nil)))
(when failure-p
- (case (operation-on-failure operation)
- (:warn (warn
- "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
- operation c))
- (:error (error 'compile-failed :component c :operation operation))
- (:ignore nil)))
+ (case (operation-on-failure operation)
+ (:warn (warn
+ "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+ operation c))
+ (:error (error 'compile-failed :component c :operation operation))
+ (:ignore nil)))
(unless output
- (error 'compile-error :component c :operation operation)))))
+ (error 'compile-error :component c :operation operation)))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
- #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
- #+:broken-fasl-loader (list (component-pathname c)))
+ (let ((p (lispize-pathname (component-pathname c))))
+ #-:broken-fasl-loader
+ (list #-ecl (compile-file-pathname p)
+ #+ecl (compile-file-pathname p :type :object)
+ #+ecl (compile-file-pathname p :type :fasl))
+ #+:broken-fasl-loader (list p)))
(defmethod perform ((operation compile-op) (c static-file))
nil)
@@ -769,15 +1580,50 @@
(defmethod output-files ((operation compile-op) (c static-file))
nil)
-;;; load-op
+(defmethod input-files ((op compile-op) (c static-file))
+ nil)
+
-(defclass load-op (operation) ())
+;;;; -------------------------------------------------------------------------
+;;;; load-op
+
+(defclass basic-load-op (operation) ())
+
+(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
- (mapcar #'load (input-files o c)))
+ #-ecl (mapcar #'load (input-files o c))
+ #+ecl (loop :for i :in (input-files o c)
+ :unless (string= (pathname-type i) "fas")
+ :collect (let ((output (compile-file-pathname (lispize-pathname i))))
+ (load output))))
+
+(defmethod perform-with-restarts (operation component)
+ (perform operation component))
+
+(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
+ (let ((state :initial))
+ (loop :until (or (eq state :success)
+ (eq state :failure)) :do
+ (case state
+ (:recompiled
+ (setf state :failure)
+ (call-next-method)
+ (setf state :success))
+ (:failed-load
+ (setf state :recompiled)
+ (perform (make-instance 'compile-op) c))
+ (t
+ (with-simple-restart
+ (try-recompiling "Recompile ~a and try loading it again"
+ (component-name c))
+ (setf state :failed-load)
+ (call-next-method)
+ (setf state :success)))))))
(defmethod perform ((operation load-op) (c static-file))
nil)
+
(defmethod operation-done-p ((operation load-op) (c static-file))
t)
@@ -788,9 +1634,10 @@
(cons (list 'compile-op (component-name c))
(call-next-method)))
-;;; load-source-op
+;;;; -------------------------------------------------------------------------
+;;;; load-source-op
-(defclass load-source-op (operation) ())
+(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(let ((source (component-pathname c)))
@@ -807,7 +1654,7 @@
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(let ((what-would-load-op-do (cdr (assoc 'load-op
- (slot-value c 'in-order-to)))))
+ (component-in-order-to c)))))
(mapcar (lambda (dep)
(if (eq (car dep) 'load-op)
(cons 'load-source-op (cdr dep))
@@ -816,362 +1663,1490 @@
(defmethod operation-done-p ((o load-source-op) (c source-file))
(if (or (not (component-property c 'last-loaded-as-source))
- (> (file-write-date (component-pathname c))
- (component-property c 'last-loaded-as-source)))
+ (> (safe-file-write-date (component-pathname c))
+ (component-property c 'last-loaded-as-source)))
nil t))
+
+;;;; -------------------------------------------------------------------------
+;;;; test-op
+
(defclass test-op (operation) ())
(defmethod perform ((operation test-op) (c component))
nil)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; invoking operations
+(defmethod operation-done-p ((operation test-op) (c system))
+ "Testing a system is _never_ done."
+ nil)
+
+(defmethod component-depends-on :around ((o test-op) (c system))
+ (cons `(load-op ,(component-name c)) (call-next-method)))
+
+
+;;;; -------------------------------------------------------------------------
+;;;; Invoking Operations
-(defun operate (operation-class system &rest args &key (verbose t) version
- &allow-other-keys)
- (let* ((op (apply #'make-instance operation-class
- :original-initargs args
- args))
- (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system))))
+(defun operate (operation-class system &rest args &key (verbose t) version force
+ &allow-other-keys)
+ (declare (ignore force))
+ (let* ((*package* *package*)
+ (*readtable* *readtable*)
+ (op (apply #'make-instance operation-class
+ :original-initargs args
+ args))
+ (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
+ (system (if (typep system 'component) system (find-system system))))
(unless (version-satisfies system version)
- (error 'missing-component :requires system :version version))
+ (error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
(with-compilation-unit ()
- (loop for (op . component) in steps do
- (loop
- (restart-case
- (progn (perform op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
- (accept ()
- :report
- (lambda (s)
- (format s
- "~@<Continue, treating ~S on ~S as ~
- having been successful.~@:>"
- op component))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return)))))))))
-
-(defun oos (&rest args)
- "Alias of OPERATE function"
- (apply #'operate args))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; syntax
-
-(defun remove-keyword (key arglist)
- (labels ((aux (key arglist)
- (cond ((null arglist) nil)
- ((eq key (car arglist)) (cddr arglist))
- (t (cons (car arglist) (cons (cadr arglist)
- (remove-keyword
- key (cddr arglist))))))))
- (aux key arglist)))
+ (loop :for (op . component) :in steps :do
+ (loop
+ (restart-case
+ (progn (perform-with-restarts op component)
+ (return))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s "~@<Retry performing ~S on ~S.~@:>"
+ op component)))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s "~@<Continue, treating ~S on ~S as ~
+ having been successful.~@:>"
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return)))))))
+ op))
+
+(defun oos (operation-class system &rest args &key force (verbose t) version
+ &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate operation-class system args))
+
+(let ((operate-docstring
+ "Operate does three things:
+
+1. It creates an instance of `operation-class` using any keyword parameters
+as initargs.
+2. It finds the asdf-system specified by `system` (possibly loading
+it from disk).
+3. It then calls `traverse` with the operation and system as arguments
+
+The traverse operation is wrapped in `with-compilation-unit` and error
+handling code. If a `version` argument is supplied, then operate also
+ensures that the system found satisfies it using the `version-satisfies`
+method.
+
+Note that dependencies may cause the operation to invoke other
+operations on the system or its components: the new operations will be
+created with the same initargs as the original one.
+"))
+ (setf (documentation 'oos 'function)
+ (format nil
+ "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+ operate-docstring))
+ (setf (documentation 'operate 'function)
+ operate-docstring))
+
+(defun load-system (system &rest args &key force (verbose t) version
+ &allow-other-keys)
+ "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
+details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'load-op system args))
+
+(defun compile-system (system &rest args &key force (verbose t) version
+ &allow-other-keys)
+ "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
+for details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'compile-op system args))
+
+(defun test-system (system &rest args &key force (verbose t) version
+ &allow-other-keys)
+ "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
+details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'test-op system args))
+
+;;;; -------------------------------------------------------------------------
+;;;; Defsystem
+
+(defun determine-system-pathname (pathname pathname-supplied-p)
+ ;; called from the defsystem macro.
+ ;; the pathname of a system is either
+ ;; 1. the one supplied,
+ ;; 2. derived from the *load-truename* (see below), or
+ ;; 3. taken from *default-pathname-defaults*
+ ;;
+ ;; if using *load-truename*, then we also deal with whether or not
+ ;; to resolve symbolic links. If not resolving symlinks, then we use
+ ;; *load-pathname* instead of *load-truename* since in some
+ ;; implementations, the latter has *already resolved it.
+ (let ((file-pathname
+ (when (or *load-pathname* *compile-file-pathname*)
+ (pathname-directory-pathname
+ (if *resolve-symlinks*
+ (resolve-symlinks (or *load-truename* *compile-file-truename*))
+ *load-pathname*)))))
+ (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
+ file-pathname
+ (current-directory))))
(defmacro defsystem (name &body options)
- (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+ (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
+ &allow-other-keys)
+ options
(let ((component-options (remove-keyword :class options)))
`(progn
- ;; system must be registered before we parse the body, otherwise
- ;; we recur when trying to find an existing system of the same name
- ;; to reuse options (e.g. pathname) from
- (let ((s (system-registered-p ',name)))
- (cond ((and s (eq (type-of (cdr s)) ',class))
- (setf (car s) (get-universal-time)))
- (s
- #+clisp
- (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
- #-clisp
- (change-class (cdr s) ',class))
- (t
- (register-system (quote ,name)
- (make-instance ',class :name ',name)))))
- (parse-component-form nil (apply
- #'list
- :module (coerce-name ',name)
- :pathname
- (or ,pathname
- (pathname-sans-name+type
- (resolve-symlinks *load-truename*))
- *default-pathname-defaults*)
- ',component-options))))))
-
+ ;; system must be registered before we parse the body, otherwise
+ ;; we recur when trying to find an existing system of the same name
+ ;; to reuse options (e.g. pathname) from
+ (let ((s (system-registered-p ',name)))
+ (cond ((and s (eq (type-of (cdr s)) ',class))
+ (setf (car s) (get-universal-time)))
+ (s
+ (change-class (cdr s) ',class))
+ (t
+ (register-system (quote ,name)
+ (make-instance ',class :name ',name))))
+ (%set-system-source-file *load-truename*
+ (cdr (system-registered-p ',name))))
+ (parse-component-form
+ nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ ,(determine-system-pathname pathname pathname-arg-p)
+ ',component-options))))))
+
(defun class-for-type (parent type)
- (let ((class
- (find-class
- (or (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) #.(package-name *package*)))
- nil)))
+ (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type)
+ (load-time-value
+ (package-name :asdf)))))
+ (class (dolist (symbol (if (keywordp type)
+ extra-symbols
+ (cons type extra-symbols)))
+ (when (and symbol
+ (find-class symbol nil)
+ (subtypep symbol 'component))
+ (return (find-class symbol))))))
(or class
- (and (eq type :file)
- (or (module-default-component-class parent)
- (find-class 'cl-source-file)))
- (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
+ (and (eq type :file)
+ (or (module-default-component-class parent)
+ (find-class 'cl-source-file)))
+ (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
(defun maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
(let ((first-op-tree (assoc op1 tree)))
(if first-op-tree
- (progn
- (aif (assoc op2 (cdr first-op-tree))
- (if (find c (cdr it))
- nil
- (setf (cdr it) (cons c (cdr it))))
- (setf (cdr first-op-tree)
- (acons op2 (list c) (cdr first-op-tree))))
- tree)
- (acons op1 (list (list op2 c)) tree))))
-
+ (progn
+ (aif (assoc op2 (cdr first-op-tree))
+ (if (find c (cdr it))
+ nil
+ (setf (cdr it) (cons c (cdr it))))
+ (setf (cdr first-op-tree)
+ (acons op2 (list c) (cdr first-op-tree))))
+ tree)
+ (acons op1 (list (list op2 c)) tree))))
+
(defun union-of-dependencies (&rest deps)
(let ((new-tree nil))
(dolist (dep deps)
(dolist (op-tree dep)
- (dolist (op (cdr op-tree))
- (dolist (c (cdr op))
- (setf new-tree
- (maybe-add-tree new-tree (car op-tree) (car op) c))))))
+ (dolist (op (cdr op-tree))
+ (dolist (c (cdr op))
+ (setf new-tree
+ (maybe-add-tree new-tree (car op-tree) (car op) c))))))
new-tree))
-(defun remove-keys (key-names args)
- (loop for ( name val ) on args by #'cddr
- unless (member (symbol-name name) key-names
- :key #'symbol-name :test 'equal)
- append (list name val)))
-
(defvar *serial-depends-on*)
-(defun parse-component-form (parent options)
- (destructuring-bind
- (type name &rest rest &key
- ;; the following list of keywords is reproduced below in the
- ;; remove-keys form. important to keep them in sync
- components pathname default-component-class
- perform explain output-files operation-done-p
- weakly-depends-on
- depends-on serial in-order-to
- ;; list ends
- &allow-other-keys) options
- (check-component-input type name weakly-depends-on depends-on components in-order-to)
-
- (when (and parent
- (find-component parent name)
- ;; ignore the same object when rereading the defsystem
- (not
- (typep (find-component parent name)
- (class-for-type parent type))))
- (error 'duplicate-names :name name))
-
- (let* ((other-args (remove-keys
- '(components pathname default-component-class
- perform explain output-files operation-done-p
- weakly-depends-on
- depends-on serial in-order-to)
- rest))
- (ret
- (or (find-component parent name)
- (make-instance (class-for-type parent type)))))
- (when weakly-depends-on
- (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
- (when (boundp '*serial-depends-on*)
- (setf depends-on
- (concatenate 'list *serial-depends-on* depends-on)))
- (apply #'reinitialize-instance
- ret
- :name (coerce-name name)
- :pathname pathname
- :parent parent
- other-args)
- (when (typep ret 'module)
- (setf (module-default-component-class ret)
- (or default-component-class
- (and (typep parent 'module)
- (module-default-component-class parent))))
- (let ((*serial-depends-on* nil))
- (setf (module-components ret)
- (loop for c-form in components
- for c = (parse-component-form ret c-form)
- collect c
- if serial
- do (push (component-name c) *serial-depends-on*))))
-
- ;; check for duplicate names
- (let ((name-hash (make-hash-table :test #'equal)))
- (loop for c in (module-components ret)
- do
- (if (gethash (component-name c)
- name-hash)
- (error 'duplicate-names
- :name (component-name c))
- (setf (gethash (component-name c)
- name-hash)
- t)))))
-
- (setf (slot-value ret 'in-order-to)
- (union-of-dependencies
- in-order-to
- `((compile-op (compile-op , at depends-on))
- (load-op (load-op , at depends-on))))
- (slot-value ret 'do-first) `((compile-op (load-op , at depends-on))))
-
- (loop for (n v) in `((perform ,perform) (explain ,explain)
- (output-files ,output-files)
- (operation-done-p ,operation-done-p))
- do (map 'nil
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf n
- ;; But this is hardly performance-critical
- (lambda (m) (remove-method (symbol-function n) m))
- (component-inline-methods ret))
- when v
- do (destructuring-bind (op qual (o c) &body body) v
- (pushnew
- (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
- , at body))
- (component-inline-methods ret))))
- ret)))
+(defun sysdef-error-component (msg type name value)
+ (sysdef-error (concatenate 'string msg
+ "~&The value specified for ~(~A~) ~A is ~W")
+ type name value))
-(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
+(defun check-component-input (type name weakly-depends-on
+ depends-on components in-order-to)
"A partial test of the values of a component."
- (when weakly-depends-on (warn "We got one! XXXXX"))
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
- type name depends-on))
+ type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
- type name weakly-depends-on))
+ type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
- type name components))
+ type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
- type name in-order-to)))
+ type name in-order-to)))
-(defun sysdef-error-component (msg type name value)
- (sysdef-error (concatenate 'string msg
- "~&The value specified for ~(~A~) ~A is ~W")
- type name value))
+(defun %remove-component-inline-methods (component)
+ (dolist (name +asdf-methods+)
+ (map ()
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
+ ;; clear methods, then add the new ones
+ (setf (component-inline-methods component) nil))
+
+(defun %define-component-inline-methods (ret rest)
+ (dolist (name +asdf-methods+)
+ (let ((keyword (intern (symbol-name name) :keyword)))
+ (loop :for data = rest :then (cddr data)
+ :for key = (first data)
+ :for value = (second data)
+ :while data
+ :when (eq key keyword) :do
+ (destructuring-bind (op qual (o c) &body body) value
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ , at body))
+ (component-inline-methods ret)))))))
+
+(defun %refresh-component-inline-methods (component rest)
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest))
-(defun resolve-symlinks (path)
- #-allegro (truename path)
- #+allegro (excl:pathname-resolve-symbolic-links path)
- )
-
-;;; optional extras
-
-;;; run-shell-command functions for other lisp implementations will be
-;;; gratefully accepted, if they do the same thing. If the docstring
-;;; is ambiguous, send a bug report
+(defun parse-component-form (parent options)
+
+ (destructuring-bind
+ (type name &rest rest &key
+ ;; the following list of keywords is reproduced below in the
+ ;; remove-keys form. important to keep them in sync
+ components pathname default-component-class
+ perform explain output-files operation-done-p
+ weakly-depends-on
+ depends-on serial in-order-to
+ ;; list ends
+ &allow-other-keys) options
+ (declare (ignorable perform explain output-files operation-done-p))
+ (check-component-input type name weakly-depends-on depends-on components in-order-to)
+
+ (when (and parent
+ (find-component parent name)
+ ;; ignore the same object when rereading the defsystem
+ (not
+ (typep (find-component parent name)
+ (class-for-type parent type))))
+ (error 'duplicate-names :name name))
+
+ (let* ((other-args (remove-keys
+ '(components pathname default-component-class
+ perform explain output-files operation-done-p
+ weakly-depends-on
+ depends-on serial in-order-to)
+ rest))
+ (ret
+ (or (find-component parent name)
+ (make-instance (class-for-type parent type)))))
+ (when weakly-depends-on
+ (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
+ (when (boundp '*serial-depends-on*)
+ (setf depends-on
+ (concatenate 'list *serial-depends-on* depends-on)))
+ (apply #'reinitialize-instance ret
+ :name (coerce-name name)
+ :pathname pathname
+ :parent parent
+ other-args)
+ (component-pathname ret) ; eagerly compute the absolute pathname
+ (when (typep ret 'module)
+ (setf (module-default-component-class ret)
+ (or default-component-class
+ (and (typep parent 'module)
+ (module-default-component-class parent))))
+ (let ((*serial-depends-on* nil))
+ (setf (module-components ret)
+ (loop :for c-form :in components
+ :for c = (parse-component-form ret c-form)
+ :collect c
+ :if serial
+ :do (push (component-name c) *serial-depends-on*))))
+
+ ;; check for duplicate names
+ (let ((name-hash (make-hash-table :test #'equal)))
+ (loop :for c in (module-components ret) :do
+ (if (gethash (component-name c)
+ name-hash)
+ (error 'duplicate-names :name (component-name c))
+ (setf (gethash (component-name c)
+ name-hash)
+ t)))))
+
+ (setf (component-in-order-to ret)
+ (union-of-dependencies
+ in-order-to
+ `((compile-op (compile-op , at depends-on))
+ (load-op (load-op , at depends-on))))
+ (component-do-first ret) `((compile-op (load-op , at depends-on))))
+
+ (%refresh-component-inline-methods ret rest)
+ ret)))
+
+;;;; ---------------------------------------------------------------------------
+;;;; run-shell-command
+;;;;
+;;;; run-shell-command functions for other lisp implementations will be
+;;;; gratefully accepted, if they do the same thing.
+;;;; If the docstring is ambiguous, send a bug report.
+;;;;
+;;;; We probably should move this functionality to its own system and deprecate
+;;;; use of it from the asdf package. However, this would break unspecified
+;;;; existing software, so until a clear alternative exists, we can't deprecate
+;;;; it, and even after it's been deprecated, we will support it for a few
+;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
(defun run-shell-command (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+ "Interpolate `args` into `control-string` as if by `format`, and
synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*. Returns the shell's exit code."
+output to `*verbose-out*`. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
- (format *verbose-out* "; $ ~A~%" command)
+ (asdf-message "; $ ~A~%" command)
#+sbcl
(sb-ext:process-exit-code
- (sb-ext:run-program
- #+win32 "sh" #-win32 "/bin/sh"
- (list "-c" command)
- #+win32 #+win32 :search t
- :input nil :output *verbose-out*))
-
+ (apply #'sb-ext:run-program
+ #+win32 "sh" #-win32 "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*
+ #+win32 '(:search t) #-win32 nil))
+
#+(or cmu scl)
(ext:process-exit-code
- (ext:run-program
+ (ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*))
#+allegro
- (excl:run-shell-command command :input nil :output *verbose-out*)
-
+ ;; will this fail if command has embedded quotes - it seems to work
+ (multiple-value-bind (stdout stderr exit-code)
+ (excl.osi:command-output
+ (format nil "~a -c \"~a\""
+ #+mswindows "sh" #-mswindows "/bin/sh" command)
+ :input nil :whole nil
+ #+mswindows :show-window #+mswindows :hide)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+ exit-code)
+
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"
+ :show-cmd nil
+ :prefix ""
:output-stream *verbose-out*)
-
- #+clisp ;XXX not exactly *verbose-out*, I know
+
+ #+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(nth-value 1
- (ccl:external-process-status
- (ccl:run-program "/bin/sh" (list "-c" command)
- :input nil :output *verbose-out*
- :wait t)))
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output *verbose-out*
+ :wait t)))
+
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
-
+
#+abcl
(ext:run-shell-command command :output *verbose-out*)
+
#-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
- (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ (error "RUN-SHELL-COMMAND not implemented for this Lisp")
))
+;;;; ---------------------------------------------------------------------------
+;;;; system-relative-pathname
-(defgeneric hyperdocumentation (package name doc-type))
-(defmethod hyperdocumentation ((package symbol) name doc-type)
- (hyperdocumentation (find-package package) name doc-type))
+(defmethod system-source-file ((system-name string))
+ (system-source-file (find-system system-name)))
+(defmethod system-source-file ((system-name symbol))
+ (system-source-file (find-system system-name)))
+
+(defun system-source-directory (system-designator)
+ "Return a pathname object corresponding to the
+directory in which the system specification (.asd file) is
+located."
+ (make-pathname :name nil
+ :type nil
+ :defaults (system-source-file system-designator)))
+
+(defun relativize-directory (directory)
+ (if (eq (car directory) :absolute)
+ (cons :relative (cdr directory))
+ directory))
+
+(defun relativize-pathname-directory (pathspec)
+ (let ((p (pathname pathspec)))
+ (make-pathname
+ :directory (relativize-directory (pathname-directory p))
+ :defaults p)))
+
+(defun system-relative-pathname (system name &key type)
+ (merge-pathnames*
+ (merge-component-name-type name :type type)
+ (system-source-directory system)))
-(defun hyperdoc (name doc-type)
- (hyperdocumentation (symbol-package name) name doc-type))
+;;; ---------------------------------------------------------------------------
+;;; implementation-identifier
+;;;
+;;; produce a string to identify current implementation.
+;;; Initially stolen from SLIME's SWANK, hacked since.
-(pushnew :asdf *features*)
+(defparameter *implementation-features*
+ '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
+ :corman :cormanlisp :armedbear :gcl :ecl :scl))
+
+(defparameter *os-features*
+ '((:windows :mswindows :win32 :mingw32)
+ (:solaris :sunos)
+ :macosx :darwin :apple
+ :freebsd :netbsd :openbsd :bsd
+ :linux :unix))
+
+(defparameter *architecture-features*
+ '((:x86-64 :amd64 :x86_64 :x8664-target)
+ (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
+ :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
+
+(defun lisp-version-string ()
+ (let ((s (lisp-implementation-version)))
+ (declare (ignorable s))
+ #+(or scl sbcl ecl armedbear cormanlisp mcl) s
+ #+cmu (substitute #\- #\/ s)
+ #+clozure (format nil "~d.~d~@[-~d~]"
+ ccl::*openmcl-major-version*
+ ccl::*openmcl-minor-version*
+ #+ppc64-target 64
+ #-ppc64-target nil)
+ #+lispworks (format nil "~A~@[~A~]" s
+ (when (member :lispworks-64bit *features*) "-64bit"))
+ #+allegro (format nil
+ "~A~A~A~A"
+ excl::*common-lisp-version-number*
+ ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+ (if (eq excl:*current-case-mode*
+ :case-sensitive-lower) "M" "A")
+ ;; Note if not using International ACL
+ ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+ (excl:ics-target-case
+ (:-ics "8")
+ (:+ics ""))
+ (if (member :64bit *features*) "-64bit" ""))
+ #+(or clisp gcl) (subseq s 0 (position #\space s))
+ #+digitool (subseq s 8)))
+
+(defun first-feature (features)
+ (labels
+ ((fp (thing)
+ (etypecase thing
+ (symbol
+ (let ((feature (find thing *features*)))
+ (when feature (return-from fp feature))))
+ ;; allows features to be lists of which the first
+ ;; member is the "main name", the rest being aliases
+ (cons
+ (dolist (subf thing)
+ (when (find subf *features*) (return-from fp (first thing))))))
+ nil))
+ (loop :for f :in features
+ :when (fp f) :return :it)))
+
+(defun implementation-type ()
+ (first-feature *implementation-features*))
+
+(defun implementation-identifier ()
+ (labels
+ ((maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (implementation-type)
+ "No implementation feature found in ~a."
+ *implementation-features*))
+ (os (maybe-warn (first-feature *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-feature *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp ~
+ implementation version.")))
+ (substitute-if
+ #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
+
+
+
+;;; ---------------------------------------------------------------------------
+;;; Generic support for configuration files
+
+(defparameter *inter-directory-separator*
+ #+(or unix cygwin) #\:
+ #-(or unix cygwin) #\;)
+
+(defun user-homedir ()
+ (truename (user-homedir-pathname)))
+
+(defun try-directory-subpath (x sub &key type)
+ (let* ((p (and x (ensure-directory-pathname x)))
+ (tp (and p (ignore-errors (truename p))))
+ (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
+ (ts (and sp (ignore-errors (truename sp)))))
+ (and ts (values sp ts))))
+(defun user-configuration-directories ()
+ (remove-if
+ #'null
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
+ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+ :for dir :in (split-string dirs :separator ":")
+ :collect (try dir "common-lisp/"))
+ #+windows
+ ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
+ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ #+(not cygwin)
+ ,(try (or (getenv "USERPROFILE") (user-homedir))
+ "Application Data/common-lisp/config/"))
+ ,(try (user-homedir) ".config/common-lisp/")))))
+(defun system-configuration-directories ()
+ (remove-if
+ #'null
+ (append
+ #+windows
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(
+ ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
+ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+ #+(not cygwin)
+ ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+ (list #p"/etc/"))))
+(defun in-first-directory (dirs x)
+ (loop :for dir :in dirs
+ :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
+(defun in-user-configuration-directory (x)
+ (in-first-directory (user-configuration-directories) x))
+(defun in-system-configuration-directory (x)
+ (in-first-directory (system-configuration-directories) x))
+
+(defun configuration-inheritance-directive-p (x)
+ (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
+ (or (member x kw)
+ (and (length=n-p x 1) (member (car x) kw)))))
+
+(defun validate-configuration-form (form tag directive-validator
+ &optional (description tag))
+ (unless (and (consp form) (eq (car form) tag))
+ (error "Error: Form doesn't specify ~A ~S~%" description form))
+ (loop :with inherit = 0
+ :for directive :in (cdr form) :do
+ (if (configuration-inheritance-directive-p directive)
+ (incf inherit)
+ (funcall directive-validator directive))
+ :finally
+ (unless (= inherit 1)
+ (error "One and only one of ~S or ~S is required"
+ :inherit-configuration :ignore-inherited-configuration)))
+ form)
+
+(defun validate-configuration-file (file validator description)
+ (let ((forms (read-file-forms file)))
+ (unless (length=n-p forms 1)
+ (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
+ (funcall validator (car forms))))
+
+(defun validate-configuration-directory (directory tag validator)
+ (let ((files (sort (ignore-errors
+ (directory (make-pathname :name :wild :type :wild :defaults directory)
+ #+sbcl :resolve-symlinks #+sbcl nil))
+ #'string< :key #'namestring)))
+ `(,tag
+ ,@(loop :for file :in files :append
+ (mapcar validator (read-file-forms file)))
+ :inherit-configuration)))
-#+sbcl
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
- (pushnew :sbcl-hooks-require *features*)))
-#+(and sbcl sbcl-hooks-require)
+;;; ---------------------------------------------------------------------------
+;;; asdf-output-translations
+;;;
+;;; this code is heavily inspired from
+;;; asdf-binary-translations, common-lisp-controller and cl-launch.
+;;; ---------------------------------------------------------------------------
+
+(defvar *output-translations* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")
+
+(defvar *user-cache*
+ (or
+ (let ((h (getenv "XDG_CACHE_HOME")))
+ (and h `(,h "common-lisp" :implementation)))
+ #+(and windows lispworks)
+ (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
+ (and h `(,h "common-lisp" "cache")))
+ #+(and windows (not cygwin))
+ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
+ (let ((h (or (getenv "USERPROFILE") (user-homedir))))
+ (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
+ '(:home ".cache" "common-lisp" :implementation)))
+(defvar *system-cache*
+ (or
+ #+(and windows lispworks)
+ (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
+ (and h `(,h "common-lisp" "cache")))
+ #+windows
+ (let ((h (or (getenv "USERPROFILE") (user-homedir))))
+ (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
+ #+(or unix cygwin)
+ '("/var/cache/common-lisp" :uid :implementation)))
+
+(defun output-translations ()
+ (car *output-translations*))
+
+(defun (setf output-translations) (new-value)
+ (setf *output-translations*
+ (list
+ (stable-sort (copy-list new-value) #'>
+ :key (lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (length (pathname-directory (car x)))))))))
+ new-value)
+
+(defun output-translations-initialized-p ()
+ (and *output-translations* t))
+
+(defun clear-output-translations ()
+ "Undoes any initialization of the output translations.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+ (setf *output-translations* '())
+ (values))
+
+(defparameter *wild-path*
+ (make-pathname :directory '(:relative :wild-inferiors)
+ :name :wild :type :wild :version :wild))
+
+(defparameter *wild-asd*
+ (make-pathname :directory '(:relative :wild-inferiors)
+ :name :wild :type "asd" :version :newest))
+
+(defun wilden (path)
+ (merge-pathnames* *wild-path* path))
+
+(defun resolve-absolute-location-component (x wildenp)
+ (let* ((r
+ (etypecase x
+ (pathname x)
+ (string (ensure-directory-pathname x))
+ (cons
+ (let ((car (resolve-absolute-location-component (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ car (cdr x) wildenp)))
+ (merge-pathnames* cdr car)))))
+ ((eql :root)
+ ;; special magic! we encode such paths as relative pathnames,
+ ;; but it means "relative to the root of the source pathname's host and device".
+ (return-from resolve-absolute-location-component
+ (make-pathname :directory '(:relative))))
+ ((eql :home) (user-homedir))
+ ((eql :user-cache) (resolve-location *user-cache* nil))
+ ((eql :system-cache) (resolve-location *system-cache* nil))
+ ((eql :current-directory) (current-directory))))
+ (s (if (and wildenp (not (pathnamep x)))
+ (wilden r)
+ r)))
+ (unless (absolute-pathname-p s)
+ (error "Not an absolute pathname ~S" s))
+ s))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string x)
+ (cons
+ (let ((car (resolve-relative-location-component super (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x) wildenp)))
+ (merge-pathnames* cdr car)))))
+ ((eql :current-directory)
+ (relativize-pathname-directory (current-directory)))
+ ((eql :implementation) (implementation-identifier))
+ ((eql :implementation-type) (string-downcase (implementation-type)))
+ ((eql :uid) (princ-to-string (get-uid)))))
+ (d (if (pathnamep x) r (ensure-directory-pathname r)))
+ (s (if (and wildenp (not (pathnamep x)))
+ (wilden d)
+ d)))
+ (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
+ (error "pathname ~S is not relative to ~S" s super))
+ (merge-pathnames* s super)))
+
+(defun resolve-location (x &optional wildenp)
+ (if (atom x)
+ (resolve-absolute-location-component x wildenp)
+ (loop :with path = (resolve-absolute-location-component (car x) nil)
+ :for (component . morep) :on (cdr x)
+ :do (setf path (resolve-relative-location-component
+ path component (and wildenp (not morep))))
+ :finally (return path))))
+
+(defun location-designator-p (x)
+ (flet ((componentp (c) (typep c '(or string pathname keyword))))
+ (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+
+(defun location-function-p (x)
+ (and
+ (consp x)
+ (length=n-p x 2)
+ (or (and (equal (first x) :function)
+ (typep (second x) 'symbol))
+ (and (equal (first x) 'lambda)
+ (cddr x)
+ (length=n-p (second x) 2)))))
+
+(defun validate-output-translations-directive (directive)
+ (unless
+ (or (member directive '(:inherit-configuration
+ :ignore-inherited-configuration
+ :enable-user-cache :disable-cache))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive))))))
+ (error "Invalid directive ~S~%" directive))
+ directive)
+
+(defun validate-output-translations-form (form)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ "output translations"))
+
+(defun validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form "output translations"))
+
+(defun validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive))
+
+(defun parse-output-translations-string (string)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error "environment string isn't: ~S" string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string)))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string)))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :for i = (or (position *inter-directory-separator* string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ (source
+ (push (list source (if (equal "" s) nil s)) directives)
+ (setf source nil))
+ ((equal "" s)
+ (when inherit
+ (error "only one inherited configuration allowed: ~S" string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (error "Uneven number of components in source to destination mapping ~S" string))
+ (unless inherit
+ (push :ignore-inherited-configuration directives))
+ (return `(:output-translations ,@(nreverse directives)))))))))
+
+(defparameter *default-output-translations*
+ '(environment-output-translations
+ user-output-translations-pathname
+ user-output-translations-directory-pathname
+ system-output-translations-pathname
+ system-output-translations-directory-pathname))
+
+(defun wrapping-output-translations ()
+ `(:output-translations
+ ;; Some implementations have precompiled ASDF systems,
+ ;; so we must disable translations for implementation paths.
+ #+sbcl (,(getenv "SBCL_HOME") ())
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
+ #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
+ ;; All-import, here is where we want user stuff to be:
+ :inherit-configuration
+ ;; If we want to enable the user cache by default, here would be the place:
+ :enable-user-cache))
+
+(defparameter *output-translations-file* #p"asdf-output-translations.conf")
+(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
+
+(defun user-output-translations-pathname ()
+ (in-user-configuration-directory *output-translations-file* ))
+(defun system-output-translations-pathname ()
+ (in-system-configuration-directory *output-translations-file*))
+(defun user-output-translations-directory-pathname ()
+ (in-user-configuration-directory *output-translations-directory*))
+(defun system-output-translations-directory-pathname ()
+ (in-system-configuration-directory *output-translations-directory*))
+(defun environment-output-translations ()
+ (getenv "ASDF_OUTPUT_TRANSLATIONS"))
+
+(defgeneric process-output-translations (spec &key inherit collect))
+(defmethod process-output-translations ((x symbol) &key
+ (inherit *default-output-translations*)
+ collect)
+ (process-output-translations (funcall x) :inherit inherit :collect collect))
+(defmethod process-output-translations ((pathname pathname) &key inherit collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-output-translations (validate-output-translations-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file pathname)
+ (process-output-translations (validate-output-translations-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-output-translations inherit :collect collect))))
+(defmethod process-output-translations ((string string) &key inherit collect)
+ (process-output-translations (parse-output-translations-string string)
+ :inherit inherit :collect collect))
+(defmethod process-output-translations ((x null) &key inherit collect)
+ (declare (ignorable x))
+ (inherit-output-translations inherit :collect collect))
+(defmethod process-output-translations ((form cons) &key inherit collect)
+ (dolist (directive (cdr (validate-output-translations-form form)))
+ (process-output-translations-directive directive :inherit inherit :collect collect)))
+
+(defun inherit-output-translations (inherit &key collect)
+ (when inherit
+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
+
+(defun process-output-translations-directive (directive &key inherit collect)
+ (if (atom directive)
+ (ecase directive
+ ((:enable-user-cache)
+ (process-output-translations-directive '(t :user-cache) :collect collect))
+ ((:disable-cache)
+ (process-output-translations-directive '(t t) :collect collect))
+ ((:inherit-configuration)
+ (inherit-output-translations inherit :collect collect))
+ ((:ignore-inherited-configuration)
+ nil))
+ (let ((src (first directive))
+ (dst (second directive)))
+ (if (eq src :include)
+ (when dst
+ (process-output-translations (pathname dst) :inherit nil :collect collect))
+ (when src
+ (let ((trusrc (or (eql src t)
+ (let ((loc (resolve-location src t)))
+ (if (absolute-pathname-p loc) (truenamize loc) loc)))))
+ (cond
+ ((location-function-p dst)
+ (funcall collect
+ (list trusrc
+ (if (symbolp (second dst))
+ (fdefinition (second dst))
+ (eval (second dst))))))
+ ((eq dst t)
+ (funcall collect (list trusrc t)))
+ (t
+ (let* ((trudst (make-pathname
+ :defaults (if dst (resolve-location dst t) trusrc)))
+ (wilddst (make-pathname
+ :name :wild :type :wild :version :wild
+ :defaults trudst)))
+ (funcall collect (list wilddst t))
+ (funcall collect (list trusrc trudst)))))))))))
+
+(defun compute-output-translations (&optional parameter)
+ "read the configuration, return it"
+ (remove-duplicates
+ (while-collecting (c)
+ (inherit-output-translations
+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+ :test 'equal :from-end t))
+
+(defun initialize-output-translations (&optional parameter)
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (setf (output-translations) (compute-output-translations parameter)))
+
+(defun disable-output-translations ()
+ "Initialize output translations in a way that maps every file to itself,
+effectively disabling the output translation facility."
+ (initialize-output-translations
+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
+
+;; checks an initial variable to see whether the state is initialized
+;; or cleared. In the former case, return current configuration; in
+;; the latter, initialize. ASDF will call this function at the start
+;; of (asdf:find-system).
+(defun ensure-output-translations ()
+ (if (output-translations-initialized-p)
+ (output-translations)
+ (initialize-output-translations)))
+
+(defun apply-output-translations (path)
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop :with p = (truenamize path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return
+ (cond
+ ((functionp destination)
+ (funcall destination p absolute-source))
+ ((eq destination t)
+ p)
+ ((not (pathnamep destination))
+ (error "invalid destination"))
+ ((not (absolute-pathname-p destination))
+ (translate-pathname p absolute-source (merge-pathnames* destination root)))
+ (root
+ (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
+ (t
+ (translate-pathname p absolute-source destination)))
+ :finally (return p)))))
+
+(defun last-char (s)
+ (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
+(defun directorize-pathname-host-device (pathname)
+ (let* ((root (pathname-root pathname))
+ (wild-root (wilden root))
+ (absolute-pathname (merge-pathnames* pathname root))
+ (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
+ (separator (last-char (namestring foo)))
+ (root-namestring (namestring root))
+ (root-string
+ (substitute-if #\/
+ (lambda (x) (or (eql x #\:)
+ (eql x separator)))
+ root-namestring)))
+ (multiple-value-bind (relative path filename)
+ (component-name-to-pathname-components root-string t)
+ (declare (ignore relative filename))
+ (let ((new-base
+ (make-pathname :defaults root
+ :directory `(:absolute , at path))))
+ (translate-pathname absolute-pathname wild-root (wilden new-base))))))
+
+(defmethod output-files :around (operation component)
+ "Translate output files, unless asked not to"
+ (declare (ignorable operation component))
+ (values
+ (multiple-value-bind (files fixedp) (call-next-method)
+ (if fixedp
+ files
+ (mapcar #'apply-output-translations files)))
+ t))
+
+(defun compile-file-pathname* (input-file &rest keys)
+ (apply-output-translations
+ (apply #'compile-file-pathname
+ (truenamize (lispize-pathname input-file))
+ keys)))
+
+#+abcl
+(defun translate-jar-pathname (source wildcard)
+ (declare (ignore wildcard))
+ (let ((root (apply-output-translations
+ (concatenate 'string
+ "/:jar:file/"
+ (namestring (first (pathname-device
+ source))))))
+ (entry (make-pathname :directory (pathname-directory source)
+ :name (pathname-name source)
+ :type (pathname-type source))))
+ (concatenate 'string (namestring root) (namestring entry))))
+
+;;;; -----------------------------------------------------------------
+;;;; Compatibility mode for ASDF-Binary-Locations
+
+(defun enable-asdf-binary-locations-compatibility
+ (&key
+ (centralize-lisp-binaries nil)
+ (default-toplevel-directory
+ ;; Use ".cache/common-lisp" instead ???
+ (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
+ (user-homedir)))
+ (include-per-user-information nil)
+ (map-all-source-files nil)
+ (source-to-target-mappings nil))
+ (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
+ (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
+ (mapped-files (make-pathname
+ :name :wild :version :wild
+ :type (if map-all-source-files :wild fasl-type)))
+ (destination-directory
+ (if centralize-lisp-binaries
+ `(,default-toplevel-directory
+ ,@(when include-per-user-information
+ (cdr (pathname-directory (user-homedir))))
+ :implementation ,wild-inferiors)
+ `(:root ,wild-inferiors :implementation))))
+ (initialize-output-translations
+ `(:output-translations
+ , at source-to-target-mappings
+ ((:root ,wild-inferiors ,mapped-files)
+ (, at destination-directory ,mapped-files))
+ (t t)
+ :ignore-inherited-configuration))))
+
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support. Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun read-null-terminated-string (s)
+ (with-output-to-string (out)
+ (loop :for code = (read-byte s)
+ :until (zerop code)
+ :do (write-char (code-char code) out))))
+
+(defun read-little-endian (s &optional (bytes 4))
+ (loop
+ :for i :from 0 :below bytes
+ :sum (ash (read-byte s) (* 8 i))))
+
+(defun parse-file-location-info (s)
+ (let ((start (file-position s))
+ (total-length (read-little-endian s))
+ (end-of-header (read-little-endian s))
+ (fli-flags (read-little-endian s))
+ (local-volume-offset (read-little-endian s))
+ (local-offset (read-little-endian s))
+ (network-volume-offset (read-little-endian s))
+ (remaining-offset (read-little-endian s)))
+ (declare (ignore total-length end-of-header local-volume-offset))
+ (unless (zerop fli-flags)
+ (cond
+ ((logbitp 0 fli-flags)
+ (file-position s (+ start local-offset)))
+ ((logbitp 1 fli-flags)
+ (file-position s (+ start
+ network-volume-offset
+ #x14))))
+ (concatenate 'string
+ (read-null-terminated-string s)
+ (progn
+ (file-position s (+ start remaining-offset))
+ (read-null-terminated-string s))))))
+
+(defun parse-windows-shortcut (pathname)
+ (with-open-file (s pathname :element-type '(unsigned-byte 8))
+ (handler-case
+ (when (and (= (read-little-endian s) *link-initial-dword*)
+ (let ((header (make-array (length *link-guid*))))
+ (read-sequence header s)
+ (equalp header *link-guid*)))
+ (let ((flags (read-little-endian s)))
+ (file-position s 76) ;skip rest of header
+ (when (logbitp 0 flags)
+ ;; skip shell item id list
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (cond
+ ((logbitp 1 flags)
+ (parse-file-location-info s))
+ (t
+ (when (logbitp 2 flags)
+ ;; skip description string
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (when (logbitp 3 flags)
+ ;; finally, our pathname
+ (let* ((length (read-little-endian s 2))
+ (buffer (make-array length)))
+ (read-sequence buffer s)
+ (map 'string #'code-char buffer)))))))
+ (end-of-file ()
+ nil))))
+
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
+
+;; Using ack 1.2 exclusions
+(defvar *default-exclusions*
+ '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"))
+
+(defvar *source-registry* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a list of directory pathnames where to look for .asd files")
+
+(defun source-registry ()
+ (car *source-registry*))
+
+(defun (setf source-registry) (new-value)
+ (setf *source-registry* (list new-value))
+ new-value)
+
+(defun source-registry-initialized-p ()
+ (and *source-registry* t))
+
+(defun clear-source-registry ()
+ "Undoes any initialization of the source registry.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+ (setf *source-registry* '())
+ (values))
+
+(defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (let ((name (coerce-name system)))
+ (block nil
+ (dolist (dir (source-registry))
+ (let ((defaults (eval dir)))
+ (when defaults
+ (cond ((directory-pathname-p defaults)
+ (let ((file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local)))
+ #+(and (or win32 windows) (not :clisp))
+ (shortcut (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd.lnk" :case :local)))
+ (when (and file (probe-file file))
+ (return file))
+ #+(and (or win32 windows) (not :clisp))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target))))))))))))))
+
+(defun validate-source-registry-directive (directive)
+ (unless
+ (or (member directive '(:default-registry (:default-registry)) :test 'equal)
+ (destructuring-bind (kw &rest rest) directive
+ (case kw
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (typep (car rest) '(or pathname string null))))
+ ((:exclude)
+ (every #'stringp rest))
+ (null rest))))
+ (error "Invalid directive ~S~%" directive))
+ directive)
+
+(defun validate-source-registry-form (form)
+ (validate-configuration-form
+ form :source-registry 'validate-source-registry-directive "a source registry"))
+
+(defun validate-source-registry-file (file)
+ (validate-configuration-file
+ file 'validate-source-registry-form "a source registry"))
+
+(defun validate-source-registry-directory (directory)
+ (validate-configuration-directory
+ directory :source-registry 'validate-source-registry-directive))
+
+(defun parse-source-registry-string (string)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error "environment string isn't: ~S" string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string)))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :for pos = (position *inter-directory-separator* string :start start) :do
+ (let ((s (subseq string start (or pos end))))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error "only one inherited configuration allowed: ~S" string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((ends-with s "//")
+ (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
+ (t
+ (push `(:directory ,s) directives)))
+ (cond
+ (pos
+ (setf start (1+ pos)))
+ (t
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives))))))))))
+
+(defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (funcall collect directory)
+ (let* ((files (ignore-errors
+ (directory (merge-pathnames* *wild-asd* directory)
+ #+sbcl #+sbcl :resolve-symlinks nil
+ #+clisp #+clisp :circle t)))
+ (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
+ :test #'equal :from-end t)))
+ (loop
+ :for dir :in dirs
+ :unless (loop :for x :in exclude
+ :thereis (find x (pathname-directory dir) :test #'equal))
+ :do (funcall collect dir)))))
+
+(defparameter *default-source-registries*
+ '(environment-source-registry
+ user-source-registry
+ user-source-registry-directory
+ system-source-registry
+ system-source-registry-directory
+ default-source-registry))
+
+(defparameter *source-registry-file* #p"source-registry.conf")
+(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+
+(defun wrapping-source-registry ()
+ `(:source-registry
+ #+sbcl (:tree ,(getenv "SBCL_HOME"))
+ :inherit-configuration))
+(defun default-source-registry ()
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(:source-registry
+ #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
+ (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
+ ,@(let*
+ #+(or unix cygwin)
+ ((datahome
+ (or (getenv "XDG_DATA_HOME")
+ (try (user-homedir) ".local/share/")))
+ (datadirs
+ (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
+ (dirs (cons datahome (split-string datadirs :separator ":"))))
+ #+(and windows (not cygwin))
+ ((datahome
+ #+lispworks (sys:get-folder-path :common-appdata)
+ #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
+ "Application Data"))
+ (datadir
+ #+lispworks (sys:get-folder-path :local-appdata)
+ #-lispworks (try (getenv "ALLUSERSPROFILE")
+ "Application Data"))
+ (dirs (list datahome datadir)))
+ #+(and (not unix) (not windows) (not cygwin))
+ ((dirs ()))
+ (loop :for dir :in dirs
+ :collect `(:directory ,(try dir "common-lisp/systems/"))
+ :collect `(:tree ,(try dir "common-lisp/source/"))))
+ :inherit-configuration)))
+(defun user-source-registry ()
+ (in-user-configuration-directory *source-registry-file*))
+(defun system-source-registry ()
+ (in-system-configuration-directory *source-registry-file*))
+(defun user-source-registry-directory ()
+ (in-user-configuration-directory *source-registry-directory*))
+(defun system-source-registry-directory ()
+ (in-system-configuration-directory *source-registry-directory*))
+(defun environment-source-registry ()
+ (getenv "CL_SOURCE_REGISTRY"))
+
+(defgeneric process-source-registry (spec &key inherit register))
+(defmethod process-source-registry ((x symbol) &key inherit register)
+ (process-source-registry (funcall x) :inherit inherit :register register))
+(defmethod process-source-registry ((pathname pathname) &key inherit register)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register))
+ ((probe-file pathname)
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register))
+ (t
+ (inherit-source-registry inherit :register register))))
+(defmethod process-source-registry ((string string) &key inherit register)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :register register))
+(defmethod process-source-registry ((x null) &key inherit register)
+ (declare (ignorable x))
+ (inherit-source-registry inherit :register register))
+(defmethod process-source-registry ((form cons) &key inherit register)
+ (let ((*default-exclusions* *default-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :register register))))
+
+(defun inherit-source-registry (inherit &key register)
+ (when inherit
+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+
+(defun process-source-registry-directive (directive &key inherit register)
+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (pathname pathname) :inherit nil :register register)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (ensure-directory-pathname pathname)))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
+ ((:exclude)
+ (setf *default-exclusions* rest))
+ ((:default-registry)
+ (inherit-source-registry '(default-source-registry) :register register))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :register register))
+ ((:ignore-inherited-configuration)
+ nil))))
+
+(defun flatten-source-registry (&optional parameter)
+ (remove-duplicates
+ (while-collecting (collect)
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register (lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude)))))
+ :test 'equal :from-end t))
+
+;; Will read the configuration and initialize all internal variables,
+;; and return the new configuration.
+(defun compute-source-registry (&optional parameter)
+ (while-collecting (collect)
+ (dolist (entry (flatten-source-registry parameter))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (register-asd-directory
+ directory
+ :recurse recurse :exclude exclude :collect #'collect)))))
+
+(defun initialize-source-registry (&optional parameter)
+ (setf (source-registry) (compute-source-registry parameter)))
+
+;; checks an initial variable to see whether the state is initialized
+;; or cleared. In the former case, return current configuration; in
+;; the latter, initialize. ASDF will call this function at the start
+;; of (asdf:find-system).
+(defun ensure-source-registry ()
+ (if (source-registry-initialized-p)
+ (source-registry)
+ (initialize-source-registry)))
+
+;;;; -----------------------------------------------------------------
+;;;; SBCL and ClozureCL hook into REQUIRE
+;;;;
+#+(or sbcl clozure abcl)
(progn
(defun module-provide-asdf (name)
- (handler-bind ((style-warning #'muffle-warning))
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (missing-component (constantly nil))
+ (error (lambda (e)
+ (format *error-output* "ASDF could not load ~A because ~A.~%"
+ name e))))
(let* ((*verbose-out* (make-broadcast-stream))
- (system (asdf:find-system name nil)))
- (when system
- (asdf:operate 'asdf:load-op name)
- t))))
-
- (defun contrib-sysdef-search (system)
- (let* ((name (coerce-name system))
- (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
- (contrib (merge-pathnames
- (make-pathname :directory `(:relative ,name)
- :name name
- :type "asd"
- :case :local
- :version :newest)
- home)))
- (probe-file contrib)))
-
- (pushnew
- '(merge-pathnames "site-systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
- *central-registry*)
-
- (pushnew
- '(merge-pathnames ".sbcl/systems/"
- (user-homedir-pathname))
- *central-registry*)
-
- (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
- (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
+ (system (asdf:find-system name nil)))
+ (when system
+ (asdf:operate 'asdf:load-op name)
+ t))))
+ (pushnew 'module-provide-asdf
+ #+sbcl sb-ext:*module-provider-functions*
+ #+clozure ccl::*module-provider-functions*
+ #+abcl sys::*module-provider-functions*))
+
+;;;; -------------------------------------------------------------------------
+;;;; Cleanups after hot-upgrade.
+;;;; Things to do in case we're upgrading from a previous version of ASDF.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;;
+;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+ecl ;; Support upgrade from before ECL went to 1.369
+ (when (fboundp 'compile-op-system-p)
+ (defmethod compile-op-system-p ((op compile-op))
+ (getf :system-p (compile-op-flags op)))
+ (defmethod initialize-instance :after ((op compile-op)
+ &rest initargs
+ &key system-p &allow-other-keys)
+ (declare (ignorable initargs))
+ (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
+
+;;;; -----------------------------------------------------------------
+;;;; Done!
+(when *load-verbose*
+ (asdf-message ";; ASDF, version ~a" (asdf-version)))
+
+#+allegro
+(eval-when (:compile-toplevel :execute)
+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
+ (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
+
+(pushnew :asdf *features*)
+;; this is a release candidate for ASDF 2.0
+(pushnew :asdf2 *features*)
+
+(provide :asdf)
-(require 'asdf-abcl)
-(provide 'asdf)
+;;; Local Variables:
+;;; mode: lisp
+;;; End:
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Apr 15 16:23:44 2010
@@ -129,7 +129,6 @@
"and.lisp"
"apropos.lisp"
"arrays.lisp"
- "asdf-abcl.lisp"
"assert.lisp"
"assoc.lisp"
"autoloads.lisp"
Modified: trunk/abcl/test/lisp/abcl/file-system-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/file-system-tests.lisp (original)
+++ trunk/abcl/test/lisp/abcl/file-system-tests.lisp Thu Apr 15 16:23:44 2010
@@ -26,12 +26,18 @@
(defparameter *this-file*
(merge-pathnames (make-pathname :type "lisp")
- *load-truename*))
+ (if (find :asdf2 *features*)
+ (merge-pathnames
+ (make-pathname :name (pathname-name *load-truename*))
+ (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/"))
+ *load-truename*)))
(defparameter *this-directory*
- (make-pathname :host (pathname-host *load-truename*)
- :device (pathname-device *load-truename*)
- :directory (pathname-directory *load-truename*)))
+ (if (find :asdf2 *features*)
+ (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/")
+ (make-pathname :host (pathname-host *load-truename*)
+ :device (pathname-device *load-truename*)
+ :directory (pathname-directory *load-truename*))))
(defun pathnames-equal-p (pathname1 pathname2)
#-(or allegro clisp cmu lispworks)
Modified: trunk/abcl/test/lisp/abcl/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/package.lisp (original)
+++ trunk/abcl/test/lisp/abcl/package.lisp Thu Apr 15 16:23:44 2010
@@ -7,9 +7,11 @@
(in-package #:abcl.test.lisp)
(defparameter *abcl-test-directory*
- (make-pathname :host (pathname-host *load-truename*)
- :device (pathname-device *load-truename*)
- :directory (pathname-directory *load-truename*)))
+ (if (find :asdf2 *features*)
+ (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/")
+ (make-pathname :host (pathname-host *load-truename*)
+ :device (pathname-device *load-truename*)
+ :directory (pathname-directory *load-truename*))))
(defun run ()
"Run the Lisp test suite for ABCL."
Modified: trunk/abcl/test/lisp/abcl/test-utilities.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/test-utilities.lisp (original)
+++ trunk/abcl/test/lisp/abcl/test-utilities.lisp Thu Apr 15 16:23:44 2010
@@ -24,16 +24,6 @@
#+(and lispworks win32)
(pushnew :windows *features*)
-#+nil ;; Taken care of by ASDF
-(unless (member "ABCL-RT" *modules* :test #'string=)
- (load (merge-pathnames "rt-package.lisp" *load-truename*))
- (load #+abcl (compile-file-if-needed (merge-pathnames "rt.lisp" *load-truename*))
- ;; Force compilation to avoid fasl name conflict between SBCL and
- ;; Allegro.
- #-abcl (compile-file (merge-pathnames "rt.lisp" *load-truename*)))
- (provide "ABCL-RT"))
-
-
(in-package #:abcl-regression-test)
(defmacro signals-error (form error-name)
@@ -43,8 +33,6 @@
(:no-error (&rest ignored) (declare (ignore ignored)) nil))))
(export '(signals-error))
-
-
#+nil (rem-all-tests)
#+nil (setf *expected-failures* nil)
Modified: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/package.lisp (original)
+++ trunk/abcl/test/lisp/ansi/package.lisp Thu Apr 15 16:23:44 2010
@@ -9,9 +9,12 @@
"<svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests>")
(defparameter *ansi-tests-directory*
- (merge-pathnames
- #p"../ansi-tests/"
- (asdf:component-pathname (asdf:find-system :abcl))))
+ (if (find :asdf2 *features*)
+ (asdf:system-relative-pathname
+ :ansi-compiled "../ansi-tests/")
+ (merge-pathnames
+ #p"../ansi-tests/"
+ (asdf:component-pathname (asdf:find-system :ansi-compiled)))))
(defun run (&key (compile-tests nil))
"Run the ANSI-TESTS suite, to be found in *ANSI-TESTS-DIRECTORY*.
Modified: trunk/abcl/test/lisp/cl-bench/wrapper.lisp
==============================================================================
--- trunk/abcl/test/lisp/cl-bench/wrapper.lisp (original)
+++ trunk/abcl/test/lisp/cl-bench/wrapper.lisp Thu Apr 15 16:23:44 2010
@@ -9,9 +9,12 @@
"<http://www.chez.com/emarsden/downloads/cl-bench.tar.gz>")
(defparameter *cl-bench-directory*
- (merge-pathnames #p"../cl-bench/"
- (component-pathname (find-system :abcl))))
-
+ (if (find :asdf2 *features*)
+ (asdf:system-relative-pathname
+ :cl-bench "../cl-bench/")
+ (merge-pathnames #p"../cl-bench/"
+ (component-pathname (find-system :abcl)))))
+
;;; cl-bench defines BENCH-GC and WITH-SPAWNED-THREAD in
;;; '*cl-bench-directory*/sysdep/setup-ablisp.lisp'.
(defun cl-bench::bench-gc () (ext:gc))
More information about the armedbear-cvs
mailing list