[armedbear-cvs] r12986 - in trunk/abcl: doc/asdf src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Sun Oct 31 08:40:31 UTC 2010
Author: mevenson
Date: Sun Oct 31 04:40:27 2010
New Revision: 12986
Log:
Upgrade to ASDF-2.010.1.
Modified:
trunk/abcl/doc/asdf/asdf.texinfo
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo (original)
+++ trunk/abcl/doc/asdf/asdf.texinfo Sun Oct 31 04:40:27 2010
@@ -65,7 +65,7 @@
@titlepage
- at title asdf: another system definition facility
+ at title ASDF: Another System Definition Facility
@c The following two commands start the copyright page.
@page
@@ -206,7 +206,10 @@
Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
and you can load it that way.
-
+If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
+if you are using the latest version of your Lisp vendor's software,
+you may also send a bug report to your Lisp vendor and complain about
+their failing to provide ASDF.
@section Checking whether ASDF is loaded
@@ -239,7 +242,7 @@
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 2.000,
+If you are running a version older than 2.008,
we recommend that you load a newer ASDF using the method below.
@@ -551,7 +554,8 @@
(asdf:load-system :@var{foo})
@end example
-On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
+On some implementations (namely recent versions of
+ABCL, Clozure CL, CLISP, CMUCL, ECL, SBCL and SCL),
ASDF hooks into the @code{CL:REQUIRE} facility
and you can just use:
@@ -565,6 +569,19 @@
we recommend that you upgrade to ASDF 2.
@xref{Loading ASDF,,Loading an otherwise installed ASDF}.
+Note the name of a system is specified as a string or a symbol,
+typically a keyword.
+If a symbol (including a keyword), its name is taken and lowercased.
+The name must be a suitable value for the @code{:name} initarg
+to @code{make-pathname} in whatever filesystem the system is to be found.
+The lower-casing-symbols behaviour 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},
+which is reported not to work on some implementations
+
@section Other Operations
@@ -719,16 +736,24 @@
@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
+ :components ((:module "mod"
+ :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 @code{:module} component named @code{"mod"} is a collection of three files,
+which will be located in a subdirectory of the main code directory named
+ at file{mod} (this location can be overridden; see the discussion of the
+ at code{:pathname} option in @ref{The defsystem grammar}).
-The method-form tokens need explaining: essentially, this part:
+The method-form tokens provide a shorthand for defining methods on
+particular components. This part
@lisp
:perform (compile-op :after (op c)
@@ -746,31 +771,58 @@
(explain-something c))
@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.
+where @code{...} is the component in question.
+In this case @code{...} would expand to something like
+
+ at lisp
+(find-component (find-system "foo") "mod")
+ at end lisp
+
+For more details on the syntax of such forms, see @ref{The defsystem
+grammar}.
+For more details on what these methods do, @pxref{Operations} in
+ at ref{The object model of ASDF}.
+
+ at c The following plunge into the weeds is not appropriate in this
+ at c location. [2010/10/03:rpg]
+ at c note that although this also supports @code{:before} methods,
+ at c they may not do what you want them to ---
+ at c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
+ at c will run after all the dependencies and sub-components have been processed,
+ at c but before the component in question has been compiled.
@node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
@comment node-name, next, previous, up
@section The defsystem grammar
+ at c FIXME: @var typesetting not consistently used here. We should either expand
+ at c its use to everywhere, or we should kill it everywhere.
+
+
@example
-system-definition := ( defsystem system-designator @var{option}* )
+system-definition := ( defsystem system-designator @var{system-option}* )
-option := :components component-list
+system-option := :defsystem-depends-on system-list
+ | module-option
+ | option
+
+module-option := :components component-list
+ | :serial [ t | nil ]
+ | :if-component-dep-fails component-dep-fail-option
+
+option :=
| :pathname pathname-specifier
- | :default-component-class
+ | :default-component-class class-name
| :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}+ )
+
+system-list := ( @var{simple-component-name}* )
+
component-list := ( @var{component-def}* )
component-def := ( component-type simple-component-name @var{option}* )
@@ -796,8 +848,12 @@
method-form := (operation-name qual lambda-list @&rest body)
qual := method qualifier
+
+component-dep-fail-option := :fail | :try-next | :ignore
@end example
+
+
@subsection Component names
Component names (@code{simple-component-name})
@@ -811,6 +867,14 @@
the current package @code{my-system-asd} can be specified as
@code{:my-component-type}, or @code{my-component-type}.
+ at subsection Defsystem depends on
+
+The @code{:defsystem-depends-on} option to @code{defsystem} allows the
+programmer to specify another ASDF-defined system or set of systems that
+must be loaded @emph{before} the system definition is processed.
+Typically this is used to load an ASDF extension that is used in the
+system definition.
+
@subsection Pathname specifiers
@cindex pathname specifiers
@@ -880,7 +944,7 @@
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,
+Note that when specifying pathname objects,
ASDF does not do any special interpretation of the pathname
influenced by the component type, unlike the procedure for
pathname-specifying strings.
@@ -892,7 +956,7 @@
@subsection Warning about logical pathnames
- at cindex logical pathnames
+ at cindex logical pathnames
We recommend that you not use logical pathnames
in your asdf system definitions at this point,
@@ -916,7 +980,7 @@
The advantage of this is that you can define yourself what translations you want to use
with the logical pathname facility.
The disadvantage is that if you do not define such translations, any
-system that uses logical pathnames will be have differently under
+system that uses logical pathnames will behave differently under
asdf-output-translations than other systems you use.
If you wish to use logical pathnames you will have to configure the
@@ -929,7 +993,7 @@
@cindex serial dependencies
If the @code{:serial t} option is specified for a module,
-ASDF will add dependencies for each each child component,
+ASDF will add dependencies for each child component,
on all the children textually preceding it.
This is done as if by @code{:depends-on}.
@@ -993,6 +1057,13 @@
from within an editor without clobbering its source location)
@end itemize
+ at subsection if-component-dep-fails option
+
+This option is only appropriate for module components (including
+systems), not individual source files.
+
+For more information about this option, @pxref{Pre-defined subclasses of component}.
+
@node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem
@section Other code in .asd files
@@ -1451,15 +1522,6 @@
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
@subsubsection properties
@@ -1671,11 +1733,14 @@
(at the time that the configuration is initialized) as well as
@code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
@code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}.
+For instance, SBCL will include directories for its contribs
+when it can find them; it will look for them where SBCL was installed,
+or at the location specified by the @code{SBCL_HOME} environment variable.
@end enumerate
-Each of these configuration is specified as a SEXP
-in a trival domain-specific language (defined below).
+Each of these configurations is specified as an s-expression
+in a trivial domain-specific language (defined below).
Additionally, a more shell-friendly syntax is available
for the environment variable (defined yet below).
@@ -1704,14 +1769,14 @@
instead of the XDG base directory specification,
we try to use folder configuration from the registry regarding
@code{Common AppData} and similar directories.
-However, support querying the Windows registry is limited as of ASDF 2,
+However, support for 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.
@section Backward Compatibility
-For backward compatibility as well as for a practical backdoor for hackers,
+For backward compatibility as well as to provide a practical backdoor for hackers,
ASDF will first search for @code{.asd} files in the directories specified in
@code{asdf:*central-registry*}
before it searches in the source registry above.
@@ -1725,10 +1790,10 @@
@section Configuration DSL
-Here is the grammar of the SEXP DSL for source-registry configuration:
+Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
@example
-;; A configuration is single SEXP starting with keyword :source-registry
+;; A configuration is a single SEXP starting with keyword :source-registry
;; followed by a list of directives.
CONFIGURATION := (:source-registry DIRECTIVE ...)
@@ -1750,6 +1815,8 @@
(:exclude PATTERN ...) |
;; augment the defaults for exclusion patterns
(:also-exclude PATTERN ...) |
+ ;; Note that the scope of a an exclude pattern specification is
+ ;; the rest of the current configuration expression or file.
;; splice the parsed contents of another config file
(:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
@@ -1757,6 +1824,29 @@
;; This directive specifies that some default must be spliced.
:default-registry
+REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file
+DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name
+
+PATHNAME-DESIGNATOR :=
+ NULL | ;; Special: skip this entry.
+ ABSOLUTE-COMPONENT-DESIGNATOR |
+ (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
+
+ABSOLUTE-COMPONENT-DESIGNATOR :=
+ STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
+ PATHNAME | ;; pathname (better be an absolute path, 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
+
+RELATIVE-COMPONENT-DESIGNATOR :=
+ STRING | ;; namestring (directory assumed where applicable)
+ PATHNAME | ;; pathname
+ :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
+ :UID | ;; current UID -- not available on Windows
+ :USER ;; current USER name -- NOT IMPLEMENTED(!)
+
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"}
@@ -1767,11 +1857,10 @@
once contained:
@example
(:source-registry
- (:tree "/home/fare/cl/")
+ (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
:inherit-configuration)
@end example
-
@section Configuration Directories
Configuration directories consist in files each contains
@@ -1834,6 +1923,7 @@
@section Search Algorithm
+ at vindex *default-source-registry-exclusions*
In case that isn't clear, the semantics of the configuration is that
when searching for a system of a given name,
@@ -1896,8 +1986,10 @@
@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,
+ You might want to call this function
+ (or better, @code{clear-configuration})
+ 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
@@ -1909,6 +2001,15 @@
If not, initialize it with the given @var{PARAMETER}.
@end defun
+Every time you use ASDF's @code{find-system}, or
+anything that uses it (such as @code{operate}, @code{load-system}, etc.),
+ at code{ensure-source-registry} is called with parameter NIL,
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-source-registry} again,
+or maybe simply to @code{clear-source-registry} (or @code{clear-configuration})
+which will cause the initialization to happen next time around.
+
@section Future
@@ -2189,15 +2290,13 @@
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
+ :SYSTEM-CACHE ;; designates the default location for the system cache
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(!)
@@ -2380,8 +2479,10 @@
@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,
+ You might want to call this function
+ (or better, @code{clear-configuration})
+ 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
@@ -2399,6 +2500,15 @@
(calls @code{ensure-output-translations} for the translations).
@end defun
+Every time you use ASDF's @code{output-files}, or
+anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.),
+ at code{ensure-output-translations} is called with parameter NIL,
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-output-translations} again,
+or maybe @code{clear-output-translations} (or @code{clear-configuration}),
+which will cause the initialization to happen next time around.
+
@section Credits for output translations
@@ -2494,13 +2604,45 @@
@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.
+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.
@end defun
+ at defun clear-system system-designator
+
+It is sometimes useful to force recompilation of a previously loaded system.
+In these cases, it may be useful to @code{(asdf:clear-system :foo)}
+to remove the system from the table of currently loaded systems;
+the next time the system @code{foo} or one that depends on it is re-loaded,
+ at code{foo} will then be loaded again.
+Alternatively, you could touch @code{foo.asd} or
+remove the corresponding fasls from the output file cache.
+(It was once conceived that one should provide
+a list of systems the recompilation of which to force
+as the @code{:force} keyword argument to @code{load-system};
+but this has never worked, and though the feature was fixed in ASDF 2.000,
+it remains @code{cerror}'ed out as nobody ever used it.)
+
+Note that this does not and cannot by itself undo the previous loading
+of the system. Common Lisp has no provision for such an operation,
+and its reliance on irreversible side-effects to global datastructures
+makes such a thing impossible in the general case.
+If the software being re-loaded is not conceived with hot upgrade in mind,
+this re-loading may cause many errors, warnings or subtle silent problems,
+as packages, generic function signatures, structures, types, macros, constants, etc.
+are being redefined incompatibly.
+It is up to the user to make sure that reloading is possible and has the desired effect.
+In some cases, extreme measures such as recursively deleting packages,
+unregistering symbols, defining methods on @code{update-instance-for-redefined-class}
+and much more are necessary for reloading to happen smoothly.
+ASDF itself goes through notable pains to make such a hot upgrade possible
+with respect to its own code, and what it does is ridiculously complex;
+look at the beginning of @file{asdf.lisp} to see what it does.
+ at end defun
@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
@comment node-name, next, previous, up
@@ -2534,7 +2676,7 @@
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,
+If you're unsure about whether something is a bug, or for general discussion,
use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
@@ -2756,7 +2898,7 @@
towards the latest version for everyone.
- at subsection Pitfalls of ASDF 2
+ at subsection Pitfalls of the transition to ASDF 2
The main pitfalls in upgrading to ASDF 2 seem to be related
to the output translation mechanism.
@@ -2783,6 +2925,12 @@
@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
But thou shall not load ABL on top of ASDF 2.
+ at end itemize
+
+Other issues include the following:
+
+ at itemize
+
@item
ASDF pathname designators are now specified in places where they were unspecified,
and a few small adjustments have to be made to some non-portable defsystems.
@@ -2793,12 +2941,6 @@
moreover when evaluation is desired @code{#.} must be used,
where it wasn't necessary in the toplevel @code{:pathname} argument.
- at end itemize
-
-Other issues include the following:
-
- at itemize
-
@item
There is a slight performance bug, notably on SBCL,
when initially searching for @file{asd} files,
@@ -2817,8 +2959,24 @@
@item
On Windows, only LispWorks supports proper default configuration pathnames
based on the Windows registry.
-Other implementations make do.
-Windows support is largely untested, so please help report and fix bugs.
+Other implementations make do with environment variables.
+Windows support is somewhat less tested than Unix support.
+Please help report and fix bugs.
+
+ at item
+The mechanism by which one customizes a system so that Lisp files
+may use a different extension from the default @file{.lisp} has changed.
+Previously, the pathname for a component was lazily computed when operating on a system,
+and you would
+ at code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
+ (declare (ignorable component system)) "cl")}.
+Now, the pathname for a component is eagerly computed when defining the system,
+and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))}
+and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
+as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
+
+ at findex source-file-type
+
@end itemize
@@ -2839,7 +2997,7 @@
@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.
+it should always be a good time to upgrade to a recent 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.
@@ -2850,7 +3008,7 @@
@itemize
@item
-If ASDF isn't installed yet, then @code{(require :asdf)}
+If ASDF isn't loaded yet, then @code{(require :asdf)}
should load the version of ASDF that is bundled with your system.
You may have it load some other version configured by the user,
if you allow such configuration.
@@ -2858,7 +3016,7 @@
@item
If your system provides a mechanism to hook into @code{CL:REQUIRE},
then it would be nice to add ASDF to this hook the same way that
-ABCL, CCL, CMUCL, ECL and SBCL do it.
+ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it.
@item
You may, like SBCL, have ASDF be implicitly used to require systems
@@ -2876,8 +3034,9 @@
and precompile it in your binary distribution,
but @file{asdf.asd} if included at all,
should be secluded from the magic systems,
-in a separate file hierarchy,
-or you may otherwise rename the system and its file to e.g.
+in a separate file hierarchy;
+alternatively, you may provide the system
+after renaming it and its @file{.asd} file to e.g.
@code{asdf-ecl} and @file{asdf-ecl.asd}, or
@code{sb-asdf} and @file{sb-asdf.asd}.
Indeed, if you made @file{asdf.asd} a magic system,
@@ -3086,6 +3245,39 @@
or as a name component plus optional dot-separated type component
(if the component class doesn't specifies a pathname type).
+ at subsection How do I create a system definition where all the source files have a .cl extension?
+
+First, create a new @code{cl-source-file} subclass that provides an
+initform for the @code{type} slot:
+
+ at lisp
+(defclass my-cl-source-file (cl-source-file)
+ ((type :initform "cl")))
+ at end lisp
+
+To support both ASDF 1 and ASDF 2,
+you may omit the above @code{type} slot definition and instead define:
+
+ at lisp
+(defmethod source-file-type ((f my-cl-source-file) (m module))
+ (declare (ignorable f m))
+ "cl")
+ at end lisp
+
+Then make your system use this subclass in preference to the standard
+one:
+
+ at lisp
+(defsystem my-cl-system
+ :default-component-class my-cl-source-file
+ ....
+)
+ at end lisp
+
+We assume that these definitions are loaded into a package that uses
+ at code{ASDF}.
+
+
@node TODO list, Inspiration, FAQ, Top
@comment node-name, next, previous, up
@@ -3263,7 +3455,7 @@
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
+ at section kmp's ``The Description of Large Systems'', MIT AI Memo 801
Available in updated-for-CL form on the web at
@url{http://nhplace.com/kent/Papers/Large-Systems.html}
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 Sun Oct 31 04:40:27 2010
@@ -47,73 +47,66 @@
#+xcvb (module ())
-(cl:in-package :cl)
-(defpackage :asdf-bootstrap (:use :cl))
-(in-package :asdf-bootstrap)
+(cl:in-package :cl-user)
+
+#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
-;; Implementation-dependent tweaks
(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
+ ;;; make package if it doesn't exist yet.
+ ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
+ (unless (find-package :asdf)
+ (make-package :asdf :use '(:cl)))
+ ;;; Implementation-dependent tweaks
+ ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
#+allegro
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car))
- #+ecl (require :cmp)
- #+gcl
- (eval-when (:compile-toplevel :load-toplevel)
- (defpackage :asdf-utilities (:use :cl))
- (defpackage :asdf (:use :cl :asdf-utilities))))
+ #+ecl (require :cmp))
+
+(in-package :asdf)
;;;; 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+ helps the version bumping script discriminate
- (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111.
- (existing-asdf (find-package :asdf))
- (vername '#:*asdf-version*)
- (versym (and existing-asdf
- (find-symbol (string vername) existing-asdf)))
- (existing-version (and versym (boundp versym) (symbol-value versym)))
+ (defvar *asdf-version* nil)
+ (defvar *upgraded-p* nil)
+ (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147
+ (existing-asdf (fboundp 'find-system))
+ (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
- #-gcl
(when existing-asdf
- (format *trace-output*
+ (format *error-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version asdf-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)))
+ ((unlink-package (package)
+ (let ((u (find-package package)))
+ (when u
+ (ensure-unintern u
+ (loop :for s :being :each :present-symbol :in u :collect s))
+ (loop :for p :in (package-used-by-list u) :do
+ (unuse-package u p))
+ (delete-package u))))
(ensure-exists (name nicknames use)
- (let* ((previous
- (remove-duplicates
- (remove-if
- #'null
- (mapcar #'find-package (cons name nicknames)))
- :from-end t)))
- (cond
- (previous
- ;; do away with packages with conflicting (nick)names
- (map () #'rename-away (cdr previous))
- ;; reuse previous package with same name
- (let ((p (car previous)))
+ (let ((previous
+ (remove-duplicates
+ (mapcar #'find-package (cons name nicknames))
+ :from-end t)))
+ ;; do away with packages with conflicting (nick)names
+ (map () #'unlink-package (cdr previous))
+ ;; reuse previous package with same name
+ (let ((p (car previous)))
+ (cond
+ (p
(rename-package p name nicknames)
(ensure-use p use)
- p))
- (t
- (make-package name :nicknames nicknames :use use)))))
+ p)
+ (t
+ (make-package name :nicknames nicknames :use use))))))
(find-sym (symbol package)
(find-symbol (string symbol) package))
(intern* (symbol package)
@@ -122,9 +115,16 @@
(let ((sym (find-sym symbol package)))
(when sym
(unexport sym package)
- (unintern sym package))))
+ (unintern sym package)
+ sym)))
(ensure-unintern (package symbols)
- (dolist (sym symbols) (remove-symbol sym package)))
+ (loop :with packages = (list-all-packages)
+ :for sym :in symbols
+ :for removed = (remove-symbol sym package)
+ :when removed :do
+ (loop :for p :in packages :do
+ (when (eq removed (find-sym sym p))
+ (unintern removed p)))))
(ensure-shadow (package symbols)
(shadow symbols package))
(ensure-use (package use)
@@ -138,15 +138,26 @@
:for sym = (find-sym name package)
:when sym :do (fmakunbound sym)))
(ensure-export (package export)
- (let ((syms (loop :for x :in export :collect
- (intern* x package))))
- (do-external-symbols (sym package)
- (unless (member sym syms)
- (remove-symbol sym package)))
- (dolist (sym syms)
- (export sym package))))
+ (let ((formerly-exported-symbols nil)
+ (bothly-exported-symbols nil)
+ (newly-exported-symbols nil))
+ (loop :for sym :being :each :external-symbol :in package :do
+ (if (member sym export :test 'string-equal)
+ (push sym bothly-exported-symbols)
+ (push sym formerly-exported-symbols)))
+ (loop :for sym :in export :do
+ (unless (member sym bothly-exported-symbols :test 'string-equal)
+ (push sym newly-exported-symbols)))
+ (loop :for user :in (package-used-by-list package)
+ :for shadowing = (package-shadowing-symbols user) :do
+ (loop :for new :in newly-exported-symbols
+ :for old = (find-sym new user)
+ :when (and old (not (member old shadowing)))
+ :do (unintern old user)))
+ (loop :for x :in newly-exported-symbols :do
+ (export (intern* x package)))))
(ensure-package (name &key nicknames use unintern fmakunbound shadow export)
- (let ((p (ensure-exists name nicknames use)))
+ (let* ((p (ensure-exists name nicknames use)))
(ensure-unintern p unintern)
(ensure-shadow p shadow)
(ensure-export p export)
@@ -161,41 +172,14 @@
:unintern ',(append #-(or gcl ecl) redefined-functions unintern)
:fmakunbound ',(append fmakunbound))))
(pkgdcl
- :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
- #: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))
- (pkgdcl
:asdf
- :use (:common-lisp :asdf-utilities)
+ :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
+ :use (:common-lisp)
:redefined-functions
(#:perform #:explain #:output-files #:operation-done-p
#:perform-with-restarts #:component-relative-pathname
- #:system-source-file #:operate #:find-component)
+ #:system-source-file #:operate #:find-component #:find-system
+ #:apply-output-translations #:translate-pathname* #:resolve-location)
:unintern
(#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector)
@@ -207,7 +191,7 @@
:export
(#:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
- #:compile-system #:load-system #:test-system
+ #:compile-system #:load-system #:test-system #:clear-system
#:compile-op #:load-op #:load-source-op
#:test-op
#:operation ; operations
@@ -215,7 +199,7 @@
#:version ; metaphorically sort-of an operation
#:version-satisfies
- #:input-files #:output-files #:perform ; operation methods
+ #:input-files #:output-files #:output-file #:perform ; operation methods
#:operation-done-p #:explain
#:component #:source-file
@@ -254,6 +238,7 @@
#:operation-on-warnings
#:operation-on-failure
+ #:component-visited-p
;;#:*component-parent-pathname*
#:*system-definition-search-functions*
#:*central-registry* ; variables
@@ -283,6 +268,7 @@
#:coerce-entry-to-directory
#:remove-entry-from-registry
+ #:clear-configuration
#:initialize-output-translations
#:disable-output-translations
#:clear-output-translations
@@ -291,28 +277,44 @@
#:compile-file*
#: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)))
- (let* ((version (intern* vername :asdf))
- (upvar (intern* '#:*upgraded-p* :asdf))
- (upval0 (and (boundp upvar) (symbol-value upvar)))
- (upval1 (if existing-version (cons existing-version upval0) upval0)))
- (eval `(progn
- (defparameter ,version ,asdf-version)
- (defparameter ,upvar ',upval1))))))))
+ #:process-source-registry
+ #:system-registered-p
+ #:asdf-message
-(in-package :asdf)
+ ;; Utilities
+ #:absolute-pathname-p
+ ;; #:aif #:it
+ ;; #:appendf
+ #:coerce-name
+ #:directory-pathname-p
+ ;; #:ends-with
+ #:ensure-directory-pathname
+ #:getenv
+ ;; #:get-uid
+ ;; #:length=n-p
+ #:merge-pathnames*
+ #:pathname-directory-pathname
+ #:read-file-forms
+ ;; #:remove-keys
+ ;; #:remove-keyword
+ #:resolve-symlinks
+ #:split-string
+ #:component-name-to-pathname-components
+ #:split-name-type
+ #:subdirectories
+ #:truenamize
+ #:while-collecting)))
+ (setf *asdf-version* asdf-version
+ *upgraded-p* (if existing-version
+ (cons existing-version *upgraded-p*)
+ *upgraded-p*))))))
;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-#+gcl
-(eval-when (:compile-toplevel :load-toplevel)
- (defvar *asdf-version* nil)
- (defvar *upgraded-p* nil))
(when *upgraded-p*
#+ecl
(when (find-class 'compile-op nil)
@@ -326,9 +328,11 @@
'(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable deleted plist))
- (format *trace-output* "Updating ~A~%" m)
+ (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
(when (member 'components-by-name added)
- (compute-module-components-by-name m))))))
+ (compute-module-components-by-name m))
+ (when (and (typep m 'system) (member 'source-file added))
+ (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
@@ -342,17 +346,18 @@
(defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems.
-Defaults to `t`.")
+Defaults to T.")
-(defvar *compile-file-warnings-behaviour* :warn
- "How should ASDF react if it encounters a warning when compiling a
-file? Valid values are :error, :warn, and :ignore.")
-
-(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
- "How should ASDF react if it encounters a failure \(per the
-ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are
-:error, :warn, and :ignore. Note that ASDF ALWAYS raises an error
-if it fails to create an output file when compiling.")
+(defvar *compile-file-warnings-behaviour*
+ (or #+clisp :ignore :warn)
+ "How should ASDF react if it encounters a warning when compiling a file?
+Valid values are :error, :warn, and :ignore.")
+
+(defvar *compile-file-failure-behaviour*
+ (or #+sbcl :error #+clisp :ignore :warn)
+ "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
+when compiling a file? Valid values are :error, :warn, and :ignore.
+Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
(defvar *verbose-out* nil)
@@ -371,53 +376,64 @@
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
-(defmacro defgeneric* (name formals &rest options)
- `(progn
- #+(or gcl ecl) (fmakunbound ',name)
- (defgeneric ,name ,formals , at options)))
+(macrolet
+ ((defdef (def* def)
+ `(defmacro ,def* (name formals &rest rest)
+ `(progn
+ #+(or ecl gcl) (fmakunbound ',name)
+ ,(when (and #+ecl (symbolp name))
+ `(declaim (notinline ,name))) ; fails for setf functions on ecl
+ (,',def ,name ,formals , at rest)))))
+ (defdef defgeneric* defgeneric)
+ (defdef defun* defun))
+(defgeneric* find-system (system &optional error-p))
(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 component-operation-time (operation component))
+(defgeneric* component-operation-time (operation component))
+(defgeneric* operation-description (operation component)
+ (:documentation "returns a phrase that describes performing this operation
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
(defgeneric* system-source-file (system)
(:documentation "Return the source file in which system is defined."))
-(defgeneric component-system (component)
+(defgeneric* component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
-(defgeneric component-pathname (component)
+(defgeneric* component-pathname (component)
(:documentation "Extracts the pathname applicable for a particular component."))
-(defgeneric component-relative-pathname (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* component-property (component property))
-(defgeneric (setf component-property) (new-value component property))
+(defgeneric* (setf component-property) (new-value component property))
-(defgeneric version-satisfies (component version))
+(defgeneric* version-satisfies (component version))
(defgeneric* find-component (base path)
(:documentation "Finds the component with PATH starting from BASE module;
if BASE is nil, then the component is assumed to be a system."))
-(defgeneric source-file-type (component system))
+(defgeneric* source-file-type (component system))
-(defgeneric operation-ancestor (operation)
+(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)
+(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
@@ -430,7 +446,7 @@
data value is NIL, the combination had been explored, but no
operations needed to be performed."))
-(defgeneric visit-component (operation component data)
+(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
@@ -438,13 +454,16 @@
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."))
+discarded instead of recorded.
+ Starting with 2.006, TRAVERSE will store an integer in data,
+so that nodes can be sorted in decreasing order of traversal."))
+
-(defgeneric (setf visiting-component) (new-value operation component))
+(defgeneric* (setf visiting-component) (new-value operation component))
-(defgeneric component-visiting-p (operation component))
+(defgeneric* component-visiting-p (operation component))
-(defgeneric component-depends-on (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:
@@ -461,9 +480,9 @@
should usually append the results of CALL-NEXT-METHOD to the
list."))
-(defgeneric component-self-dependencies (operation component))
+(defgeneric* component-self-dependencies (operation component))
-(defgeneric traverse (operation component)
+(defgeneric* traverse (operation component)
(:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.
@@ -496,13 +515,13 @@
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
-(defun pathname-directory-pathname (pathname)
+(defun* pathname-directory-pathname (pathname)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
(when pathname
(make-pathname :name nil :type nil :version nil :defaults pathname)))
-(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
+(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."
@@ -511,7 +530,18 @@
(let* ((specified (pathname specified))
(defaults (pathname defaults))
(directory (pathname-directory specified))
- #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
+ (directory
+ (cond
+ #-(or sbcl cmu scl)
+ ((stringp directory) `(:absolute ,directory) directory)
+ #+gcl
+ ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
+ `(:relative , at directory))
+ ((or (null directory)
+ (and (consp directory) (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
@@ -520,7 +550,7 @@
(unspecific-handler (p)
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
- (#-gcl ecase #+gcl case (first directory)
+ (ecase (first directory)
((nil)
(values (pathname-host defaults)
(pathname-device defaults)
@@ -537,13 +567,6 @@
(if (pathname-directory defaults)
(append (pathname-directory defaults) (cdr directory))
directory)
- (unspecific-handler defaults)))
- #+gcl
- (t
- (assert (stringp (first directory)))
- (values (pathname-host defaults)
- (pathname-device defaults)
- (append (pathname-directory defaults) directory)
(unspecific-handler defaults))))
(make-pathname :host host :device device :directory directory
:name (funcall unspecific-handler name)
@@ -556,17 +579,17 @@
(define-modify-macro orf (&rest args)
or "or a flag")
-(defun first-char (s)
+(defun* first-char (s)
(and (stringp s) (plusp (length s)) (char s 0)))
-(defun last-char (s)
+(defun* last-char (s)
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-(defun asdf-message (format-string &rest format-args)
+(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)))
+(defun* split-string (string &key max (separator '(#\Space #\Tab)))
"Split STRING into a list of components separated by
any of the characters in the sequence SEPARATOR.
If MAX is specified, then no more than max(1,MAX) components will be returned,
@@ -586,7 +609,7 @@
(incf words)
(setf end start))))))
-(defun split-name-type (filename)
+(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.
@@ -598,7 +621,7 @@
(values filename unspecific)
(values name type)))))
-(defun component-name-to-pathname-components (s &optional force-directory)
+(defun* component-name-to-pathname-components (s &key force-directory force-relative)
"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.
@@ -615,12 +638,17 @@
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
pathnames."
(check-type s string)
+ (when (find #\: s)
+ (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
(let* ((components (split-string s :separator "/"))
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
(if (equal (first-char s) #\/)
- (values :absolute (cdr components))
+ (progn
+ (when force-relative
+ (error "absolute pathname designator not allowed: ~S" s))
+ (values :absolute (cdr components)))
(values :relative nil))
(values :relative components))
(setf components (remove "" components :test #'equal))
@@ -632,38 +660,30 @@
(t
(values relative (butlast components) last-comp))))))
-(defun remove-keys (key-names args)
+(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)
+(defun* remove-keyword (key args)
(loop :for (k v) :on args :by #'cddr
:unless (eq k key)
:append (list k v)))
-(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* getenv (x)
+ (#+abcl ext:getenv
+ #+allegro sys:getenv
+ #+clisp ext:getenv
+ #+clozure ccl:getenv
+ #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
+ #+ecl si:getenv
+ #+gcl system:getenv
+ #+lispworks lispworks:environment-variable
+ #+sbcl sb-ext:posix-getenv
+ x))
-(defun directory-pathname-p (pathname)
+(defun* directory-pathname-p (pathname)
"Does PATHNAME represent a directory?
A directory-pathname is a pathname _without_ a filename. The three
@@ -672,13 +692,16 @@
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)))
+ (when pathname
+ (let ((pathname (pathname pathname)))
+ (flet ((check-one (x)
+ (member x '(nil :unspecific "") :test 'equal)))
+ (and (not (wild-pathname-p pathname))
+ (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname))
+ t)))))
-(defun ensure-directory-pathname (pathspec)
+(defun* ensure-directory-pathname (pathspec)
"Converts the non-wild pathname designator PATHSPEC to directory form."
(cond
((stringp pathspec)
@@ -686,7 +709,7 @@
((not (pathnamep pathspec))
(error "Invalid pathname designator ~S" pathspec))
((wild-pathname-p pathspec)
- (error "Can't reliably convert wild pathnames."))
+ (error "Can't reliably convert wild pathname ~S" pathspec))
((directory-pathname-p pathspec)
pathspec)
(t
@@ -696,10 +719,10 @@
:name nil :type nil :version nil
:defaults pathspec))))
-(defun absolute-pathname-p (pathspec)
- (eq :absolute (car (pathname-directory (pathname pathspec)))))
+(defun* absolute-pathname-p (pathspec)
+ (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
-(defun length=n-p (x n) ;is it that (= (length x) n) ?
+(defun* length=n-p (x n) ;is it that (= (length x) n) ?
(check-type n (integer 0 *))
(loop
:for l = x :then (cdr l)
@@ -708,14 +731,14 @@
((zerop i) (return (null l)))
((not (consp l)) (return nil)))))
-(defun ends-with (s suffix)
+(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)
+(defun* read-file-forms (file)
(with-open-file (in file)
(loop :with eof = (list nil)
:for form = (read in nil eof)
@@ -724,43 +747,56 @@
#-(and (or win32 windows mswindows mingw32) (not cygwin))
(progn
-#+clisp (defun get-uid () (posix:uid))
-#+sbcl (defun get-uid () (sb-unix:unix-getuid))
-#+cmu (defun get-uid () (unix:unix-getuid))
-#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
- '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
-#+ecl (defun get-uid ()
- #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
- '(ffi:c-inline () () :int "getuid()" :one-liner t)
- '(ext::getuid)))
-#+allegro (defun get-uid () (excl.osi:getuid))
-#-(or cmu sbcl clisp allegro ecl)
-(defun get-uid ()
- (let ((uid-string
- (with-output-to-string (*verbose-out*)
- (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")))))))
+ #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
+ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
+ (defun* get-uid ()
+ #+allegro (excl.osi:getuid)
+ #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
+ :for f = (ignore-errors (read-from-string s))
+ :when f :return (funcall f))
+ #+(or cmu scl) (unix:unix-getuid)
+ #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
+ '(ffi:c-inline () () :int "getuid()" :one-liner t)
+ '(ext::getuid))
+ #+sbcl (sb-unix:unix-getuid)
+ #-(or allegro clisp cmu ecl sbcl scl)
+ (let ((uid-string
+ (with-output-to-string (*verbose-out*)
+ (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)
+(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)
+(defun* probe-file* (p)
+ "when given a pathname P, probes the filesystem for a file or directory
+with given pathname and if it exists return its truename."
+ (etypecase p
+ (null nil)
+ (string (probe-file* (parse-namestring p)))
+ (pathname (unless (wild-pathname-p p)
+ #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
+ #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
+
+(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)))
- #-sbcl (when (stringp directory) (return p))
+ (let ((found (probe-file* p)))
+ (when found (return found)))
+ #-(or sbcl cmu) (when (stringp directory) (return p))
(when (not (eq :absolute (car directory))) (return p))
- (let ((sofar (ignore-errors (truename (pathname-root p)))))
+ (let ((sofar (probe-file* (pathname-root p))))
(unless sofar (return p))
(flet ((solution (directories)
(merge-pathnames*
@@ -772,35 +808,34 @@
sofar)))
(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
+ :for more = (probe-file*
+ (merge-pathnames*
+ (make-pathname :directory `(:relative ,component))
+ sofar)) :do
(if more
(setf sofar more)
(return (solution rest)))
:finally
(return (solution nil))))))))
-(defun resolve-symlinks (path)
+(defun* resolve-symlinks (path)
#-allegro (truenamize path)
#+allegro (excl:pathname-resolve-symbolic-links path))
-(defun default-directory ()
+(defun* default-directory ()
(truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-(defun lispize-pathname (input-file)
+(defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
(defparameter *wild-path*
(make-pathname :directory '(:relative :wild-inferiors)
:name :wild :type :wild :version :wild))
-(defun wilden (path)
+(defun* wilden (path)
(merge-pathnames* *wild-path* path))
-(defun directorize-pathname-host-device (pathname)
+(defun* directorize-pathname-host-device (pathname)
(let* ((root (pathname-root pathname))
(wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root))
@@ -813,7 +848,7 @@
(eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string t)
+ (component-name-to-pathname-components root-string :force-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname :defaults root
@@ -837,7 +872,8 @@
error-name error-pathname error-condition
duplicate-names-name
error-component error-operation
- module-components module-components-by-name)
+ module-components module-components-by-name
+ circular-dependency-components)
(ftype (function (t t) t) (setf module-components-by-name)))
@@ -856,7 +892,9 @@
(error-name c) (error-pathname c) (error-condition c)))))
(define-condition circular-dependency (system-definition-error)
- ((components :initarg :components :reader circular-dependency-components)))
+ ((components :initarg :components :reader circular-dependency-components))
+ (:report (lambda (c s)
+ (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
@@ -892,11 +930,29 @@
((name :accessor component-name :initarg :name :documentation
"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
- :accessor component-in-order-to)
;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
+ ;; POIU is a parallel (multi-process build) extension of ASDF. See
+ ;; http://www.cliki.net/poiu
(load-dependencies :accessor component-load-dependencies :initform nil)
- ;; XXX crap name, but it's an official API name!
+ ;; In the ASDF object model, dependencies exist between *actions*
+ ;; (an action is a pair of operation and component). They are represented
+ ;; alists of operations to dependencies (other actions) in each component.
+ ;; There are two kinds of dependencies, each stored in its own slot:
+ ;; in-order-to and do-first dependencies. These two kinds are related to
+ ;; the fact that some actions modify the filesystem,
+ ;; whereas other actions modify the current image, and
+ ;; this implies a difference in how to interpret timestamps.
+ ;; in-order-to dependencies will trigger re-performing the action
+ ;; when the timestamp of some dependency
+ ;; makes the timestamp of current action out-of-date;
+ ;; do-first dependencies do not trigger such re-performing.
+ ;; Therefore, a FASL must be recompiled if it is obsoleted
+ ;; by any of its FASL dependencies (in-order-to); but
+ ;; it needn't be recompiled just because one of these dependencies
+ ;; hasn't yet been loaded in the current image (do-first).
+ ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+ (in-order-to :initform nil :initarg :in-order-to
+ :accessor component-in-order-to)
(do-first :initform nil :initarg :do-first
:accessor component-do-first)
;; methods defined using the "inline" style inside a defsystem form:
@@ -915,7 +971,7 @@
(properties :accessor component-properties :initarg :properties
:initform nil)))
-(defun component-find-path (component)
+(defun* component-find-path (component)
(reverse
(loop :for c = component :then (component-parent c)
:while c :collect (component-name c))))
@@ -931,26 +987,24 @@
(format s "~@<~A, required by ~A~@:>"
(call-next-method c nil) (missing-required-by c)))
-(defun sysdef-error (format &rest arguments)
+(defun* sysdef-error (format &rest 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~
- ~@[ in ~A~]~@:>"
+ (format s "~@<component ~S not found~@[ in ~A~]~@:>"
(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)))))
+ (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)))))
(defmethod component-system ((component component))
(aif (component-parent component)
@@ -959,7 +1013,7 @@
(defvar *default-component-class* 'cl-source-file)
-(defun compute-module-components-by-name (module)
+(defun* compute-module-components-by-name (module)
(let ((hash (make-hash-table :test 'equal)))
(setf (module-components-by-name module) hash)
(loop :for c :in (module-components module)
@@ -989,7 +1043,7 @@
:initarg :default-component-class
:accessor module-default-component-class)))
-(defun component-parent-pathname (component)
+(defun* 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
@@ -1006,7 +1060,8 @@
(component-relative-pathname component)
(pathname-directory-pathname (component-parent-pathname component)))))
(unless (or (null pathname) (absolute-pathname-p pathname))
- (error "Invalid relative pathname ~S for component ~S" pathname component))
+ (error "Invalid relative pathname ~S for component ~S"
+ pathname (component-find-path component)))
(setf (slot-value component 'absolute-pathname) pathname)
pathname)))
@@ -1030,7 +1085,8 @@
(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)))
+ :writer %set-system-source-file)
+ (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
;;;; -------------------------------------------------------------------------
;;;; version-satisfies
@@ -1057,7 +1113,7 @@
;;;; -------------------------------------------------------------------------
;;;; Finding systems
-(defun make-defined-systems-table ()
+(defun* make-defined-systems-table ()
(make-hash-table :test 'equal))
(defvar *defined-systems* (make-defined-systems-table)
@@ -1067,17 +1123,17 @@
system definition was last updated, and the second element
of which is a system object.")
-(defun coerce-name (name)
+(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))))
-(defun system-registered-p (name)
+(defun* system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
-(defun clear-system (name)
+(defun* clear-system (name)
"Clear the entry for a system in the database of systems previously loaded.
Note that this does NOT in any way cause the code of the system to be unloaded."
;; There is no "unload" operation in Common Lisp, and a general such operation
@@ -1088,7 +1144,7 @@
;; that the system was loaded at some point.
(setf (gethash (coerce-name name) *defined-systems*) nil))
-(defun map-systems (fn)
+(defun* map-systems (fn)
"Apply FN to each defined system.
FN should be a function of one argument. It will be
@@ -1106,7 +1162,7 @@
(defparameter *system-definition-search-functions*
'(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
-(defun system-definition-pathname (system)
+(defun* system-definition-pathname (system)
(let ((system-name (coerce-name system)))
(or
(some (lambda (x) (funcall x system-name))
@@ -1130,7 +1186,7 @@
Going forward, we recommend new users should be using the source-registry.
")
-(defun probe-asd (name defaults)
+(defun* probe-asd (name defaults)
(block nil
(when (directory-pathname-p defaults)
(let ((file
@@ -1151,7 +1207,7 @@
(when target
(return (pathname target)))))))))
-(defun sysdef-central-registry-search (system)
+(defun* sysdef-central-registry-search (system)
(let ((name (coerce-name system))
(to-remove nil)
(to-replace nil))
@@ -1169,8 +1225,7 @@
(let* ((*print-circle* nil)
(message
(format nil
- "~@<While searching for system ~S: ~S evaluated ~
-to ~S which is not a directory.~@:>"
+ "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
system dir defaults)))
(error message))
(remove-entry-from-registry ()
@@ -1193,7 +1248,7 @@
(list new)
(subseq *central-registry* (1+ position))))))))))
-(defun make-temporary-package ()
+(defun* make-temporary-package ()
(flet ((try (counter)
(ignore-errors
(make-package (format nil "~A~D" :asdf counter)
@@ -1202,7 +1257,7 @@
(package (try counter) (try counter)))
(package package))))
-(defun safe-file-write-date (pathname)
+(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.
;; Also, generated files will not exist at the time planning is done
@@ -1213,15 +1268,17 @@
;; (or should we treat the case in a different, special way?)
(or (and pathname (probe-file pathname) (file-write-date pathname))
(progn
- (when pathname
+ (when (and pathname *asdf-verbose*)
(warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
pathname))
0)))
-(defun find-system (name &optional (error-p t))
+(defmethod find-system (name &optional (error-p t))
+ (find-system (coerce-name name) error-p))
+
+(defmethod find-system ((name string) &optional (error-p t))
(catch 'find-system
- (let* ((name (coerce-name name))
- (in-memory (system-registered-p name))
+ (let* ((in-memory (system-registered-p name))
(on-disk (system-definition-pathname name)))
(when (and on-disk
(or (not in-memory)
@@ -1240,28 +1297,34 @@
(load on-disk)))
(delete-package package))))
(let ((in-memory (system-registered-p name)))
- (if in-memory
- (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)))))))
+ (cond
+ (in-memory
+ (when on-disk
+ (setf (car in-memory) (safe-file-write-date on-disk)))
+ (cdr in-memory))
+ (error-p
+ (error 'missing-component :requires name)))))))
-(defun register-system (name system)
+(defun* register-system (name system)
(asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
(setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system)))
-(defun sysdef-find-asdf (system)
- (let ((name (coerce-name system)))
- (when (equal name "asdf")
- (let* ((registered (cdr (gethash name *defined-systems*)))
- (asdf (or registered
- (make-instance
- 'system :name "asdf"
- :source-file (or *compile-file-truename* *load-truename*)))))
- (unless registered
- (register-system "asdf" asdf))
- (throw 'find-system asdf)))))
+(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
+ (setf fallback (coerce-name fallback)
+ source-file (or source-file *compile-file-truename* *load-truename*)
+ requested (coerce-name requested))
+ (when (equal requested fallback)
+ (let* ((registered (cdr (gethash fallback *defined-systems*)))
+ (system (or registered
+ (apply 'make-instance 'system
+ :name fallback :source-file source-file keys))))
+ (unless registered
+ (register-system fallback system))
+ (throw 'find-system system))))
+
+(defun* sysdef-find-asdf (name)
+ (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
;;;; -------------------------------------------------------------------------
@@ -1317,14 +1380,14 @@
(declare (ignorable s))
(source-file-explicit-type component))
-(defun merge-component-name-type (name &key type defaults)
+(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*
+ ;; ASDF:MERGE-PATHNAMES*
(etypecase name
(pathname
name)
@@ -1332,7 +1395,8 @@
(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))
+ (component-name-to-pathname-components name :force-directory (eq type :directory)
+ :force-relative t)
(multiple-value-bind (name type)
(cond
((or (eq type :directory) (null filename))
@@ -1369,7 +1433,7 @@
;; including other systems we depend on.
;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
;; to force systems named in a given list
- ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
+ ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
(forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
:accessor operation-original-initargs)
@@ -1389,7 +1453,7 @@
;; empty method to disable initarg validity checking
(values))
-(defun node-for (o c)
+(defun* node-for (o c)
(cons (class-name (class-of o)) c))
(defmethod operation-ancestor ((operation operation))
@@ -1398,7 +1462,7 @@
operation))
-(defun make-sub-operation (c o dep-c dep-o)
+(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."
@@ -1543,9 +1607,9 @@
"This dynamically-bound variable is used to force operations in
recursive calls to traverse.")
-(defgeneric do-traverse (operation component collect))
+(defgeneric* do-traverse (operation component collect))
-(defun %do-one-dep (operation c collect required-op required-c required-v)
+(defun* %do-one-dep (operation c collect required-op required-c required-v)
;; collects a partial plan that results from performing required-op
;; on required-c, possibly with a required-vERSION
(let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
@@ -1561,9 +1625,9 @@
(op (make-sub-operation c operation dep-c required-op)))
(do-traverse op dep-c collect)))
-(defun do-one-dep (operation c collect 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.
+(defun* do-one-dep (operation c collect required-op required-c required-v)
+ ;; this function is a thin, error-handling wrapper around %do-one-dep.
+ ;; Collects a partial plan per that function.
(loop
(restart-case
(return (%do-one-dep operation c collect
@@ -1571,22 +1635,15 @@
(retry ()
:report (lambda (s)
(format s "~@<Retry loading component ~S.~@:>"
- required-c))
+ (component-find-path 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))))))))
-(defun do-dep (operation c collect op dep)
+(defun* do-dep (operation c collect op dep)
;; type of arguments uncertain:
;; op seems to at least potentially be a symbol, rather than an operation
;; dep is a list of component names
@@ -1625,7 +1682,9 @@
(error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
flag))))
-(defun do-collect (collect x)
+(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
+
+(defun* do-collect (collect x)
(funcall collect x))
(defmethod do-traverse ((operation operation) (c component) collect)
@@ -1710,10 +1769,10 @@
(do-collect collect (vector module-ops))
(do-collect collect (cons operation c)))))
(setf (visiting-component operation c) nil)))
- (visit-component operation c flag)
+ (visit-component operation c (when flag (incf *visit-count*)))
flag))
-(defun flatten-tree (l)
+(defun* flatten-tree (l)
;; You collected things into a list.
;; Most elements are just things to collect again.
;; A (simple-vector 1) indicate that you should recurse into its contents.
@@ -1740,12 +1799,12 @@
(mapcar #'coerce-name (operation-forced operation))))
(flatten-tree
(while-collecting (collect)
- (do-traverse operation c #'collect))))
+ (let ((*visit-count* 0))
+ (do-traverse operation c #'collect)))))
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
- "~@<required method PERFORM not implemented ~
- for operation ~A, component ~A~@:>"
+ "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
@@ -1753,7 +1812,10 @@
nil)
(defmethod explain ((operation operation) (component component))
- (asdf-message "~&;;; ~A on ~A~%" operation component))
+ (asdf-message "~&;;; ~A~%" (operation-description operation component)))
+
+(defmethod operation-description (operation component)
+ (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
;;;; -------------------------------------------------------------------------
;;;; compile-op
@@ -1767,6 +1829,12 @@
(flags :initarg :flags :accessor compile-op-flags
:initform #-ecl nil #+ecl '(:system-p t))))
+(defun output-file (operation component)
+ "The unique output file of performing OPERATION on COMPONENT"
+ (let ((files (output-files operation component)))
+ (assert (length=n-p files 1))
+ (first files)))
+
(defmethod perform :before ((operation compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
@@ -1783,7 +1851,8 @@
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
-(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
+(declaim (ftype (function ((or pathname string)
+ &rest t &key (:output-file t) &allow-other-keys)
(values t t t))
compile-file*))
@@ -1792,7 +1861,9 @@
(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)))
+ ;; on some implementations, there are more than one output-file,
+ ;; but the first one should always be the primary fasl that gets loaded.
+ (output-file (first (output-files operation c)))
(*compile-file-warnings-behaviour* (operation-on-warnings operation))
(*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
@@ -1835,6 +1906,9 @@
(declare (ignorable operation c))
nil)
+(defmethod operation-description ((operation compile-op) component)
+ (declare (ignorable operation))
+ (format nil "compiling component ~S" (component-find-path component)))
;;;; -------------------------------------------------------------------------
;;;; load-op
@@ -1844,11 +1918,11 @@
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
- #-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))))
+ (map () #'load
+ #-ecl (input-files o c)
+ #+ecl (loop :for i :in (input-files o c)
+ :unless (string= (pathname-type i) "fas")
+ :collect (compile-file-pathname (lispize-pathname i)))))
(defmethod perform-with-restarts (operation component)
(perform operation component))
@@ -1911,6 +1985,11 @@
(cons (list 'compile-op (component-name c))
(call-next-method)))
+(defmethod operation-description ((operation load-op) component)
+ (declare (ignorable operation))
+ (format nil "loading component ~S" (component-find-path component)))
+
+
;;;; -------------------------------------------------------------------------
;;;; load-source-op
@@ -1949,6 +2028,10 @@
(component-property c 'last-loaded-as-source)))
nil t))
+(defmethod operation-description ((operation load-source-op) component)
+ (declare (ignorable operation))
+ (format nil "loading component ~S" (component-find-path component)))
+
;;;; -------------------------------------------------------------------------
;;;; test-op
@@ -1998,21 +2081,19 @@
(retry ()
:report
(lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
+ (format s "~@<Retry ~A.~@:>" (operation-description op component))))
(accept ()
:report
(lambda (s)
- (format s "~@<Continue, treating ~S on ~S as ~
- having been successful.~@:>"
- op component))
+ (format s "~@<Continue, treating ~A as having been successful.~@:>"
+ (operation-description op component)))
(setf (gethash (type-of op)
(component-operation-times component))
(get-universal-time))
- (return)))))))
- op))
+ (return))))))
+ (values op steps))))
-(defun oos (operation-class system &rest args &key force verbose version
+(defun* oos (operation-class system &rest args &key force verbose version
&allow-other-keys)
(declare (ignore force verbose version))
(apply #'operate operation-class system args))
@@ -2042,37 +2123,40 @@
(setf (documentation 'operate 'function)
operate-docstring))
-(defun load-system (system &rest args &key force verbose version
+(defun* load-system (system &rest args &key force verbose 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))
+ (apply #'operate 'load-op system args)
+ t)
-(defun compile-system (system &rest args &key force verbose version
+(defun* compile-system (system &rest args &key force verbose 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))
+ (apply #'operate 'compile-op system args)
+ t)
-(defun test-system (system &rest args &key force verbose version
+(defun* test-system (system &rest args &key force verbose 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))
+ (apply #'operate 'test-op system args)
+ t)
;;;; -------------------------------------------------------------------------
;;;; Defsystem
-(defun load-pathname ()
+(defun* load-pathname ()
(let ((pn (or *load-pathname* *compile-file-pathname*)))
(if *resolve-symlinks*
(and pn (resolve-symlinks pn))
pn)))
-(defun determine-system-pathname (pathname pathname-supplied-p)
+(defun* determine-system-pathname (pathname pathname-supplied-p)
;; The defsystem macro calls us to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
@@ -2081,14 +2165,14 @@
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
- file-pathname
+ directory-pathname
(default-directory))))
(defmacro defsystem (name &body options)
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
defsystem-depends-on &allow-other-keys)
options
- (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
+ (let ((component-options (remove-keys '(: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
@@ -2112,7 +2196,7 @@
,(determine-system-pathname pathname pathname-arg-p)
',component-options))))))
-(defun class-for-type (parent type)
+(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
(unless (keywordp type) type)
(find-symbol (symbol-name type) *package*)
@@ -2125,7 +2209,7 @@
(find-class *default-component-class*)))
(sysdef-error "~@<don't recognize component type ~A~@:>" type)))
-(defun maybe-add-tree (tree op1 op2 c)
+(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)))
@@ -2140,7 +2224,7 @@
tree)
(acons op1 (list (list op2 c)) tree))))
-(defun union-of-dependencies (&rest deps)
+(defun* union-of-dependencies (&rest deps)
(let ((new-tree nil))
(dolist (dep deps)
(dolist (op-tree dep)
@@ -2153,12 +2237,12 @@
(defvar *serial-depends-on* nil)
-(defun sysdef-error-component (msg type name value)
+(defun* sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg
"~&The value specified for ~(~A~) ~A is ~S")
type name value))
-(defun check-component-input (type name weakly-depends-on
+(defun* check-component-input (type name weakly-depends-on
depends-on components in-order-to)
"A partial test of the values of a component."
(unless (listp depends-on)
@@ -2174,7 +2258,7 @@
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
-(defun %remove-component-inline-methods (component)
+(defun* %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
@@ -2186,7 +2270,7 @@
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
-(defun %define-component-inline-methods (ret rest)
+(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)
@@ -2200,11 +2284,11 @@
, at body))
(component-inline-methods ret)))))))
-(defun %refresh-component-inline-methods (component rest)
+(defun* %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
-(defun parse-component-form (parent options)
+(defun* parse-component-form (parent options)
(destructuring-bind
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
@@ -2285,7 +2369,7 @@
;;;; 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)
+(defun* run-shell-command (control-string &rest args)
"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."
@@ -2357,7 +2441,7 @@
(defmethod system-source-file ((system-name symbol))
(system-source-file (find-system system-name)))
-(defun system-source-directory (system-designator)
+(defun* system-source-directory (system-designator)
"Return a pathname object corresponding to the
directory in which the system specification (.asd file) is
located."
@@ -2365,7 +2449,7 @@
:type nil
:defaults (system-source-file system-designator)))
-(defun relativize-directory (directory)
+(defun* relativize-directory (directory)
(cond
((stringp directory)
(list :relative directory))
@@ -2374,13 +2458,13 @@
(t
directory)))
-(defun relativize-pathname-directory (pathspec)
+(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)
+(defun* system-relative-pathname (system name &key type)
(merge-pathnames*
(merge-component-name-type name :type type)
(system-source-directory system)))
@@ -2393,25 +2477,35 @@
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
- '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
- :corman :cormanlisp :armedbear :gcl :ecl :scl))
+ '((:acl :allegro)
+ (:lw :lispworks)
+ (:digitool) ; before clozure, so it won't get preempted by ccl
+ (:ccl :clozure)
+ (:corman :cormanlisp)
+ (:abcl :armedbear)
+ :sbcl :cmu :clisp :gcl :ecl :scl))
(defparameter *os-features*
- '((:windows :mswindows :win32 :mingw32)
+ '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
(:solaris :sunos)
- :linux ;; for GCL at least, must appear before :bsd.
- :macosx :darwin :apple
+ (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
+ (:macosx :darwin :darwin-target :apple)
:freebsd :netbsd :openbsd :bsd
: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
- :java-1.4 :java-1.5 :java-1.6 :java-1.7))
-
+ '((:amd64 :x86-64 :x86_64 :x8664-target)
+ (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+ :hppa64
+ :hppa
+ (:ppc64 :ppc64-target)
+ (:ppc32 :ppc32-target :ppc :powerpc)
+ :sparc64
+ (:sparc32 :sparc)
+ (:arm :arm-target)
+ (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
-(defun lisp-version-string ()
+(defun* lisp-version-string ()
(let ((s (lisp-implementation-version)))
(declare (ignorable s))
#+allegro (format nil
@@ -2428,7 +2522,7 @@
(if (member :64bit *features*) "-64bit" ""))
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
#+clisp (subseq s 0 (position #\space s))
- #+clozure (format nil "~d.~d-fasl~d"
+ #+clozure (format nil "~d.~d-f~d" ; shorten for windows
ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
(logand ccl::fasl-version #xFF))
@@ -2446,7 +2540,7 @@
#-(or allegro armedbear clisp clozure cmu cormanlisp digitool
ecl gcl lispworks mcl sbcl scl) s))
-(defun first-feature (features)
+(defun* first-feature (features)
(labels
((fp (thing)
(etypecase thing
@@ -2462,10 +2556,10 @@
(loop :for f :in features
:when (fp f) :return :it)))
-(defun implementation-type ()
+(defun* implementation-type ()
(first-feature *implementation-features*))
-(defun implementation-identifier ()
+(defun* implementation-identifier ()
(labels
((maybe-warn (value fstring &rest args)
(cond (value)
@@ -2480,8 +2574,7 @@
"No architecture feature found in ~a."
*architecture-features*))
(version (maybe-warn (lisp-version-string)
- "Don't know how to get Lisp ~
- implementation version.")))
+ "Don't know how to get Lisp implementation version.")))
(substitute-if
#\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
(format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
@@ -2495,16 +2588,16 @@
#+(or unix cygwin) #\:
#-(or unix cygwin) #\;)
-(defun user-homedir ()
+(defun* user-homedir ()
(truename (user-homedir-pathname)))
-(defun try-directory-subpath (x sub &key type)
+(defun* try-directory-subpath (x sub &key type)
(let* ((p (and x (ensure-directory-pathname x)))
- (tp (and p (ignore-errors (truename p))))
+ (tp (and p (probe-file* p)))
(sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
- (ts (and sp (ignore-errors (truename sp)))))
+ (ts (and sp (probe-file* sp))))
(and ts (values sp ts))))
-(defun user-configuration-directories ()
+(defun* user-configuration-directories ()
(remove-if
#'null
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
@@ -2517,7 +2610,7 @@
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
,(try (getenv "APPDATA") "common-lisp/config/"))
,(try (user-homedir) ".config/common-lisp/")))))
-(defun system-configuration-directories ()
+(defun* system-configuration-directories ()
(remove-if
#'null
(append
@@ -2527,21 +2620,20 @@
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
(list #p"/etc/common-lisp/"))))
-(defun in-first-directory (dirs x)
+(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)
+ :thereis (and dir (probe-file* (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)
+(defun* in-system-configuration-directory (x)
(in-first-directory (system-configuration-directories) x))
-(defun configuration-inheritance-directive-p (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
+(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))
@@ -2556,16 +2648,16 @@
:inherit-configuration :ignore-inherited-configuration)))
form)
-(defun validate-configuration-file (file validator description)
+(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 hidden-file-p (pathname)
+(defun* hidden-file-p (pathname)
(equal (first-char (pathname-name pathname)) #\.))
-(defun validate-configuration-directory (directory tag validator)
+(defun* validate-configuration-directory (directory tag validator)
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
@@ -2603,10 +2695,10 @@
;; with other users messing with such directories.
*user-cache*)
-(defun output-translations ()
+(defun* output-translations ()
(car *output-translations*))
-(defun (setf output-translations) (new-value)
+(defun* (setf output-translations) (new-value)
(setf *output-translations*
(list
(stable-sort (copy-list new-value) #'>
@@ -2617,34 +2709,34 @@
(length (pathname-directory (car x)))))))))
new-value)
-(defun output-translations-initialized-p ()
+(defun* output-translations-initialized-p ()
(and *output-translations* t))
-(defun clear-output-translations ()
+(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-asd*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type "asd" :version :newest))
-
-
-(declaim (ftype (function (t &optional boolean) (or null pathname))
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
+ (values (or null pathname) &optional))
resolve-location))
-(defun resolve-relative-location-component (super x &optional wildenp)
+(defun* resolve-relative-location-component (super x &key directory wilden)
(let* ((r (etypecase x
(pathname x)
(string x)
(cons
- (let ((car (resolve-relative-location-component super (car x) nil)))
+ (return-from resolve-relative-location-component
(if (null (cdr x))
- car
- (let ((cdr (resolve-relative-location-component
- (merge-pathnames* car super) (cdr x) wildenp)))
+ (resolve-relative-location-component
+ super (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ super (car x) :directory t :wilden nil))
+ (cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x)
+ :directory directory :wilden wilden)))
(merge-pathnames* cdr car)))))
((eql :default-directory)
(relativize-pathname-directory (default-directory)))
@@ -2652,56 +2744,62 @@
((eql :implementation-type) (string-downcase (implementation-type)))
#-(and (or win32 windows mswindows mingw32) (not cygwin))
((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)))
+ (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
+ (s (if (or (pathnamep x) (not wilden)) d (wilden 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-absolute-location-component (x wildenp)
+(defun* resolve-absolute-location-component (x &key directory wilden)
(let* ((r
(etypecase x
(pathname x)
- (string (ensure-directory-pathname x))
+ (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
(cons
- (let ((car (resolve-absolute-location-component (car x) nil)))
+ (return-from resolve-absolute-location-component
(if (null (cdr x))
- car
- (let ((cdr (resolve-relative-location-component
- car (cdr x) wildenp)))
- (merge-pathnames* cdr car)))))
+ (resolve-absolute-location-component
+ (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-absolute-location-component
+ (car x) :directory t :wilden nil))
+ (cdr (resolve-relative-location-component
+ car (cdr x) :directory directory :wilden wilden)))
+ (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
((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))))
+ (let ((p (make-pathname :directory '(:relative))))
+ (if wilden (wilden p) p))))
((eql :home) (user-homedir))
- ((eql :user-cache) (resolve-location *user-cache* nil))
- ((eql :system-cache) (resolve-location *system-cache* nil))
+ ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
+ ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
((eql :default-directory) (default-directory))))
- (s (if (and wildenp (not (pathnamep x)))
+ (s (if (and wilden (not (pathnamep x)))
(wilden r)
r)))
(unless (absolute-pathname-p s)
(error "Not an absolute pathname ~S" s))
s))
-(defun resolve-location (x &optional wildenp)
+(defun* resolve-location (x &key directory wilden)
(if (atom x)
- (resolve-absolute-location-component x wildenp)
- (loop :with path = (resolve-absolute-location-component (car x) nil)
+ (resolve-absolute-location-component x :directory directory :wilden wilden)
+ (loop :with path = (resolve-absolute-location-component
+ (car x) :directory (and (or directory (cdr x)) t)
+ :wilden (and wilden (null (cdr x))))
:for (component . morep) :on (cdr x)
+ :for dir = (and (or morep directory) t)
+ :for wild = (and wilden (not morep))
:do (setf path (resolve-relative-location-component
- path component (and wildenp (not morep))))
+ path component :directory dir :wilden wild))
:finally (return path))))
-(defun location-designator-p (x)
+(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)
+(defun* location-function-p (x)
(and
(consp x)
(length=n-p x 2)
@@ -2711,11 +2809,11 @@
(cddr x)
(length=n-p (second x) 2)))))
-(defun validate-output-translations-directive (directive)
+(defun* validate-output-translations-directive (directive)
(unless
(or (member directive '(:inherit-configuration
:ignore-inherited-configuration
- :enable-user-cache :disable-cache))
+ :enable-user-cache :disable-cache nil))
(and (consp directive)
(or (and (length=n-p directive 2)
(or (and (eq (first directive) :include)
@@ -2728,22 +2826,22 @@
(error "Invalid directive ~S~%" directive))
directive)
-(defun validate-output-translations-form (form)
+(defun* validate-output-translations-form (form)
(validate-configuration-form
form
:output-translations
'validate-output-translations-directive
"output translations"))
-(defun validate-output-translations-file (file)
+(defun* validate-output-translations-file (file)
(validate-configuration-file
file 'validate-output-translations-form "output translations"))
-(defun validate-output-translations-directory (directory)
+(defun* validate-output-translations-directory (directory)
(validate-configuration-directory
directory :output-translations 'validate-output-translations-directive))
-(defun parse-output-translations-string (string)
+(defun* parse-output-translations-string (string)
(cond
((or (null string) (equal string ""))
'(:output-translations :inherit-configuration))
@@ -2788,36 +2886,36 @@
system-output-translations-pathname
system-output-translations-directory-pathname))
-(defun wrapping-output-translations ()
+(defun* wrapping-output-translations ()
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
- #+sbcl (,(getenv "SBCL_HOME") ())
+ #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
- #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
+ #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
;; All-import, here is where we want user stuff to be:
:inherit-configuration
;; These are for convenience, and can be overridden by the user:
#+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; If we want to enable the user cache by default, here would be the place:
+ ;; We enable the user cache by default, and here is the place we do:
: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 ()
+(defun* user-output-translations-pathname ()
(in-user-configuration-directory *output-translations-file* ))
-(defun system-output-translations-pathname ()
+(defun* system-output-translations-pathname ()
(in-system-configuration-directory *output-translations-file*))
-(defun user-output-translations-directory-pathname ()
+(defun* user-output-translations-directory-pathname ()
(in-user-configuration-directory *output-translations-directory*))
-(defun system-output-translations-directory-pathname ()
+(defun* system-output-translations-directory-pathname ()
(in-system-configuration-directory *output-translations-directory*))
-(defun environment-output-translations ()
+(defun* environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
-(defgeneric process-output-translations (spec &key inherit collect))
+(defgeneric* process-output-translations (spec &key inherit collect))
(declaim (ftype (function (t &key (:collect (or symbol function))) t)
inherit-output-translations))
(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
@@ -2847,11 +2945,11 @@
(dolist (directive (cdr (validate-output-translations-form form)))
(process-output-translations-directive directive :inherit inherit :collect collect)))
-(defun inherit-output-translations (inherit &key 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)
+(defun* process-output-translations-directive (directive &key inherit collect)
(if (atom directive)
(ecase directive
((:enable-user-cache)
@@ -2860,7 +2958,7 @@
(process-output-translations-directive '(t t) :collect collect))
((:inherit-configuration)
(inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration)
+ ((:ignore-inherited-configuration nil)
nil))
(let ((src (first directive))
(dst (second directive)))
@@ -2869,7 +2967,7 @@
(process-output-translations (pathname dst) :inherit nil :collect collect))
(when src
(let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src t)))
+ (let ((loc (resolve-location src :directory t :wilden t)))
(if (absolute-pathname-p loc) (truenamize loc) loc)))))
(cond
((location-function-p dst)
@@ -2882,14 +2980,14 @@
(funcall collect (list trusrc t)))
(t
(let* ((trudst (make-pathname
- :defaults (if dst (resolve-location dst t) trusrc)))
+ :defaults (if dst (resolve-location dst :directory t :wilden 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)
+(defun* compute-output-translations (&optional parameter)
"read the configuration, return it"
(remove-duplicates
(while-collecting (c)
@@ -2897,12 +2995,12 @@
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end t))
-(defun initialize-output-translations (&optional parameter)
+(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 ()
+(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
@@ -2912,12 +3010,28 @@
;; 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 ()
+(defun* ensure-output-translations ()
(if (output-translations-initialized-p)
(output-translations)
(initialize-output-translations)))
-(defun apply-output-translations (path)
+(defun* translate-pathname* (path absolute-source destination &optional root source)
+ (declare (ignore source))
+ (cond
+ ((functionp destination)
+ (funcall destination path absolute-source))
+ ((eq destination t)
+ path)
+ ((not (pathnamep destination))
+ (error "invalid destination"))
+ ((not (absolute-pathname-p destination))
+ (translate-pathname path absolute-source (merge-pathnames* destination root)))
+ (root
+ (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
+ (t
+ (translate-pathname path absolute-source destination))))
+
+(defun* apply-output-translations (path)
(etypecase path
(logical-pathname
path)
@@ -2934,20 +3048,7 @@
(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)))
+ :return (translate-pathname* p absolute-source destination root source)
:finally (return p)))))
(defmethod output-files :around (operation component)
@@ -2960,24 +3061,24 @@
(mapcar #'apply-output-translations files)))
t))
-(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
(or output-file
(apply-output-translations
(apply 'compile-file-pathname
(truenamize (lispize-pathname input-file))
keys))))
-(defun tmpize-pathname (x)
+(defun* tmpize-pathname (x)
(make-pathname
:name (format nil "ASDF-TMP-~A" (pathname-name x))
:defaults x))
-(defun delete-file-if-exists (x)
+(defun* delete-file-if-exists (x)
(when (and x (probe-file x))
(delete-file x)))
-(defun compile-file* (input-file &rest keys &key &allow-other-keys)
- (let* ((output-file (apply 'compile-file-pathname* input-file keys))
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+ (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
@@ -3001,7 +3102,7 @@
(values output-truename warnings-p failure-p))))
#+abcl
-(defun translate-jar-pathname (source wildcard)
+(defun* translate-jar-pathname (source wildcard)
(declare (ignore wildcard))
(let* ((p (pathname (first (pathname-device source))))
(root (format nil "/___jar___file___root___/~@[~A/~]"
@@ -3017,7 +3118,7 @@
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations
-(defun enable-asdf-binary-locations-compatibility
+(defun* enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
@@ -3025,8 +3126,11 @@
(merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
(user-homedir)))
(include-per-user-information nil)
- (map-all-source-files nil)
+ (map-all-source-files (or #+(or ecl clisp) t nil))
(source-to-target-mappings nil))
+ #+(or ecl clisp)
+ (when (null map-all-source-files)
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
(wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
(mapped-files (make-pathname
@@ -3053,21 +3157,23 @@
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
+#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+(progn
(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)
+(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))
+(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)
+(defun* parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
@@ -3091,7 +3197,7 @@
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
-(defun parse-windows-shortcut (pathname)
+(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*)
@@ -3119,7 +3225,7 @@
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
(end-of-file ()
- nil))))
+ nil)))))
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
@@ -3127,9 +3233,11 @@
;; Using ack 1.2 exclusions
(defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
- "_sgbak" "autom4te.cache" "cover_db" "_build"))
+ "_sgbak" "autom4te.cache" "cover_db" "_build"
+ "debian")) ;; debian often build stuff under the debian directory... BAD.
(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
@@ -3137,50 +3245,105 @@
"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 ()
+(defun* source-registry ()
(car *source-registry*))
-(defun (setf source-registry) (new-value)
+(defun* (setf source-registry) (new-value)
(setf *source-registry* (list new-value))
new-value)
-(defun source-registry-initialized-p ()
+(defun* source-registry-initialized-p ()
(and *source-registry* t))
-(defun clear-source-registry ()
+(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 validate-source-registry-directive (directive)
+(defparameter *wild-asd*
+ (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+
+(defun directory-has-asd-files-p (directory)
+ (and (ignore-errors
+ (directory (merge-pathnames* *wild-asd* directory)
+ #+sbcl #+sbcl :resolve-symlinks nil
+ #+ccl #+ccl :follow-links nil
+ #+clisp #+clisp :circle t))
+ t))
+
+(defun subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-cormanlisp
+ (wild (merge-pathnames*
+ #-(or abcl allegro lispworks scl)
+ (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+ #+(or abcl allegro lispworks scl) "*.*"
+ directory))
+ (dirs
+ #-cormanlisp
+ (ignore-errors
+ (directory wild .
+ #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+ccl '(:follow-links nil :directories t :files nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+digitool '(:directories t)
+ #+sbcl '(:resolve-symlinks nil))))
+ #+cormanlisp (cl::directory-subdirs directory))
+ #+(or abcl allegro lispworks scl)
+ (dirs (remove-if-not #+abcl #'extensions:probe-directory
+ #+allegro #'excl:probe-directory
+ #+lispworks #'lw:file-directory-p
+ #-(or abcl allegro lispworks) #'directory-pathname-p
+ dirs)))
+ dirs))
+
+(defun collect-sub*directories (directory collectp recursep collector)
+ (when (funcall collectp directory)
+ (funcall collector directory))
+ (dolist (subdir (subdirectories directory))
+ (when (funcall recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector))))
+
+(defun collect-sub*directories-with-asd
+ (directory &key
+ (exclude *default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ #'directory-has-asd-files-p
+ #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+ collect))
+
+(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))))
+ (location-designator-p (first rest))))
((:exclude :also-exclude)
(every #'stringp rest))
(null rest))))
(error "Invalid directive ~S~%" directive))
directive)
-(defun validate-source-registry-form (form)
+(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)
+(defun* validate-source-registry-file (file)
(validate-configuration-file
file 'validate-source-registry-form "a source registry"))
-(defun validate-source-registry-directory (directory)
+(defun* validate-source-registry-directory (directory)
(validate-configuration-directory
directory :source-registry 'validate-source-registry-directive))
-(defun parse-source-registry-string (string)
+(defun* parse-source-registry-string (string)
(cond
((or (null string) (equal string ""))
'(:source-registry :inherit-configuration))
@@ -3214,25 +3377,11 @@
(push '(:ignore-inherited-configuration) directives))
(return `(:source-registry ,@(nreverse directives))))))))))
-(defun register-asd-directory (directory &key recurse exclude collect)
+(defun* register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
(funcall collect directory)
- (let* ((files
- (handler-case
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+clisp #+clisp :circle t)
- (error (c)
- (warn "Error while scanning system definitions under directory ~S:~%~A"
- directory c)
- nil)))
- (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)))))
+ (collect-sub*directories-with-asd
+ directory :exclude exclude :collect collect)))
(defparameter *default-source-registries*
'(environment-source-registry
@@ -3245,12 +3394,12 @@
(defparameter *source-registry-file* #p"source-registry.conf")
(defparameter *source-registry-directory* #p"source-registry.conf.d/")
-(defun wrapping-source-registry ()
+(defun* wrapping-source-registry ()
`(:source-registry
#+sbcl (:tree ,(getenv "SBCL_HOME"))
:inherit-configuration
#+cmu (:tree #p"modules:")))
-(defun default-source-registry ()
+(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)))
@@ -3276,18 +3425,18 @@
:collect `(:directory ,(try dir "common-lisp/systems/"))
:collect `(:tree ,(try dir "common-lisp/source/"))))
:inherit-configuration)))
-(defun user-source-registry ()
+(defun* user-source-registry ()
(in-user-configuration-directory *source-registry-file*))
-(defun system-source-registry ()
+(defun* system-source-registry ()
(in-system-configuration-directory *source-registry-file*))
-(defun user-source-registry-directory ()
+(defun* user-source-registry-directory ()
(in-user-configuration-directory *source-registry-directory*))
-(defun system-source-registry-directory ()
+(defun* system-source-registry-directory ()
(in-system-configuration-directory *source-registry-directory*))
-(defun environment-source-registry ()
+(defun* environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY"))
-(defgeneric process-source-registry (spec &key inherit register))
+(defgeneric* process-source-registry (spec &key inherit register))
(declaim (ftype (function (t &key (:register (or symbol function))) t)
inherit-source-registry))
(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
@@ -3316,24 +3465,25 @@
(dolist (directive (cdr (validate-source-registry-form form)))
(process-source-registry-directive directive :inherit inherit :register register))))
-(defun inherit-source-registry (inherit &key 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)
+(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)))
+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
((:directory)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (ensure-directory-pathname pathname)))))
+ (funcall register (resolve-location pathname :directory t)))))
((:tree)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
+ (funcall register (resolve-location pathname :directory t)
+ :recurse t :exclude *source-registry-exclusions*))))
((:exclude)
(setf *source-registry-exclusions* rest))
((:also-exclude)
@@ -3346,7 +3496,7 @@
nil)))
nil)
-(defun flatten-source-registry (&optional parameter)
+(defun* flatten-source-registry (&optional parameter)
(remove-duplicates
(while-collecting (collect)
(inherit-source-registry
@@ -3359,7 +3509,7 @@
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
-(defun compute-source-registry (&optional parameter)
+(defun* compute-source-registry (&optional parameter)
(while-collecting (collect)
(dolist (entry (flatten-source-registry parameter))
(destructuring-bind (directory &key recurse exclude) entry
@@ -3367,7 +3517,7 @@
directory
:recurse recurse :exclude exclude :collect #'collect)))))
-(defun initialize-source-registry (&optional parameter)
+(defun* initialize-source-registry (&optional parameter)
(setf (source-registry) (compute-source-registry parameter)))
;; Checks an initial variable to see whether the state is initialized
@@ -3378,41 +3528,49 @@
;; will be too late to provide a parameter to this function, though
;; you may override the configuration explicitly by calling
;; initialize-source-registry directly with your parameter.
-(defun ensure-source-registry (&optional parameter)
+(defun* ensure-source-registry (&optional parameter)
(if (source-registry-initialized-p)
(source-registry)
(initialize-source-registry parameter)))
-(defun sysdef-source-registry-search (system)
+(defun* sysdef-source-registry-search (system)
(ensure-source-registry)
(loop :with name = (coerce-name system)
:for defaults :in (source-registry)
:for file = (probe-asd name defaults)
:when file :return file))
+(defun* clear-configuration ()
+ (clear-source-registry)
+ (clear-output-translations))
+
;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
;;;;
-#+(or abcl clozure cmu ecl sbcl)
-(progn
- (defun module-provide-asdf (name)
- (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 (find-system (string-downcase name) nil)))
- (when system
- (load-system system)
- t))))
- (pushnew 'module-provide-asdf
- #+abcl sys::*module-provider-functions*
- #+clozure ccl:*module-provider-functions*
- #+cmu ext:*module-provider-functions*
- #+ecl si:*module-provider-functions*
- #+sbcl sb-ext:*module-provider-functions*))
+(defun* module-provide-asdf (name)
+ (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 (find-system (string-downcase name) nil)))
+ (when system
+ (load-system system)
+ t))))
+
+#+(or abcl clisp clozure cmu ecl sbcl)
+(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
+ (when x
+ (eval `(pushnew 'module-provide-asdf
+ #+abcl sys::*module-provider-functions*
+ #+clisp ,x
+ #+clozure ccl:*module-provider-functions*
+ #+cmu ext:*module-provider-functions*
+ #+ecl si:*module-provider-functions*
+ #+sbcl sb-ext:*module-provider-functions*))))
+
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
More information about the armedbear-cvs
mailing list