Skip to content
Snippets Groups Projects
Commit 335d386d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge branch 'master' into minimakefile

Conflicts:
	Makefile
	bin/asdf-builder
parents fe3d1afc f6c62d75
No related branches found
No related tags found
No related merge requests found
...@@ -75,7 +75,7 @@ ...@@ -75,7 +75,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "3.1.2.4" ;; to be automatically updated by make bump-version :version "3.1.3" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
:class #.(if (find-class 'package-inferred-system nil) 'package-inferred-system 'system) :class #.(if (find-class 'package-inferred-system nil) 'package-inferred-system 'system)
......
...@@ -5,8 +5,9 @@ ...@@ -5,8 +5,9 @@
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring #:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
#:clear-configuration-and-retry #:retry))
(in-package :asdf/cache) (in-package :asdf/cache)
;;; This stamp cache is useful for: ;;; This stamp cache is useful for:
...@@ -42,8 +43,17 @@ ...@@ -42,8 +43,17 @@
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override)) (if (and *asdf-cache* (not override))
(funcall fun) (funcall fun)
(let ((*asdf-cache* (make-hash-table :test 'equal))) (loop
(funcall fun))))) (restart-case
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(return (funcall fun)))
(retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
(clear-configuration-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clear-configuration)))))))
(defmacro with-asdf-cache ((&key key override) &body body) (defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
......
cl-asdf (2:3.1.2-1) unstable; urgency=low cl-asdf (2:3.1.3-1) unstable; urgency=low
Bug fix release:
* A bug in 3.1.2 caused errors when hot-upgrading from 3.1.2 ASDF.
* Fix bugs in ASDF component search caching. In some circumstances,
aggressive caching (particularly of negative results) interfered with
error-handling through restarts. Also, in some cases use of caching
interfered with error-checking. Some of these issues are discussed in
ticket #1335323 on launchpad.
* Miscellaneous bug fixes and tweaks to UIOP.
* Documentation improvements.
-- Francois-Rene Rideau <fare@tunes.org> Thu, 24 Jul 2014 12:48:29 -0400
cl-asdf (2:3.1.2-2) unstable; urgency=low
New release: New release:
* ~/common-lisp/ is now present by default in the source-registry, so * ~/common-lisp/ is now present by default in the source-registry, so
...@@ -56,7 +70,8 @@ cl-asdf (2:3.1.2-1) unstable; urgency=low ...@@ -56,7 +70,8 @@ cl-asdf (2:3.1.2-1) unstable; urgency=low
* Substantially rewritten, updated, and expanded manual. * Substantially rewritten, updated, and expanded manual.
* TODO updated. * TODO updated.
-- Robert P Goldman <rpgoldman@sift.info> Tue, 6 May 2014 10:54:29 -0500 -- Francois-Rene Rideau <fare@tunes.org> Mon, 19 May 2014 20:07:40 -0400
cl-asdf (2:3.0.3-1) unstable; urgency=low cl-asdf (2:3.0.3-1) unstable; urgency=low
......
...@@ -7,7 +7,8 @@ maintained the debian package as part of the upstream git repository at ...@@ -7,7 +7,8 @@ maintained the debian package as part of the upstream git repository at
The debian related changes and files are licensed according to the GPL-v2, see The debian related changes and files are licensed according to the GPL-v2, see
/usr/share/common-licenses/GPL-2 /usr/share/common-licenses/GPL-2
Upstream Authors: Dan Barlow <dan@telent.net> & Contributors Upstream Authors: Dan Barlow <dan@telent.net>, Francois-Rene Rideau
(fare@tunes.org), Robert P. Goldman (rpgoldman@sift.net) & Contributors.
Copyright: Copyright:
...@@ -15,7 +16,8 @@ Copyright: ...@@ -15,7 +16,8 @@ Copyright:
http://www.opensource.org/licenses/mit-license.html on or about http://www.opensource.org/licenses/mit-license.html on or about
Monday; July 13, 2009) Monday; July 13, 2009)
Copyright (c) 2001-2014 Daniel Barlow and contributors Copyright (c) 2001-2014 Daniel Barlow, Francois-Rene Rideau, Robert P. Goldman,
and contributors
Permission is hereby granted, free of charge, to any person obtaining Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the a copy of this software and associated documentation files (the
......
...@@ -903,6 +903,7 @@ For that you may use the following function: ...@@ -903,6 +903,7 @@ For that you may use the following function:
regarding source-registry or output-translations. regarding source-registry or output-translations.
@end defun @end defun
@vindex *image-dump-hook*
This function is pushed onto the @code{uiop:*image-dump-hook*} by default, This function is pushed onto the @code{uiop:*image-dump-hook*} by default,
which means that if you save an image using @code{uiop:dump-image}, which means that if you save an image using @code{uiop:dump-image},
or via @code{asdf:image-op} and @code{asdf:program-op}, or via @code{asdf:image-op} and @code{asdf:program-op},
...@@ -2382,25 +2383,150 @@ the file's @code{last-modified} time exceeds the @code{last-modified} time ...@@ -2382,25 +2383,150 @@ the file's @code{last-modified} time exceeds the @code{last-modified} time
of the system in memory of the system in memory
@end itemize @end itemize
@cindex ASDF-USER package
When system definitions are loaded from @file{.asd} files, When system definitions are loaded from @file{.asd} files,
a new scratch package is created for them to load into, they are implicitly loaded into the @code{ASDF-USER} package,
so that different systems do not overwrite each others operations. which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{
The user may also wish to (and is recommended to) Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE},
include @code{defpackage} and @code{in-package} forms not all of @code{UIOP}, was used; if you want your code to work
in his system definition files, however, with releases earlier than 3.1.2, you may have to explicitly define a package
so that they can be loaded manually if need be. that uses @code{UIOP}, or use proper package prefix to your symbols, as in
@code{uiop:version<}.}
Programmers who do anything non-trivial in a @file{.asd} file,
such as defining new variables, functions or classes,
should include @code{defpackage} and @code{in-package} forms in this file,
so they will not overwrite each others' extensions.
Such forms might also help the files behave identically
if loaded manually with @code{cl:load} for development or debugging,
though we recommend you use the function @code{asdf::load-asd} instead,
which the @code{slime-asdf} contrib knows about.
The default value of @code{*system-definition-search-functions*} The default value of @code{*system-definition-search-functions*}
is a list of two functions. is a list of three functions.
The first function looks in each of the directories given The first function looks in each of the directories given
by evaluating members of @code{*central-registry*} by evaluating members of @code{*central-registry*}
for a file whose name is the name of the system and whose type is @file{asd}. for a file whose name is the name of the system and whose type is @file{asd};
The first such file is returned, the first such file is returned,
whether or not it turns out to actually define the appropriate system. whether or not it turns out to actually define the appropriate system.
The second function does something similar, The second function does something similar,
for the directories specified in the @code{source-registry}. for the directories specified in the @code{source-registry},
Hence, it is strongly advised to define a system but searches the filesystem only once and caches its results.
@var{foo} in the corresponding file @var{foo.asd}. The third function makes the @code{package-inferred-system} extension work,
@pxref{The package-inferred-system extension}.
Because of the way these search functions are defined,
you should put the definition for a system
@var{foo} in a file named @file{foo.asd},
in a directory that is
in the central registry or
which can be found using the
source registry configuration.
@c FIXME: Move this discussion to the system definition grammar, or somewhere else.
@anchor{System names}
@cindex System names
@cindex Primary system name
@findex primary-system-name
It is often useful to define multiple systems in a same file,
but ASDF can only locate a system's definition file based on the system
name.
For this reason,
ASDF 3's system search algorithm has been extended to
allow a file @file{foo.asd} to contain
secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc.,
in addition to the primary system named @var{foo}.
The first component of a system name,
separated by the slash character, @code{/},
is called the primary name of a system.
The primary name may be
extracted by function @code{asdf::primary-system-name};
when ASDF 3 is told to find a system whose name has a slash,
it will first attempt to load the corresponding primary system,
and will thus see any such definitions, and/or any
definition of a @code{package-inferred-system}.@footnote{
ASDF 2.26 and earlier versions
do not support this primary system name convention.
With these versions of ASDF
you must explicitly load @file{foo.asd}
before you can use system @var{foo/bar} defined therein,
e.g. using @code{(asdf:find-system "foo")}.
We do not support ASDF 2, and recommend that you should upgrade to ASDF 3.
}
If your file @file{foo.asd} also defines systems
that do not follow this convention, e.g., a system named @var{foo-test},
ASDF will not be able to automatically locate a definition for these systems,
and will only see their definition
if you explicitly find or load the primary system
using e.g. @code{(asdf:find-system "foo")} before you try to use them.
We strongly recommend against this practice,
though it is currently supported for backward compatibility.
@end defun
@defun primary-system-name name
Internal (not exported) function, @code{asdf::primary-system-name}.
Returns the primary system name (the portion before
the slash, @code{/}, in a secondary system name) from @var{name}.
@end defun
@defun locate-system name
This function should typically @emph{not} be invoked directly. It is
exported as part of the API only for programmers who wish to provide
their own @code{*system-definition-search-functions*}.
Given a system @var{name} designator,
try to locate where to load the system definition from.
@c (This does not include the loading of the system definition,
@c which is done by @code{find-system},
@c or the loading of the system itself, which is done by @code{load-system};
@c however, for systems the definition of which has already been loaded,
@c @code{locate-system} may return an object of class @code{system}.)
Returns five values: @var{foundp}, @var{found-system}, @var{pathname},
@var{previous}, and @var{previous-time}.
@var{foundp} is true when a system was found,
either a new as yet unregistered one, or a previously registered one.
The @var{found-system} return value
will be a @code{system} object, if a system definition is found in your
source registry.
@c This system may be registered (by @code{register-system}) or may not, if
@c it's preloaded code. Fare writes:
@c In the case of preloaded code, as for "asdf", "uiop", etc.,
@c themselves, the system objects are not registered until after they are
@c initially located by sysdef-preloaded-system-search as a fallback when
@c no source code was found.
The system definition will @emph{not} be
loaded if it hasn't been loaded already.
@var{pathname} when not null is a path from which to load the system,
either associated with @var{found-system}, or with the @var{previous} system.
If @var{previous} is not null, it will be a @emph{previously loaded}
@code{system} object of the same name (note that the system
@emph{definition} is previously-loaded: the system itself may or may not be).
@var{previous-time} when not null is
the timestamp of the previous system definition file, at the
time when the @var{previous} system definition was loaded.
For example, if your current registry has @file{foo.asd} in
@file{/current/path/to/foo.asd},
but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd}
then @var{locate-system} will return the following values:
@enumerate
@item
@var{foundp} will be @code{T},
@item
@var{found-system} will be @code{NIL},
@item
@var{pathname} will be @code{#p"/current/path/to/foo.asd"},
@item
@var{previous} will be an object of type @code{SYSTEM} with
@code{system-source-file} slot value of
@code{#p"/previous/path/to/foo.asd"}
@item
@var{previous-time} will be the timestamp of
@code{#p"/previous/path/to/foo.asd"} at the time it was loaded.
@end enumerate
@end defun @end defun
@defun find-component base path @defun find-component base path
...@@ -2719,8 +2845,8 @@ the default @code{defsystem} macro takes a @code{:class} keyword argument. ...@@ -2719,8 +2845,8 @@ the default @code{defsystem} macro takes a @code{:class} keyword argument.
New component types are defined by subclassing one of the existing New component types are defined by subclassing one of the existing
component classes and specializing methods on the new component class. component classes and specializing methods on the new component class.
@emph{FIXME: this should perhaps be explained more throughly, @c FIXME: this should perhaps be explained more throughly,
not only by example ...} @c not only by example ...
As an example, suppose we have some implementation-dependent As an example, suppose we have some implementation-dependent
functionality that we want to isolate functionality that we want to isolate
...@@ -2763,10 +2889,10 @@ The new component type is used in a @code{defsystem} form in this way: ...@@ -2763,10 +2889,10 @@ The new component type is used in a @code{defsystem} form in this way:
@c FIXME: Moved this material here, but it isn't very comfortable @c FIXME: Moved this material here, but it isn't very comfortable
@c here.... Also needs to be revised to be coherent. @c here.... Also needs to be revised to be coherent.
To be successfully buildable, this graph of actions but be acyclic. To be successfully build-able, this graph of actions must be acyclic.
If, as a user, extender or implementer of ASDF, you fail If, as a user, extender or implementer of ASDF, you introduce
to keep the dependency graph without cycles, a cycle into the dependency graph,
ASDF will fail loudly as it eventually finds one. ASDF will fail loudly.
To clearly distinguish the direction of dependencies, To clearly distinguish the direction of dependencies,
ASDF 3 uses the words @emph{requiring} and @emph{required} ASDF 3 uses the words @emph{requiring} and @emph{required}
as applied to an action depending on the other: as applied to an action depending on the other:
...@@ -2957,7 +3083,7 @@ however we recommend you instead use ...@@ -2957,7 +3083,7 @@ however we recommend you instead use
our source-registry configuration mechanism described below, our source-registry configuration mechanism described below,
because it is easier to setup in a portable way across users and implementations. because it is easier to setup in a portable way across users and implementations.
Addtionally, some people dislike truename, Additionally, some people dislike truename,
either because it is very slow on their system, or either because it is very slow on their system, or
because they are using content-addressed storage where the truename of a file because they are using content-addressed storage where the truename of a file
is related to a digest of its individual contents, is related to a digest of its individual contents,
...@@ -3245,9 +3371,9 @@ directory according to X's (relative) instructions. ...@@ -3245,9 +3371,9 @@ directory according to X's (relative) instructions.
When considering environment variable @code{CL_SOURCE_REGISTRY} When considering environment variable @code{CL_SOURCE_REGISTRY}
ASDF will skip to next configuration if it's an empty string. ASDF will skip to next configuration if it's an empty string.
It will @code{READ} the string as a SEXP in the DSL It will @code{READ} the string as a SEXP in the DSL
if it begins with a paren @code{(} if it begins with a paren @code{(},
and it will be interpreted much like @code{TEXINPUTS} otherwise it will be interpreted much like @code{TEXINPUTS},
list of paths, where as a list of paths, where
* paths are separated * paths are separated
by a @code{:} (colon) on Unix platforms (including cygwin), by a @code{:} (colon) on Unix platforms (including cygwin),
...@@ -3703,7 +3829,7 @@ TRANSLATION-FUNCTION := ...@@ -3703,7 +3829,7 @@ TRANSLATION-FUNCTION :=
SYMBOL | ;; symbol naming a function that takes two arguments: SYMBOL | ;; symbol naming a function that takes two arguments:
;; the pathname to be translated and the matching ;; the pathname to be translated and the matching
;; DIRECTORY-DESIGNATOR ;; DIRECTORY-DESIGNATOR
LAMBDA ;; A form which evalutates to a function taking two arguments: LAMBDA ;; A form which evaluates to a function taking two arguments:
;; the pathname to be translated and the matching ;; the pathname to be translated and the matching
;; DIRECTORY-DESIGNATOR ;; DIRECTORY-DESIGNATOR
...@@ -3764,7 +3890,7 @@ from the file specified. ...@@ -3764,7 +3890,7 @@ from the file specified.
If the @code{translate-pathname} mechanism cannot achieve a desired If the @code{translate-pathname} mechanism cannot achieve a desired
translation, the user may provide a function which provides the translation, the user may provide a function which provides the
required algorithim. Such a translation function is specified by required algorithm. Such a translation function is specified by
supplying a list as the second @code{directory-designator} supplying a list as the second @code{directory-designator}
the first element of which is the keyword @code{:function}, the first element of which is the keyword @code{:function},
and the second element of which is and the second element of which is
...@@ -5607,3 +5733,6 @@ Also, bugs are now tracked on launchpad: ...@@ -5607,3 +5733,6 @@ Also, bugs are now tracked on launchpad:
@printindex vr @printindex vr
@bye @bye
@c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl
@c LocalWords: namestring initargs fasls
...@@ -39,7 +39,7 @@ ...@@ -39,7 +39,7 @@
and the ability to deliver standalone executables. and the ability to deliver standalone executables.
It was pre-released as 2.27 on February 1st 2013, It was pre-released as 2.27 on February 1st 2013,
released as 3.0.0 on May 15th 2013, released as 3.0.0 on May 15th 2013,
and again as 3.1.2 on May 6th 2014. again as 3.1.2 on May 6th 2014, and as 3.1.3 on 24 July 2014.
</p> </p>
<a id="what_it_is"></a> <a id="what_it_is"></a>
<h3>What it is</h3> <h3>What it is</h3>
...@@ -419,6 +419,11 @@ XCL (Peter Graves) <gnooth@gmail.com> ...@@ -419,6 +419,11 @@ XCL (Peter Graves) <gnooth@gmail.com>
<a id="news"></a> <a id="news"></a>
<h3>What is happening</h3> <h3>What is happening</h3>
<dl> <dl>
<dt>May 2014 to July 2014</dt>
<dd>ASDF bug fixing from 3.1.2 leads to release of 3.1.3, a major bug
fix release. We strongly urge implementors that have shipped with 3.1.2
to upgrade to 3.1.3. There should be no incompatibilities, and some
very important bug fixes are provided. See the Changelog for more details.</dd>
<dt>July 2013 to May 2014</dt> <dt>July 2013 to May 2014</dt>
<dd>Fran&ccedil;ois-Ren&eacute; Rideau has resigned as maintainer <dd>Fran&ccedil;ois-Ren&eacute; Rideau has resigned as maintainer
but remained an active developer. but remained an active developer.
......
...@@ -107,10 +107,10 @@ ...@@ -107,10 +107,10 @@
(and (typep c 'missing-dependency) (and (typep c 'missing-dependency)
(eq (missing-required-by c) component) (eq (missing-required-by c) component)
(equal (missing-requires c) name)))) (equal (missing-requires c) name))))
(unless (component-parent component) (unless (component-parent component)
(let ((name (coerce-name name))) (let ((name (coerce-name name)))
(unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(find-system ,name))
(unset-asdf-cache-entry `(locate-system ,name)))))))) (unset-asdf-cache-entry `(locate-system ,name))))))))
(defun resolve-dependency-spec (component dep-spec) (defun resolve-dependency-spec (component dep-spec)
......
...@@ -99,8 +99,8 @@ of which is a system object.") ...@@ -99,8 +99,8 @@ of which is a system object.")
(defun clear-defined-systems () (defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered. ;; Invalidate all systems but ASDF itself, if registered.
(loop :for name :being :the :hash-keys :of *defined-systems* (loop :for name :being :the :hash-keys :of *defined-systems*
:unless (equal name "asdf") :unless (equal name "asdf")
:do (clear-defined-system name))) :do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
...@@ -353,79 +353,70 @@ but not loaded in memory" ...@@ -353,79 +353,70 @@ but not loaded in memory"
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
FOUNDP is true when a system was found, FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one. either a new unregistered one or a previously registered one.
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
PATHNAME when not null is a path from where to load the system, PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system. either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
(with-asdf-cache (:key `(locate-system ,name)) (let* ((name (coerce-name name))
(let* ((name (coerce-name name)) (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (previous (cdr in-memory))
(previous (cdr in-memory)) (previous (and (typep previous 'system) previous))
(previous (and (typep previous 'system) previous)) (previous-time (car in-memory))
(previous-time (car in-memory)) (found (search-for-system-definition name))
(found (search-for-system-definition name)) (found-system (and (typep found 'system) found))
(found-system (and (typep found 'system) found)) (pathname (ensure-pathname
(pathname (ensure-pathname (or (and (typep found '(or pathname string)) (pathname found))
(or (and (typep found '(or pathname string)) (pathname found)) (and found-system (system-source-file found-system))
(and found-system (system-source-file found-system)) (and previous (system-source-file previous)))
(and previous (system-source-file previous))) :want-absolute t :resolve-symlinks *resolve-symlinks*))
:want-absolute t :resolve-symlinks *resolve-symlinks*)) (foundp (and (or found-system pathname previous) t)))
(foundp (and (or found-system pathname previous) t))) (check-type found (or null pathname system))
(check-type found (or null pathname system)) (unless (check-not-old-asdf-system name pathname)
(unless (check-not-old-asdf-system name pathname) (cond
(cond (previous (setf found nil pathname nil))
(previous (setf found nil pathname nil)) (t
(t (setf found (sysdef-preloaded-system-search "asdf"))
(setf found (sysdef-preloaded-system-search "asdf")) (assert (typep found 'system))
(assert (typep found 'system)) (setf found-system found pathname nil))))
(setf found-system found pathname nil)))) (values foundp found-system pathname previous previous-time)))
(values foundp found-system pathname previous previous-time))))
(defmethod find-system ((name string) &optional (error-p t)) (defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name)) (with-asdf-cache (:key `(find-system ,name))
(let ((primary-name (primary-system-name name))) (let ((primary-name (primary-system-name name)))
(unless (equal name primary-name) (unless (equal name primary-name)
(find-system primary-name nil))) (find-system primary-name nil)))
(loop (or (and *immutable-systems* (gethash name *immutable-systems*)
(restart-case (cdr (system-registered-p name)))
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
(when (and found-system (eq found-system previous) (assert (eq foundp (and (or found-system pathname previous) t)))
(or (first (gethash `(find-system ,name) *asdf-cache*)) (let ((previous-pathname (and previous (system-source-file previous)))
(and *immutable-systems* (gethash name *immutable-systems*)))) (system (or previous found-system)))
(return found-system)) (when (and found-system (not previous))
(assert (eq foundp (and (or found-system pathname previous) t))) (register-system found-system))
(let ((previous-pathname (and previous (system-source-file previous))) (when (and system pathname)
(system (or previous found-system))) (setf (system-source-file system) pathname))
(when (and found-system (not previous)) (when (and pathname
(register-system found-system)) (let ((stamp (get-file-stamp pathname)))
(when (and system pathname) (and stamp
(setf (system-source-file system) pathname)) (not (and previous
(when (and pathname (or (pathname-equal pathname previous-pathname)
(let ((stamp (get-file-stamp pathname))) (and pathname previous-pathname
(and stamp (pathname-equal
(not (and previous (physicalize-pathname pathname)
(or (pathname-equal pathname previous-pathname) (physicalize-pathname previous-pathname))))
(and pathname previous-pathname (stamp<= stamp previous-time))))))
(pathname-equal ;; only load when it's a pathname that is different or has newer content, and not an old asdf
(physicalize-pathname pathname) (load-asd pathname :name name)))
(physicalize-pathname previous-pathname)))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(stamp<= stamp previous-time)))))) (cond
;; only load when it's a pathname that is different or has newer content, and not an old asdf (in-memory
(load-asd pathname :name name))) (when pathname
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (setf (car in-memory) (get-file-stamp pathname)))
(return (cdr in-memory))
(cond (error-p
(in-memory (error 'missing-component :requires name))
(when pathname (t ;; not found: don't keep negative cache, see lp#1335323
(setf (car in-memory) (get-file-stamp pathname))) (unset-asdf-cache-entry `(locate-system ,name))
(cdr in-memory)) (return-from find-system nil)))))))))
(error-p
(error 'missing-component :requires name))))))
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(unset-asdf-cache-entry `(locate-system ,name))
(initialize-source-registry)))))))
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.1.2.4: Another System Definition Facility. ;;; This is ASDF 3.1.3: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -126,11 +126,13 @@ ...@@ -126,11 +126,13 @@
#:package-inferred-system-missing-package-error #:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error #:operation-definition-warning #:operation-definition-error
#:try-recompiling #:try-recompiling ; restarts
#:retry #:retry
#:accept ; restarts #:accept
#:coerce-entry-to-directory #:coerce-entry-to-directory
#:remove-entry-from-registry #:remove-entry-from-registry
#:clear-configuration-and-retry
#:*encoding-detection-hook* #:*encoding-detection-hook*
#:*encoding-external-format-hook* #:*encoding-external-format-hook*
...@@ -166,5 +168,6 @@ ...@@ -166,5 +168,6 @@
#:user-source-registry #:user-source-registry
#:system-source-registry #:system-source-registry
#:user-source-registry-directory #:user-source-registry-directory
#:system-source-registry-directory)) #:system-source-registry-directory
))
...@@ -111,7 +111,8 @@ The default operation may change in the future if we implement a ...@@ -111,7 +111,8 @@ The default operation may change in the future if we implement a
component-directed strategy for how to load or compile systems.") component-directed strategy for how to load or compile systems.")
(defmethod component-depends-on ((o prepare-op) (s system)) (defmethod component-depends-on ((o prepare-op) (s system))
`((,*load-system-operation* ,@(component-sideway-dependencies s)))) (loop :for (o . cs) :in (call-next-method)
:collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
(defclass build-op (non-propagating-operation) () (defclass build-op (non-propagating-operation) ()
(:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
...@@ -122,7 +123,8 @@ as a symbol or as a string later read as a symbol (after loading the defsystem-d ...@@ -122,7 +123,8 @@ as a symbol or as a string later read as a symbol (after loading the defsystem-d
if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION* if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
that will load the system in the current image, and its typically LOAD-OP.")) that will load the system in the current image, and its typically LOAD-OP."))
(defmethod component-depends-on ((o build-op) (c component)) (defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) *load-system-operation*) ,c))) `((,(or (component-build-operation c) *load-system-operation*) ,c)
,@(call-next-method)))
(defun make (system &rest keys) (defun make (system &rest keys)
"The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
......
...@@ -6,7 +6,7 @@ extern int sample_function(); ...@@ -6,7 +6,7 @@ extern int sample_function();
int sample_function() int sample_function()
{ {
return 42; return 42;
} }
") ")
...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int sample_function(void); ...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int sample_function(void);
int sample_function(void) int sample_function(void)
{ {
return 42; return 42;
} }
") ")
...@@ -6,7 +6,7 @@ extern int always_7(); ...@@ -6,7 +6,7 @@ extern int always_7();
int always_7() int always_7()
{ {
return 7; return 7;
} }
") ")
...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int always_7(void); ...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int always_7(void);
int always_7(void) int always_7(void)
{ {
return 7; return 7;
} }
") ")
...@@ -6,7 +6,7 @@ extern int always_42(); ...@@ -6,7 +6,7 @@ extern int always_42();
int always_42() int always_42()
{ {
return 6*always_7(); return 6*always_7();
} }
") ")
...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int always_42(void); ...@@ -16,6 +16,6 @@ extern MKCL_DLLEXPORT int always_42(void);
int always_42(void) int always_42(void)
{ {
return 6*always_7(); return 6*always_7();
} }
") ")
...@@ -552,16 +552,18 @@ is bound, write a message and exit on an error. If ...@@ -552,16 +552,18 @@ is bound, write a message and exit on an error. If
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%") (format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) (acall :call-with-asdf-cache
(assert-pathname-equal-helper ;; not always EQUAL (!) #'(lambda ()
'*test-directory* *test-directory* (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
'(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) (assert-pathname-equal-helper ;; not always EQUAL (!)
(unless (equal *test-directory* x) '*test-directory* *test-directory*
(format t "Interestingly, while *test-directory* has components~% ~S~%~ '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%" ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*) (pathname-components *test-directory*)
(pathname-components x))) (pathname-components x)))
(setf *test-directory* x))) (setf *test-directory* x)))))
t) t)
(defun frob-packages () (defun frob-packages ()
......
;;; -*- Lisp -*-
;;; test to check that the cache doesn't upset error signaling from FIND-SYSTEM
(in-package asdf-test)
(defparameter *all-systems*
(list
"test-asdf"
"test-asdf/all"
"test-asdf/1"
"test-asdf/2"
"test-asdf/4"
"test-asdf/test9-1"
"test-asdf/test-module-depend"
"test-asdf/test9-2"
"test-asdf/test9-3"
"test-asdf/test-source-directory-1"
"test-asdf/test-source-directory-2"
"test-asdf/bundle-1"
"test-asdf/bundle-2"
"test-asdf/force"
"test-asdf/force1"))
(defun clear-caches-and-search ()
(setf asdf:*central-registry* nil)
(mapc #'asdf/find-system:clear-defined-system *all-systems*))
(clear-caches-and-search)
(assert (not (asdf:find-system "test-asdf/force1" nil)))
(multiple-value-bind (ret cond)
(ignore-errors (asdf:find-system "test-asdf/force1" t))
(assert (not ret))
(assert (typep cond 'asdf:missing-component)))
;;; -*- Lisp -*-
;;; test retrying finding location of an ASDF system.
(in-package asdf-test)
(defparameter *old-registry* asdf:*central-registry*)
;;(defparameter *search-table* (hash-table->alist asdf::*source-registry*))
;;(pprint *search-table*)
;;(terpri)
(assert (asdf:find-system "test-asdf/force1"))
(defun clear-caches-and-search ()
(setf asdf:*central-registry* nil)
(asdf/find-system:clear-defined-system "test-asdf")
(asdf/find-system:clear-defined-system "test-asdf/force1"))
(DBG "Clearing the caches and finding.")
(clear-caches-and-search)
(assert (not (asdf:find-system "test-asdf/force1" nil)))
(DBG "Correctly failed to find system.")
(assert
(let (tried-once)
(with-asdf-cache (:override t)
(handler-bind
((asdf:missing-component
#'(lambda (c)
(DBG "Caught MISSING-COMPONENT condition.")
(if (not tried-once)
(let ((missing (asdf::missing-requires c)))
(assert (equal missing "test-asdf/force1"))
(setf tried-once t)
(setf asdf:*central-registry* *old-registry*)
(invoke-restart 'asdf:retry))
;; avoid infinite looping
(error c)))))
(asdf:find-system "test-asdf/force1" t)))))
(DBG "Refinding test successful.")
(DBG "Now trying LOAD-SYSTEM with refinding.")
(clear-caches-and-search)
(def-test-system test-missing-dependency
:depends-on ("test-asdf/force1")
:components ((:file "file2")))
;; (trace find-system)
;; (trace find-component)
;; (trace asdf::component-find-path)
;; (trace operate)
(let (tried-once)
(with-asdf-cache (:override t)
(flet ((handle-missing (c)
(if (not tried-once)
(let ((missing (asdf::missing-requires c)))
(assert (equal missing "test-asdf/force1"))
(setf tried-once t)
(DBG "Trying to reset the central registry and retry.")
(setf asdf:*central-registry* *old-registry*)
(unless (find-restart 'asdf:clear-configuration-and-retry)
(error "Expected CLEAR-CONFIGURATION-AND-RETRY restart not found."))
(DBG "Before invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*)
(invoke-restart 'asdf:clear-configuration-and-retry)
(DBG "After invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*))
;; avoid infinite looping
(error c))))
(handler-bind
((asdf:missing-dependency-of-version
#'(lambda (c)
;; Nothing Quicklisp can do to recover from this, so
;; just resignal
(error c)))
(asdf:missing-dependency
#'(lambda (c)
(DBG "Catching MISSING-DEPENDENCY condition:" tried-once)
(handle-missing c)))
(asdf:missing-component
#'(lambda (c)
(DBG "Catching MISSING-COMPONENT condition:" tried-once)
(handle-missing c))))
(asdf:load-system "test-missing-dependency")))))
...@@ -160,6 +160,8 @@ ...@@ -160,6 +160,8 @@
asdf/backward-interface:on-warnings asdf/backward-interface:on-warnings
asdf/find-system:contrib-sysdef-search asdf/find-system:contrib-sysdef-search
asdf/find-system:sysdef-find-asdf asdf/find-system:sysdef-find-asdf
;; restart
asdf/cache:clear-configuration-and-retry
)) ))
(defun defined-symbol-p (symbol) (defun defined-symbol-p (symbol)
......
...@@ -148,7 +148,7 @@ this function tries to locate the Windows FOLDER for one of ...@@ -148,7 +148,7 @@ this function tries to locate the Windows FOLDER for one of
"Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
be applied to the results to yield a configuration form. Current be applied to the results to yield a configuration form. Current
values of TAG include :source-registry and :output-translations." values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
(remove-if (remove-if
'hidden-pathname-p 'hidden-pathname-p
(directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
......
...@@ -95,8 +95,8 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -95,8 +95,8 @@ This is designed to abstract away the implementation specific quit forms."
(declare (ignorable stream count condition)) (declare (ignorable stream count condition))
#+abcl #+abcl
(loop :for i :from 0 (loop :for i :from 0
:for frame :in (sys:backtrace (or count most-positive-fixnum)) :do :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
(safe-format! stream "~&~D: ~A~%" i frame)) (safe-format! stream "~&~D: ~A~%" i frame))
#+allegro #+allegro
(let ((*terminal-io* stream) (let ((*terminal-io* stream)
(*standard-output* stream) (*standard-output* stream)
...@@ -120,20 +120,20 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -120,20 +120,20 @@ This is designed to abstract away the implementation specific quit forms."
(debug:backtrace (or count most-positive-fixnum) stream)) (debug:backtrace (or count most-positive-fixnum) stream))
#+(or ecl mkcl) #+(or ecl mkcl)
(let* ((top (si:ihs-top)) (let* ((top (si:ihs-top))
(repeats (if count (min top count) top)) (repeats (if count (min top count) top))
(backtrace (loop :for ihs :from 0 :below top (backtrace (loop :for ihs :from 0 :below top
:collect (list (si::ihs-fun ihs) :collect (list (si::ihs-fun ihs)
(si::ihs-env ihs))))) (si::ihs-env ihs)))))
(loop :for i :from 0 :below repeats (loop :for i :from 0 :below repeats
:for frame :in (nreverse backtrace) :do :for frame :in (nreverse backtrace) :do
(safe-format! stream "~&~D: ~S~%" i frame))) (safe-format! stream "~&~D: ~S~%" i frame)))
#+gcl #+gcl
(let ((*debug-io* stream)) (let ((*debug-io* stream))
(ignore-errors (ignore-errors
(with-safe-io-syntax () (with-safe-io-syntax ()
(if condition (if condition
(conditions::condition-backtrace condition) (conditions::condition-backtrace condition)
(system::simple-backtrace))))) (system::simple-backtrace)))))
#+lispworks #+lispworks
(let ((dbg::*debugger-stack* (let ((dbg::*debugger-stack*
(dbg::grab-stack nil :how-many (or count most-positive-fixnum))) (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
...@@ -147,8 +147,8 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -147,8 +147,8 @@ This is designed to abstract away the implementation specific quit forms."
stream) stream)
#+xcl #+xcl
(loop :for i :from 0 :below (or count most-positive-fixnum) (loop :for i :from 0 :below (or count most-positive-fixnum)
:for frame :in (extensions:backtrace-as-list) :do :for frame :in (extensions:backtrace-as-list) :do
(safe-format! stream "~&~D: ~S~%" i frame))) (safe-format! stream "~&~D: ~S~%" i frame)))
(defun print-backtrace (&rest keys &key stream count condition) (defun print-backtrace (&rest keys &key stream count condition)
"Print a backtrace" "Print a backtrace"
...@@ -248,14 +248,14 @@ if we are not called from a directly executable image." ...@@ -248,14 +248,14 @@ if we are not called from a directly executable image."
;; SBCL and Allegro already separate user arguments from implementation arguments. ;; SBCL and Allegro already separate user arguments from implementation arguments.
#-(or sbcl allegro) #-(or sbcl allegro)
(unless (eq *image-dumped-p* :executable) (unless (eq *image-dumped-p* :executable)
;; LispWorks command-line processing isn't transparent to the user ;; LispWorks command-line processing isn't transparent to the user
;; unless you create a standalone executable; in that case, ;; unless you create a standalone executable; in that case,
;; we rely on cl-launch or some other script to set the arguments for us. ;; we rely on cl-launch or some other script to set the arguments for us.
#+lispworks (return *command-line-arguments*) #+lispworks (return *command-line-arguments*)
;; On other implementations, on non-standalone executables, ;; On other implementations, on non-standalone executables,
;; we trust cl-launch or whichever script starts the program ;; we trust cl-launch or whichever script starts the program
;; to use -- as a delimiter between implementation arguments and user arguments. ;; to use -- as a delimiter between implementation arguments and user arguments.
#-lispworks (setf arguments (member "--" arguments :test 'string-equal))) #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
(rest arguments))) (rest arguments)))
(defun argv0 () (defun argv0 ()
...@@ -290,7 +290,7 @@ immediately to the surrounding restore process if allowed to continue. ...@@ -290,7 +290,7 @@ immediately to the surrounding restore process if allowed to continue.
Then, comes the restore process itself: Then, comes the restore process itself:
First, call each function in the RESTORE-HOOK, First, call each function in the RESTORE-HOOK,
in the order they were registered with REGISTER-RESTORE-HOOK. in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
Second, evaluate the prelude, which is often Lisp text that is read, Second, evaluate the prelude, which is often Lisp text that is read,
as per EVAL-INPUT. as per EVAL-INPUT.
Third, call the ENTRY-POINT function, if any is specified, with no argument. Third, call the ENTRY-POINT function, if any is specified, with no argument.
...@@ -335,7 +335,7 @@ of the function will be returned rather than interpreted as a boolean designatin ...@@ -335,7 +335,7 @@ of the function will be returned rather than interpreted as a boolean designatin
(dump-hook *image-dump-hook*) (dump-hook *image-dump-hook*)
#+clozure prepend-symbols #+clozure (purify t) #+clozure prepend-symbols #+clozure (purify t)
#+sbcl compression #+sbcl compression
#+(and sbcl windows) application-type) #+(and sbcl os-windows) application-type)
"Dump an image of the current Lisp environment at pathname FILENAME, with various options. "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
...@@ -409,7 +409,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -409,7 +409,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(when compression (list :compression compression)) (when compression (list :compression compression))
;;--- only save runtime-options for standalone executables ;;--- only save runtime-options for standalone executables
(when executable (list :toplevel #'restore-image :save-runtime-options t)) (when executable (list :toplevel #'restore-image :save-runtime-options t))
#+(and sbcl windows) ;; passing :application-type :gui will disable the console window. #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
;; the default is :console - only works with SBCL 1.1.15 or later. ;; the default is :console - only works with SBCL 1.1.15 or later.
(when application-type (list :application-type application-type))))) (when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl) #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment