[armedbear-cvs] r12796 - in branches/generic-class-file/abcl: doc/asdf src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri Jul 9 21:01:32 UTC 2010
Author: ehuelsmann
Date: Fri Jul 9 17:01:30 2010
New Revision: 12796
Log:
Merge trunk/abcl:r12762-r12795.
Note: This branch will probably live for a while;
keeping as close to trunk as possible for easier
merge-back later on.
Modified:
branches/generic-class-file/abcl/doc/asdf/asdf.texinfo
branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: branches/generic-class-file/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- branches/generic-class-file/abcl/doc/asdf/asdf.texinfo (original)
+++ branches/generic-class-file/abcl/doc/asdf/asdf.texinfo Fri Jul 9 17:01:30 2010
@@ -170,11 +170,9 @@
the ASDF internals and how to extend ASDF.
@emph{Nota Bene}:
-We are preparing for a release of ASDF 2, hopefully for May 2010,
-which will have version 2.000 and later.
-Current releases, in the 1.700 series and beyond,
-should be considered as release candidates.
-We're still working on polishing the code and documentation.
+We have released ASDF 2.000 on May 31st 2010.
+It hopefully will have been it included
+in all CL maintained implementations shortly afterwards.
@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
@@ -241,7 +239,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 1.711,
+If you are running a version older than 2.000,
we recommend that you load a newer ASDF using the method below.
@@ -340,27 +338,28 @@
the authors of that tool should already have configured ASDF.
The simplest way to add a path to your search path,
-say @file{/foo/bar/baz/quux/}
+say @file{/home/luser/.asd-link-farm/}
is to create the directory
@file{~/.config/common-lisp/source-registry.conf.d/}
-and there create a file with any name of your choice,
-for instance @file{42-bazquux.conf}
+and there create a file with any name of your choice but the type @file{conf},
+for instance @file{42-asd-link-farm.conf}
containing the line:
- at kbd{(:directory "/foo/bar/baz/quux/")}
+ at kbd{(:directory "/home/luser/.asd-link-farm/")}
-If you want all the subdirectories under @file{/foo/bar/baz/}
+If you want all the subdirectories under @file{/home/luser/lisp/}
to be recursively scanned for @file{.asd} files, instead use:
- at kbd{(:tree "/foo/bar/baz/quux/")}
+ at kbd{(:tree "/home/luser/lisp/")}
Note that your Operating System distribution or your system administrator
may already have configured system-managed libraries for you.
-Also note that when choosing a filename, the convention is to use
-the @file{.conf} extension
-(and a non-empty extension is required for CLISP compatibility),
-and it is customary to start the filename with two digits
+The required @file{.conf} extension allows you to have disabled files
+or editor backups (ending in @file{~}), and works portably
+(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
+Excluded are files the name of which start with a @file{.} character.
+It is customary to start the filename with two digits
that specify the order in which the directories will be scanned.
ASDF will automatically read your configuration
@@ -485,7 +484,7 @@
to @file{/where/i/want/my/fasls/}
is to create the directory
@file{~/.config/common-lisp/asdf-output-translations.conf.d/}
-and there create a file with any name of your choice,
+and there create a file with any name of your choice and the type @file{conf},
for instance @file{42-bazquux.conf}
containing the line:
@@ -510,11 +509,11 @@
under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}.
@xref{Controlling where ASDF searches for systems}, for full details.
-
-Also note that when choosing a filename, the convention is to use
-the @file{.conf} extension
-(and a non-empty extension is required for CLISP compatibility),
-and it is customary to start the filename with two digits
+The required @file{.conf} extension allows you to have disabled files
+or editor backups (ending in @file{~}), and works portably
+(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
+Excluded are files the name of which start with a @file{.} character.
+It is customary to start the filename with two digits
that specify the order in which the directories will be scanned.
ASDF will automatically read your configuration
@@ -535,7 +534,7 @@
each in subtly different and incompatible ways:
ASDF-Binary-Locations, cl-launch, common-lisp-controller.
ASDF-Binary-Locations is now not needed anymore and should not be used.
-cl-launch 2.900 and common-lisp-controller 7.1 have been updated
+cl-launch 3.000 and common-lisp-controller 7.2 have been updated
to just delegate this functionality to ASDF.
@node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
@@ -813,6 +812,7 @@
@code{:my-component-type}, or @code{my-component-type}.
@subsection Pathname specifiers
+ at cindex pathname specifiers
A pathname specifier (@code{pathname-specifier})
may be a pathname, a string or a symbol.
@@ -845,6 +845,14 @@
and a string @code{"foo/bar.quux"}
will be interpreted as the pathname @file{#p"foo/bar.quux"}.
+ASDF does not interpret the string @code{".."} to designate the parent
+directory. This string will be passed through to the underlying
+operating system for interpretation. We @emph{believe} that this will
+work on all platforms where ASDF is deployed, but do not guarantee this
+behavior. A pathname object with a relative directory component of
+ at code{:up} or @code{:back} is the only guaranteed way to specify a
+parent directory.
+
If a symbol is given, it will be translated into a string,
and downcased in the process.
The downcasing of symbols is unconventional,
@@ -856,23 +864,26 @@
as argument to @code{make-pathname},
which is reported not to work on some implementations.
-Pathnames objects may be given to override the path for a component.
+Pathname objects may be given to override the path for a component.
Such objects are typically specified using reader macros such as @code{#p}
or @code{#.(make-pathname ...)}.
-Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)}
-and that the behavior @code{parse-namestring} is completely non-portable,
-unless you are using Common Lisp @code{logical-pathname}s.
-(@xref{The defsystem grammar,,Warning about logical pathnames}, below.)
+Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)}
+and that the behavior of @code{parse-namestring} is completely non-portable,
+unless you are using Common Lisp @code{logical-pathname}s
+(@pxref{The defsystem grammar,,Warning about logical pathnames}, below).
Pathnames made with @code{#.(make-pathname ...)}
can usually be done more easily with the string syntax above.
The only case that you really need a pathname object is to override
the component-type default file type for a given component.
-Therefore, it is a rare case that pathname objects should be used at all.
+Therefore, pathname objects should only rarely be used.
Unhappily, ASDF 1 didn't properly support
parsing component names as strings specifying paths with directories,
and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
-Note that when specifying pathname objects, no magic interpretation of the pathname
-is made depending on the component type.
+
+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.
On the one hand, you have to be careful to provide a pathname that correctly
fulfills whatever constraints are required from that component type
(e.g. naming a directory or a file with appropriate type);
@@ -881,6 +892,11 @@
@subsection Warning about logical pathnames
+ at cindex logical pathnames
+
+We recommend that you not use logical pathnames
+in your asdf system definitions at this point,
+but logical pathnames @emph{are} supported.
To use logical pathnames,
you will have to provide a pathname object as a @code{:pathname} specifier
@@ -888,24 +904,29 @@
@code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}.
You only have to specify such logical pathname for your system or
-some top-level component, as sub-components using the usual string syntax
-for names will be properly merged with the pathname of their parent.
+some top-level component. Sub-components' relative pathnames, specified
+using the string syntax
+for names, will be properly merged with the pathnames of their parents.
The specification of a logical pathname host however is @emph{not}
otherwise directly supported in the ASDF syntax
for pathname specifiers as strings.
-Logical pathnames are not specifically recommended to newcomers,
-but are otherwise supported.
-Moreover, the @code{asdf-output-translation} layer will
-avoid trying to resolve and translate logical-pathnames,
-so you can define yourself what translations you want to use
+The @code{asdf-output-translation} layer will
+avoid trying to resolve and translate logical-pathnames.
+The advantage of this is that you can define yourself what translations you want to use
with the logical pathname facility.
-
-The user of logical pathnames will have to configure logical pathnames himself,
-before they may be used, and ASDF provides no specific support for that.
+The disadvantage is that if you do not define such translations, any
+system that uses logical pathnames will be have differently under
+asdf-output-translations than other systems you use.
+
+If you wish to use logical pathnames you will have to configure the
+translations yourself before they may be used.
+ASDF currently provides no specific support
+for defining logical pathname translations.
@subsection Serial dependencies
+ at cindex serial dependencies
If the @code{:serial t} option is specified for a module,
ASDF will add dependencies for each each child component,
@@ -913,8 +934,8 @@
This is done as if by @code{:depends-on}.
@lisp
-:components ((:file "a") (:file "b") (:file "c"))
:serial t
+:components ((:file "a") (:file "b") (:file "c"))
@end lisp
is equivalent to
@@ -1713,23 +1734,26 @@
;; A directive is one of the following:
DIRECTIVE :=
+ ;; INHERITANCE DIRECTIVE:
+ ;; Your configuration expression MUST contain
+ ;; exactly one of either of these:
+ :inherit-configuration | ; splices inherited configuration (often specified last)
+ :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+
;; add a single directory to be scanned (no recursion)
(:directory DIRECTORY-PATHNAME-DESIGNATOR) |
;; add a directory hierarchy, recursing but excluding specified patterns
(:tree DIRECTORY-PATHNAME-DESIGNATOR) |
- ;; override the default defaults for exclusion patterns
+ ;; override the defaults for exclusion patterns
(:exclude PATTERN ...) |
+ ;; augment the defaults for exclusion patterns
+ (:also-exclude PATTERN ...) |
;; splice the parsed contents of another config file
(:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
- ;; Your configuration expression MUST contain
- ;; exactly one of either of these:
- :inherit-configuration | ; splices contents of inherited configuration
- :ignore-inherited-configuration | ; drop contents of inherited configuration
-
;; This directive specifies that some default must be spliced.
:default-registry
@@ -1738,6 +1762,15 @@
of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
@end example
+For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
+which is the default place ASDF looks for this configuration,
+once contained:
+ at example
+(:source-registry
+ (:tree "/home/fare/cl/")
+ :inherit-configuration)
+ at end example
+
@section Configuration Directories
@@ -1746,7 +1779,7 @@
The files will be sorted by namestring as if by @code{string<} and
the lists of directives of these files with be concatenated in order.
An implicit @code{:inherit-configuration} will be included
-at the end of the list.
+at the @emph{end} of the list.
This allows for packaging software that has file granularity
(e.g. Debian's @code{dpkg} or some future version of @code{clbuild})
@@ -1766,6 +1799,15 @@
(:include "/foo/bar/")
@end example
+Hence, to achieve the same effect as
+my example @file{~/.config/common-lisp/source-registry.conf} above,
+I could simply create a file
+ at file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf}
+alone in its directory with the following contents:
+ at example
+(:tree "/home/fare/cl/")
+ at end example
+
@section Shell-friendly syntax for configuration
@@ -1808,9 +1850,14 @@
XCVB currently raised an error.
If none is found, the search continues.
-Exclude statements specify patterns of subdirectories the systems of which
-to ignore. Typically you don't want to use copies of files kept by such
+Exclude statements specify patterns of subdirectories
+the systems from which to ignore.
+Typically you don't want to use copies of files kept by such
version control systems as Darcs.
+Exclude statements are not propagated to further included or inherited
+configuration files or expressions;
+instead the defaults are reset around every configuration statement
+to the default defaults from @code{asdf::*default-source-registry-exclusions*}.
Include statements cause the search to recurse with the path specifications
from the file specified.
@@ -2057,7 +2104,7 @@
in an easy way with configuration files.
Recent versions of same packages use
the new @code{asdf-output-translations} API as defined below:
- at code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00);
+ at code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000).
@code{ASDF-Binary-Locations} is fully superseded and not to be used anymore.
This incompatibility shouldn't inconvenience many people.
@@ -2110,13 +2157,14 @@
;; A directive is one of the following:
DIRECTIVE :=
- ;; include a configuration file or directory
- (:include PATHNAME-DESIGNATOR) |
-
+ ;; INHERITANCE DIRECTIVE:
;; Your configuration expression MUST contain
;; exactly one of either of these:
- :inherit-configuration | ; splices contents of inherited configuration
- :ignore-inherited-configuration | ; drop contents of inherited configuration
+ :inherit-configuration | ; splices inherited configuration (often specified last)
+ :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+
+ ;; include a configuration file or directory
+ (:include PATHNAME-DESIGNATOR) |
;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
:enable-user-cache |
@@ -2232,7 +2280,7 @@
The files will be sorted by namestring as if by @code{string<} and
the lists of directives of these files with be concatenated in order.
An implicit @code{:inherit-configuration} will be included
-at the end of the list.
+at the @emph{end} of the list.
This allows for packaging software that has file granularity
(e.g. Debian's @command{dpkg} or some future version of @command{clbuild})
@@ -2494,26 +2542,21 @@
@subsection What are ASDF 1 and ASDF 2?
-We are preparing for a release of ASDF 2,
-which will have version 2.000 and later.
-While the code and documentation are essentially complete
-we are still working on polishing them before release.
-
-Releases in the 1.700 series and beyond
-should be considered as release candidates.
-For all practical purposes,
-ASDF 2 refers to releases later than 1.656,
-and ASDF 1 to any release earlier than 1.369 or so.
-If your ASDF doesn't have a version, it's old.
+On May 31st 2010, we have released ASDF 2.
+ASDF 2 refers to release 2.000 and later.
+(Releases between 1.656 and 1.728 were development releases for ASDF 2.)
+ASDF 1 to any release earlier than 1.369 or so.
+If your ASDF doesn't sport a version, it's an old ASDF 1.
-ASDF 2 release candidates and beyond will have
+ASDF 2 and its release candidates push
@code{:asdf2} onto @code{*features*} so that if you are writing
ASDF-dependent code you may check for this feature
to see if the new API is present.
@emph{All} versions of ASDF should have the @code{:asdf} feature.
If you are experiencing problems or limitations of any sort with ASDF 1,
-we recommend that you should upgrade to ASDF 2 or its latest release candidate.
+we recommend that you should upgrade to ASDF 2,
+or whatever is the latest release.
@subsection ASDF can portably name files in subdirectories
@@ -2537,6 +2580,12 @@
@code{asdf-utilities:merge-pathnames*},
@code{asdf::merge-component-name-type}.
+On the other hand, there are places where systems used to accept namestrings
+where you must now use an explicit pathname object:
+ at code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+must now be written with the @code{#p} syntax:
+ at code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+
@xref{The defsystem grammar,,Pathname specifiers}.
@@ -2635,11 +2684,12 @@
@item
The internal test suite used to massively fail on many implementations.
While still incomplete, it now fully passes
-on all implementations supported by the test suite.
+on all implementations supported by the test suite,
+except for GCL (due to GCL bugs).
@item
Support was lacking for some implementations.
-ABCL was notably wholly broken.
+ABCL and GCL were notably wholly broken.
ECL extensions were not integrated in the ASDF release.
@item
@@ -2660,7 +2710,7 @@
With ASDF 2, we provide a new stable set of working features
that everyone can rely on from now on.
Use @code{#+asdf2} to detect presence of ASDF 2,
- at code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
+ at code{(asdf:version-satisfies (asdf:asdf-version) "2.000")}
to check the availability of a version no earlier than required.
@@ -2733,6 +2783,16 @@
@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
But thou shall not load ABL on top of ASDF 2.
+ at 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.
+Notably, in the @code{:pathname} argument to a @code{defsystem} and its components,
+a logical pathname (or implementation-dependent hierarchical pathname)
+must now be specified with @code{#p} syntax
+where the namestring might have previously sufficed;
+moreover when evaluation is desired @code{#.} must be used,
+where it wasn't necessary in the toplevel @code{:pathname} argument.
+
@end itemize
Other issues include the following:
@@ -3089,12 +3149,8 @@
@section Missing bits in implementation
-** all of the above
-
** reuse the same scratch package whenever a system is reloaded from disk
-** rules for system pathname defaulting are not yet implemented properly
-
** proclamations probably aren't
** when a system is reloaded with fewer components than it previously had, odd things happen
@@ -3103,16 +3159,6 @@
like take the list of kids and @code{setf} the slot to @code{nil},
then transfer children from old to new list as they're found.
-** traverse may become a normal function
-
-If you're defining methods on @code{traverse}, speak up.
-
-
-** a lot of load-op methods can be rewritten to use input-files
-
-so should be.
-
-
** (stuff that might happen later)
*** Propagation of the @code{:force} option.
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java Fri Jul 9 17:01:30 2010
@@ -514,6 +514,9 @@
autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");
autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass");
autoload(PACKAGE_JAVA, "get-default-classloader", "JavaClassLoader");
+ autoload(PACKAGE_JAVA, "make-classloader", "JavaClassLoader");
+ autoload(PACKAGE_JAVA, "add-to-classpath", "JavaClassLoader");
+ autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader");
autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java Fri Jul 9 17:01:30 2010
@@ -40,11 +40,20 @@
private LispObject propertyList = NIL;
private int callCount;
private int hotCount;
-
- protected Function() {}
+ /**
+ * The value of *load-truename* which was current when this function
+ * was loaded, used for fetching the class bytes in case of disassebly.
+ */
+ private final LispObject loadedFrom;
+
+ protected Function() {
+ LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow();
+ loadedFrom = loadTruename != null ? loadTruename : NIL;
+ }
public Function(String name)
{
+ this();
if (name != null) {
Symbol symbol = Symbol.addFunction(name.toUpperCase(), this);
if (cold)
@@ -55,6 +64,7 @@
public Function(Symbol symbol, String arglist)
{
+ this();
symbol.setSymbolFunction(this);
if (cold)
symbol.setBuiltInFunction(true);
@@ -64,6 +74,7 @@
public Function(Symbol symbol, String arglist, String docstring)
{
+ this();
symbol.setSymbolFunction(this);
if (cold)
symbol.setBuiltInFunction(true);
@@ -100,6 +111,7 @@
public Function(String name, Package pkg, boolean exported,
String arglist, String docstring)
{
+ this();
if (arglist instanceof String)
setLambdaList(new SimpleString(arglist));
if (name != null) {
@@ -120,11 +132,13 @@
public Function(LispObject name)
{
+ this();
setLambdaName(name);
}
public Function(LispObject name, LispObject lambdaList)
{
+ this();
setLambdaName(name);
setLambdaList(lambdaList);
}
@@ -182,7 +196,22 @@
} else {
ClassLoader c = getClass().getClassLoader();
if(c instanceof FaslClassLoader) {
- return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
+ final LispThread thread = LispThread.currentThread();
+ SpecialBindingsMark mark = thread.markSpecialBindings();
+ try {
+ thread.bindSpecial(Symbol.LOAD_TRUENAME, loadedFrom);
+ return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
+ } catch(Throwable t) {
+ //This is because unfortunately getFunctionClassBytes uses
+ //Debug.assertTrue(false) to signal errors
+ if(t instanceof ControlTransfer) {
+ throw (ControlTransfer) t;
+ } else {
+ return NIL;
+ }
+ } finally {
+ thread.resetSpecialBindings(mark);
+ }
} else {
return NIL;
}
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java Fri Jul 9 17:01:30 2010
@@ -210,26 +210,26 @@
private static final Primitive _JMAKE_PROXY =
new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
- "interface invocation-handler") {
+ "interfaces invocation-handler") {
public LispObject execute(final LispObject[] args) {
int length = args.length;
if (length != 3) {
return error(new WrongNumberOfArgumentsException(this));
}
- if(!(args[0] instanceof JavaObject) ||
- !(((JavaObject) args[0]).javaInstance() instanceof Class)) {
- return error(new TypeError(args[0], new SimpleString(Class.class.getName())));
+ if(!(args[0] instanceof Cons)) {
+ return error(new TypeError(args[0], new SimpleString("CONS")));
}
- if(!(args[1] instanceof JavaObject) ||
- !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) {
- return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName())));
- }
- Class<?> iface = (Class<?>) ((JavaObject) args[0]).javaInstance();
- InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance();
+ Class[] ifaces = new Class[args[0].length()];
+ LispObject ifList = args[0];
+ for(int i = 0; i < ifaces.length; i++) {
+ ifaces[i] = (Class) ifList.car().javaInstance(Class.class);
+ ifList = ifList.cdr();
+ }
+ InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class);
Object proxy = Proxy.newProxyInstance(
- iface.getClassLoader(),
- new Class[] { iface },
+ JavaClassLoader.getCurrentClassLoader(),
+ ifaces,
invocationHandler);
synchronized(proxyMap) {
proxyMap.put(proxy, args[2]);
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java Fri Jul 9 17:01:30 2010
@@ -39,8 +39,9 @@
import java.util.HashSet;
import java.util.Set;
import java.net.URL;
+import java.net.URLClassLoader;
-public class JavaClassLoader extends java.net.URLClassLoader {
+public class JavaClassLoader extends URLClassLoader {
private static JavaClassLoader persistentInstance;
@@ -168,6 +169,92 @@
}
};
+ private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath();
+ private static final class pf_dump_classpath extends Primitive
+ {
+ pf_dump_classpath()
+ {
+ super("dump-classpath", PACKAGE_JAVA, true, "&optional classloader");
+ }
+
+ @Override
+ public LispObject execute() {
+ return execute(new JavaObject(getCurrentClassLoader()));
+ }
+
+ @Override
+ public LispObject execute(LispObject classloader) {
+ LispObject list = NIL;
+ Object o = classloader.javaInstance();
+ while(o instanceof ClassLoader) {
+ ClassLoader cl = (ClassLoader) o;
+ list = list.push(dumpClassPath(cl));
+ o = cl.getParent();
+ }
+ return list.nreverse();
+ }
+ };
+
+ private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath();
+ private static final class pf_add_to_classpath extends Primitive
+ {
+ pf_add_to_classpath()
+ {
+ super("add-to-classpath", PACKAGE_JAVA, true, "jar-or-jars &optional (classloader (get-current-classloader))");
+ }
+
+ @Override
+ public LispObject execute(LispObject jarOrJars) {
+ return execute(jarOrJars, new JavaObject(getCurrentClassLoader()));
+ }
+
+ @Override
+ public LispObject execute(LispObject jarOrJars, LispObject classloader) {
+ Object o = classloader.javaInstance();
+ if(o instanceof JavaClassLoader) {
+ JavaClassLoader jcl = (JavaClassLoader) o;
+ if(jarOrJars instanceof Cons) {
+ while(jarOrJars != NIL) {
+ addURL(jcl, jarOrJars.car());
+ jarOrJars = jarOrJars.cdr();
+ }
+ } else {
+ addURL(jcl, jarOrJars);
+ }
+ return T;
+ } else {
+ return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName()));
+ }
+ }
+ };
+
+ protected static void addURL(JavaClassLoader jcl, LispObject jar) {
+ try {
+ if(jar instanceof Pathname) {
+ jcl.addURL(((Pathname) jar).toURL());
+ } else if(jar instanceof AbstractString) {
+ jcl.addURL(new Pathname(jar.toString()).toURL());
+ } else {
+ error(new TypeError(jar + " must be a pathname designator"));
+ }
+ } catch(java.net.MalformedURLException e) {
+ error(new LispError(jar + " is not a valid URL"));
+ }
+ }
+
+
+ public static LispObject dumpClassPath(ClassLoader o) {
+ if(o instanceof URLClassLoader) {
+ LispObject list = NIL;
+ for(URL u : ((URLClassLoader) o).getURLs()) {
+ list = list.push(new Pathname(u));
+ }
+ return new Cons(new JavaObject(o), list.nreverse());
+ } else {
+ return new JavaObject(o);
+ }
+ }
+
public static ClassLoader getCurrentClassLoader() {
LispObject classLoader = CLASSLOADER.symbolValueNoThrow();
if(classLoader != null) {
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Fri Jul 9 17:01:30 2010
@@ -606,8 +606,8 @@
// the namestring." 19.2.2.2.3.1
if (host != NIL) {
Debug.assertTrue(host instanceof AbstractString
- || host instanceof Cons);
- if (host instanceof Cons) {
+ || isURL());
+ if (isURL()) {
LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL);
LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL);
Debug.assertTrue(scheme != NIL);
@@ -631,7 +631,7 @@
}
if (device == NIL) {
} else if (device == Keyword.UNSPECIFIC) {
- } else if (device instanceof Cons) {
+ } else if (isJar()) {
LispObject[] jars = ((Cons) device).copyToArray();
StringBuilder prefix = new StringBuilder();
for (int i = 0; i < jars.length; i++) {
@@ -643,9 +643,6 @@
sb.append("!/");
}
sb = prefix.append(sb);
- } else if (device instanceof AbstractString
- && device.getStringValue().startsWith("jar:")) {
- sb.append(device.getStringValue());
} else if (device instanceof AbstractString) {
sb.append(device.getStringValue());
if (this instanceof LogicalPathname
@@ -723,7 +720,7 @@
}
}
namestring = sb.toString();
- // XXX Decide when this is necessary
+ // XXX Decide if this is necessary
// if (isURL()) {
// namestring = Utilities.uriEncode(namestring);
// }
@@ -1236,7 +1233,7 @@
namestring = file.getCanonicalPath();
} catch (IOException e) {
Debug.trace("Failed to make a Pathname from "
- + "." + file + "'");
+ + "'" + file + "'");
return null;
}
return new Pathname(namestring);
@@ -1290,7 +1287,7 @@
if (host == NIL) {
host = defaults.host;
}
- if (directory == NIL && defaults != null) {
+ if (directory == NIL) {
directory = defaults.directory;
}
if (!deviceSupplied) {
@@ -2084,7 +2081,8 @@
if (pathname.isURL()) {
result = new URL(pathname.getNamestring());
} else {
- // XXX ensure that we have cannonical path.
+ // XXX Properly encode Windows drive letters and UNC paths
+ // XXX ensure that we have cannonical path?
result = new URL("file://" + pathname.getNamestring());
}
} catch (MalformedURLException e) {
@@ -2342,6 +2340,22 @@
return getNamestring();
}
+ public URL toURL() throws MalformedURLException {
+ if(isURL()) {
+ return new URL(getNamestring());
+ } else {
+ return toFile().toURL();
+ }
+ }
+
+ public File toFile() {
+ if(!isURL()) {
+ return new File(getNamestring());
+ } else {
+ throw new RuntimeException(this + " does not represent a file");
+ }
+ }
+
static {
LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue();
Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj));
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java Fri Jul 9 17:01:30 2010
@@ -523,8 +523,10 @@
// If we're looking at zero return values, set 'value' to null
if (value == NIL) {
LispObject[] values = thread._values;
- if (values != null && values.length == 0)
+ if (values != null && values.length == 0) {
value = null;
+ thread._values = null; // reset 'no values' indicator
+ }
}
return value;
}
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jul 9 17:01:30 2010
@@ -47,30 +47,30 @@
#+xcvb (module ())
-(cl:in-package :cl-user)
+(cl:in-package :cl)
+(defpackage :asdf-bootstrap (:use :cl))
+(in-package :asdf-bootstrap)
-(declaim (optimize (speed 2) (debug 2) (safety 3))
- #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
-
-#+ecl (require :cmp)
+;; Implementation-dependent tweaks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; (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))))
;;;; 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.
-#+gcl
-(eval-when (:compile-toplevel :load-toplevel)
- (defpackage :asdf-utilities (:use :cl))
- (defpackage :asdf (:use :cl :asdf-utilities)))
-
(eval-when (:load-toplevel :compile-toplevel :execute)
- #+allegro
- (setf excl::*autoload-package-name-alist*
- (remove "asdf" excl::*autoload-package-name-alist*
- :test 'equalp :key 'car))
- (let* ((asdf-version
- ;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:1.719" (1+ (length "VERSION"))))
+ (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
+ (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
(existing-asdf (find-package :asdf))
(vername '#:*asdf-version*)
(versym (and existing-asdf
@@ -80,7 +80,7 @@
(unless (and existing-asdf already-there)
#-gcl
(when existing-asdf
- (format *error-output*
+ (format *trace-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version asdf-version))
(labels
@@ -155,13 +155,11 @@
(macrolet
((pkgdcl (name &key nicknames use export
redefined-functions unintern fmakunbound shadow)
- `(ensure-package
- ',name :nicknames ',nicknames :use ',use :export ',export
- :shadow ',shadow
- :unintern ',(append #-(or gcl ecl) redefined-functions
- unintern)
- :fmakunbound ',(append #+(or gcl ecl) redefined-functions
- fmakunbound))))
+ `(ensure-package
+ ',name :nicknames ',nicknames :use ',use :export ',export
+ :shadow ',shadow
+ :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
+ :fmakunbound ',(append fmakunbound))))
(pkgdcl
:asdf-utilities
:nicknames (#:asdf-extensions)
@@ -290,6 +288,7 @@
#:clear-output-translations
#:ensure-output-translations
#:apply-output-translations
+ #:compile-file*
#:compile-file-pathname*
#:enable-asdf-binary-locations-compatibility
@@ -327,6 +326,7 @@
'(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable deleted plist))
+ (format *trace-output* "Updating ~A~%" m)
(when (member 'components-by-name added)
(compute-module-components-by-name m))))))
@@ -336,7 +336,7 @@
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
*asdf-version*)
(defvar *resolve-symlinks* t
@@ -344,9 +344,15 @@
Defaults to `t`.")
-(defvar *compile-file-warnings-behaviour* :warn)
-
-(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+(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 *verbose-out* nil)
@@ -365,16 +371,20 @@
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
-
-(defgeneric perform-with-restarts (operation component))
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(defmacro defgeneric* (name formals &rest options)
+ `(progn
+ #+(or gcl ecl) (fmakunbound ',name)
+ (defgeneric ,name ,formals , at options)))
+
+(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 system-source-file (system)
+(defgeneric* system-source-file (system)
(:documentation "Return the source file in which system is defined."))
(defgeneric component-system (component)
@@ -396,7 +406,7 @@
(defgeneric version-satisfies (component version))
-(defgeneric find-component (base path)
+(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."))
@@ -455,17 +465,27 @@
(defgeneric traverse (operation component)
(:documentation
-"Generate and return a plan for performing `operation` on `component`.
+"Generate and return a plan for performing OPERATION on COMPONENT.
-The plan returned is a list of dotted-pairs. Each pair is the `cons`
-of ASDF operation object and a `component` object. The pairs will be
-processed in order by `operate`."))
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
(defmacro while-collecting ((&rest collectors) &body body)
+ "COLLECTORS should be a list of names for collections. A collector
+defines a function that, when applied to an argument inside BODY, will
+add its argument to the corresponding collection. Returns multiple values,
+a list for each collection, in order.
+ E.g.,
+\(while-collecting \(foo bar\)
+ \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
+ \(foo \(first x\)\)
+ \(bar \(second x\)\)\)\)
+Returns two values: \(A B C\) and \(1 2 3\)."
(let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
(initial-values (mapcar (constantly nil) collectors)))
`(let ,(mapcar #'list vars initial-values)
@@ -479,10 +499,8 @@
(defun pathname-directory-pathname (pathname)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
- (make-pathname :name nil :type nil :version nil :defaults pathname))
-
-(defun current-directory ()
- (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+ (when pathname
+ (make-pathname :name nil :type nil :version nil :defaults pathname)))
(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
@@ -493,7 +511,7 @@
(let* ((specified (pathname specified))
(defaults (pathname defaults))
(directory (pathname-directory specified))
- (directory (if (stringp directory) `(:absolute ,directory) directory))
+ #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
@@ -516,9 +534,9 @@
((:relative)
(values (pathname-host defaults)
(pathname-device defaults)
- (if (null (pathname-directory defaults))
- directory
- (append (pathname-directory defaults) (cdr directory)))
+ (if (pathname-directory defaults)
+ (append (pathname-directory defaults) (cdr directory))
+ directory)
(unspecific-handler defaults)))
#+gcl
(t
@@ -538,13 +556,19 @@
(define-modify-macro orf (&rest args)
or "or a flag")
+(defun first-char (s)
+ (and (stringp s) (plusp (length s)) (char s 0)))
+
+(defun last-char (s)
+ (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
(defun asdf-message (format-string &rest format-args)
(declare (dynamic-extent format-args))
(apply #'format *verbose-out* format-string format-args))
(defun split-string (string &key max (separator '(#\Space #\Tab)))
- "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
-return a list.
+ "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,
starting the separation from the end, e.g. when called with arguments
\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
@@ -595,13 +619,14 @@
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
- (if (and (plusp (length s)) (eql (char s 0) #\/))
+ (if (equal (first-char s) #\/)
(values :absolute (cdr components))
(values :relative nil))
(values :relative components))
+ (setf components (remove "" components :test #'equal))
(cond
((equal last-comp "")
- (values relative (butlast components) nil))
+ (values relative components nil)) ; "" already removed
(force-directory
(values relative components nil))
(t
@@ -618,17 +643,13 @@
:unless (eq k key)
:append (list k v)))
-(defun resolve-symlinks (path)
- #-allegro (truenamize path)
- #+allegro (excl:pathname-resolve-symbolic-links path))
-
(defun getenv (x)
#+abcl
(ext:getenv x)
#+sbcl
(sb-ext:posix-getenv x)
#+clozure
- (ccl::getenv x)
+ (ccl:getenv x)
#+clisp
(ext:getenv x)
#+cmu
@@ -643,13 +664,13 @@
(si:getenv x))
(defun directory-pathname-p (pathname)
- "Does `pathname` represent a directory?
+ "Does PATHNAME represent a directory?
A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be `nil`,
-`:unspecific` or the empty string.
+ways that the filename components can be missing are for it to be NIL,
+:UNSPECIFIC or the empty string.
-Note that this does _not_ check to see that `pathname` points to an
+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)))
@@ -733,10 +754,8 @@
(directory (pathname-directory p)))
(when (typep p 'logical-pathname) (return p))
(ignore-errors (return (truename p)))
- (when (stringp directory)
- (return p))
- (when (not (eq :absolute (car directory)))
- (return p))
+ #-sbcl (when (stringp directory) (return p))
+ (when (not (eq :absolute (car directory))) (return p))
(let ((sofar (ignore-errors (truename (pathname-root p)))))
(unless sofar (return p))
(flet ((solution (directories)
@@ -760,9 +779,43 @@
:finally
(return (solution nil))))))))
+(defun resolve-symlinks (path)
+ #-allegro (truenamize path)
+ #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun default-directory ()
+ (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+
(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)
+ (merge-pathnames* *wild-path* path))
+
+(defun directorize-pathname-host-device (pathname)
+ (let* ((root (pathname-root pathname))
+ (wild-root (wilden root))
+ (absolute-pathname (merge-pathnames* pathname root))
+ (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
+ (separator (last-char (namestring foo)))
+ (root-namestring (namestring root))
+ (root-string
+ (substitute-if #\/
+ (lambda (x) (or (eql x #\:)
+ (eql x separator)))
+ root-namestring)))
+ (multiple-value-bind (relative path filename)
+ (component-name-to-pathname-components root-string t)
+ (declare (ignore relative filename))
+ (let ((new-base
+ (make-pathname :defaults root
+ :directory `(:absolute , at path))))
+ (translate-pathname absolute-pathname wild-root (wilden new-base))))))
+
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
@@ -775,6 +828,15 @@
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmu (:report print-object))
+(declaim (ftype (function (t) t)
+ format-arguments format-control
+ error-name error-pathname error-condition
+ duplicate-names-name
+ error-component error-operation
+ module-components module-components-by-name)
+ (ftype (function (t t) t) (setf module-components-by-name)))
+
+
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
@@ -894,8 +956,8 @@
(defvar *default-component-class* 'cl-source-file)
(defun compute-module-components-by-name (module)
- (let ((hash (module-components-by-name module)))
- (clrhash hash)
+ (let ((hash (make-hash-table :test 'equal)))
+ (setf (module-components-by-name module) hash)
(loop :for c :in (module-components module)
:for name = (component-name c)
:for previous = (gethash name (module-components-by-name module))
@@ -911,7 +973,6 @@
:initarg :components
:accessor module-components)
(components-by-name
- :initform (make-hash-table :test 'equal)
:accessor module-components-by-name)
;; What to do if we can't satisfy a dependency of one of this module's
;; components. This allows a limited form of conditional processing.
@@ -939,7 +1000,7 @@
(let ((pathname
(merge-pathnames*
(component-relative-pathname component)
- (component-parent-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))
(setf (slot-value component 'absolute-pathname) pathname)
@@ -1013,9 +1074,9 @@
(gethash (coerce-name name) *defined-systems*))
(defun map-systems (fn)
- "Apply `fn` to each defined system.
+ "Apply FN to each defined system.
-`fn` should be a function of one argument. It will be
+FN should be a function of one argument. It will be
called with an object of type asdf:system."
(maphash (lambda (_ datum)
(declare (ignore _))
@@ -1028,7 +1089,7 @@
;;; convention that functions in this list are prefixed SYSDEF-
(defparameter *system-definition-search-functions*
- '(sysdef-central-registry-search sysdef-source-registry-search))
+ '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
(defun system-definition-pathname (system)
(let ((system-name (coerce-name system)))
@@ -1054,6 +1115,27 @@
Going forward, we recommend new users should be using the source-registry.
")
+(defun probe-asd (name defaults)
+ (block nil
+ (when (directory-pathname-p defaults)
+ (let ((file
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name name
+ :type "asd")))
+ (when (probe-file file)
+ (return file)))
+ #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+ (let ((shortcut
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name (concatenate 'string name ".asd")
+ :type "lnk")))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target)))))))))
+
(defun sysdef-central-registry-search (system)
(let ((name (coerce-name system))
(to-remove nil)
@@ -1072,8 +1154,8 @@
(let* ((*print-circle* nil)
(message
(format nil
- "~@<While searching for system `~a`: `~a` evaluated ~
-to `~a` 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 ()
@@ -1122,37 +1204,50 @@
0)))
(defun find-system (name &optional (error-p t))
- (let* ((name (coerce-name name))
- (in-memory (system-registered-p name))
- (on-disk (system-definition-pathname name)))
- (when (and on-disk
- (or (not in-memory)
- (< (car in-memory) (safe-file-write-date on-disk))))
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error (lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname on-disk
- :condition condition))))
- (let ((*package* package))
- (asdf-message
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- on-disk *package*)
- (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))))))
+ (catch 'find-system
+ (let* ((name (coerce-name name))
+ (in-memory (system-registered-p name))
+ (on-disk (system-definition-pathname name)))
+ (when (and on-disk
+ (or (not in-memory)
+ (< (car in-memory) (safe-file-write-date on-disk))))
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (handler-bind
+ ((error (lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname on-disk
+ :condition condition))))
+ (let ((*package* package))
+ (asdf-message
+ "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ on-disk *package*)
+ (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)))))))
(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)))))
+
;;;; -------------------------------------------------------------------------
;;;; Finding components
@@ -1171,8 +1266,9 @@
(find-component (car base) (cons (cdr base) path)))
(defmethod find-component ((module module) (name string))
- (when (slot-boundp module 'components-by-name)
- (values (gethash name (module-components-by-name module)))))
+ (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
+ (compute-module-components-by-name module))
+ (values (gethash name (module-components-by-name module))))
(defmethod find-component ((component component) (name symbol))
(if name
@@ -1602,19 +1698,6 @@
(visit-component operation c flag)
flag))
-(defmethod traverse ((operation operation) (c component))
- ;; cerror'ing a feature that seems to have NEVER EVER worked
- ;; ever since danb created it in his 2003-03-16 commit e0d02781.
- ;; It was both fixed and disabled in the 1.700 rewrite.
- (when (consp (operation-forced operation))
- (cerror "Continue nonetheless."
- "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
- (setf (operation-forced operation)
- (mapcar #'coerce-name (operation-forced operation))))
- (flatten-tree
- (while-collecting (collect)
- (do-traverse operation c #'collect))))
-
(defun flatten-tree (l)
;; You collected things into a list.
;; Most elements are just things to collect again.
@@ -1631,6 +1714,19 @@
(dolist (x l) (r x))))
(r* l))))
+(defmethod traverse ((operation operation) (c component))
+ ;; cerror'ing a feature that seems to have NEVER EVER worked
+ ;; ever since danb created it in his 2003-03-16 commit e0d02781.
+ ;; It was both fixed and disabled in the 1.700 rewrite.
+ (when (consp (operation-forced operation))
+ (cerror "Continue nonetheless."
+ "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
+ (setf (operation-forced operation)
+ (mapcar #'coerce-name (operation-forced operation))))
+ (flatten-tree
+ (while-collecting (collect)
+ (do-traverse operation c #'collect))))
+
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
"~@<required method PERFORM not implemented ~
@@ -1672,14 +1768,20 @@
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
+(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
+ (values t t t))
+ compile-file*))
+
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
#-:broken-fasl-loader
(let ((source-file (component-pathname c))
- (output-file (car (output-files operation c))))
+ (output-file (car (output-files operation c)))
+ (*compile-file-warnings-behaviour* (operation-on-warnings operation))
+ (*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
- (apply #'compile-file source-file :output-file output-file
+ (apply #'compile-file* source-file :output-file output-file
(compile-op-flags operation))
(when warnings-p
(case (operation-on-warnings operation)
@@ -1855,7 +1957,7 @@
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
-(defgeneric operate (operation-class system &key &allow-other-keys))
+(defgeneric* operate (operation-class system &key &allow-other-keys))
(defmethod operate (operation-class system &rest args
&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
@@ -1903,15 +2005,15 @@
(let ((operate-docstring
"Operate does three things:
-1. It creates an instance of `operation-class` using any keyword parameters
+1. It creates an instance of OPERATION-CLASS using any keyword parameters
as initargs.
-2. It finds the asdf-system specified by `system` (possibly loading
+2. It finds the asdf-system specified by SYSTEM (possibly loading
it from disk).
-3. It then calls `traverse` with the operation and system as arguments
+3. It then calls TRAVERSE with the operation and system as arguments
-The traverse operation is wrapped in `with-compilation-unit` and error
-handling code. If a `version` argument is supplied, then operate also
-ensures that the system found satisfies it using the `version-satisfies`
+The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
+handling code. If a VERSION argument is supplied, then operate also
+ensures that the system found satisfies it using the VERSION-SATISFIES
method.
Note that dependencies may cause the operation to invoke other
@@ -1949,26 +2051,23 @@
;;;; -------------------------------------------------------------------------
;;;; Defsystem
+(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)
- ;; called from the defsystem macro.
- ;; the pathname of a system is either
+ ;; The defsystem macro calls us to determine
+ ;; the pathname of a system as follows:
;; 1. the one supplied,
- ;; 2. derived from the *load-truename* (see below), or
- ;; 3. taken from *default-pathname-defaults*
- ;;
- ;; if using *load-truename*, then we also deal with whether or not
- ;; to resolve symbolic links. If not resolving symlinks, then we use
- ;; *load-pathname* instead of *load-truename* since in some
- ;; implementations, the latter has *already resolved it.
- (let ((file-pathname
- (when (or *load-pathname* *compile-file-pathname*)
- (pathname-directory-pathname
- (if *resolve-symlinks*
- (resolve-symlinks (or *load-truename* *compile-file-truename*))
- *load-pathname*)))))
- (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
+ ;; 2. derived from *load-pathname* via load-pathname
+ ;; 3. taken from the *default-pathname-defaults* via default-directory
+ (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
- (current-directory))))
+ (default-directory))))
(defmacro defsystem (name &body options)
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
@@ -1989,7 +2088,7 @@
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
- (%set-system-source-file *load-truename*
+ (%set-system-source-file (load-pathname)
(cdr (system-registered-p ',name))))
(parse-component-form
nil (list*
@@ -1998,24 +2097,18 @@
,(determine-system-pathname pathname pathname-arg-p)
',component-options))))))
-
(defun class-for-type (parent type)
- (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type)
- (load-time-value
- (package-name :asdf)))))
- (class (dolist (symbol (if (keywordp type)
- extra-symbols
- (cons type extra-symbols)))
- (when (and symbol
- (find-class symbol nil)
- (subtypep symbol 'component))
- (return (find-class symbol))))))
- (or class
- (and (eq type :file)
- (or (module-default-component-class parent)
- (find-class 'cl-source-file)))
- (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
+ (or (loop :for symbol :in (list
+ (unless (keywordp type) type)
+ (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type) :asdf))
+ :for class = (and symbol (find-class symbol nil))
+ :when (and class (subtypep class 'component))
+ :return class)
+ (and (eq type :file)
+ (or (module-default-component-class parent)
+ (find-class *default-component-class*)))
+ (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
(defun maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
@@ -2178,9 +2271,9 @@
;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
(defun run-shell-command (control-string &rest args)
- "Interpolate `args` into `control-string` as if by `format`, and
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
-output to `*verbose-out*`. Returns the shell's exit code."
+output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
@@ -2333,7 +2426,7 @@
(when (member :lispworks-64bit *features*) "-64bit"))
;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+(or mcl sbcl scl) s
+ #+(or cormanlisp mcl sbcl scl) s
#-(or allegro armedbear clisp clozure cmu cormanlisp digitool
ecl gcl lispworks mcl sbcl scl) s))
@@ -2453,10 +2546,15 @@
(error "One and only one form allowed for ~A. Got: ~S~%" description forms))
(funcall validator (car forms))))
+(defun hidden-file-p (pathname)
+ (equal (first-char (pathname-name pathname)) #\.))
+
(defun validate-configuration-directory (directory tag validator)
(let ((files (sort (ignore-errors
- (directory (make-pathname :name :wild :type :wild :defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil))
+ (remove-if
+ 'hidden-file-p
+ (directory (make-pathname :name :wild :type "conf" :defaults directory)
+ #+sbcl :resolve-symlinks #+sbcl nil)))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
@@ -2513,16 +2611,38 @@
(setf *output-translations* '())
(values))
-(defparameter *wild-path*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type :wild :version :wild))
-
(defparameter *wild-asd*
(make-pathname :directory '(:relative :wild-inferiors)
:name :wild :type "asd" :version :newest))
-(defun wilden (path)
- (merge-pathnames* *wild-path* path))
+
+(declaim (ftype (function (t &optional boolean) (or null pathname))
+ resolve-location))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string x)
+ (cons
+ (let ((car (resolve-relative-location-component super (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x) wildenp)))
+ (merge-pathnames* cdr car)))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :implementation) (implementation-identifier))
+ ((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)))
+ (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)
(let* ((r
@@ -2544,7 +2664,7 @@
((eql :home) (user-homedir))
((eql :user-cache) (resolve-location *user-cache* nil))
((eql :system-cache) (resolve-location *system-cache* nil))
- ((eql :current-directory) (current-directory))))
+ ((eql :default-directory) (default-directory))))
(s (if (and wildenp (not (pathnamep x)))
(wilden r)
r)))
@@ -2552,30 +2672,6 @@
(error "Not an absolute pathname ~S" s))
s))
-(defun resolve-relative-location-component (super x &optional wildenp)
- (let* ((r (etypecase x
- (pathname x)
- (string x)
- (cons
- (let ((car (resolve-relative-location-component super (car x) nil)))
- (if (null (cdr x))
- car
- (let ((cdr (resolve-relative-location-component
- (merge-pathnames* car super) (cdr x) wildenp)))
- (merge-pathnames* cdr car)))))
- ((eql :current-directory)
- (relativize-pathname-directory (current-directory)))
- ((eql :implementation) (implementation-identifier))
- ((eql :implementation-type) (string-downcase (implementation-type)))
- ((eql :uid) (princ-to-string (get-uid)))))
- (d (if (pathnamep x) r (ensure-directory-pathname r)))
- (s (if (and wildenp (not (pathnamep x)))
- (wilden d)
- d)))
- (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
- (error "pathname ~S is not relative to ~S" s super))
- (merge-pathnames* s super)))
-
(defun resolve-location (x &optional wildenp)
(if (atom x)
(resolve-absolute-location-component x wildenp)
@@ -2681,8 +2777,8 @@
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
#+sbcl (,(getenv "SBCL_HOME") ())
- #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
- #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
+ #+clozure (,(wilden (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:
@@ -2706,6 +2802,11 @@
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
(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)
+ process-output-translations-directive))
+
(defmethod process-output-translations ((x symbol) &key
(inherit *default-output-translations*)
collect)
@@ -2833,29 +2934,6 @@
(translate-pathname p absolute-source destination)))
:finally (return p)))))
-(defun last-char (s)
- (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-(defun directorize-pathname-host-device (pathname)
- (let* ((root (pathname-root pathname))
- (wild-root (wilden root))
- (absolute-pathname (merge-pathnames* pathname root))
- (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
- (separator (last-char (namestring foo)))
- (root-namestring (namestring root))
- (root-string
- (substitute-if #\/
- (lambda (x) (or (eql x #\:)
- (eql x separator)))
- root-namestring)))
- (multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string t)
- (declare (ignore relative filename))
- (let ((new-base
- (make-pathname :defaults root
- :directory `(:absolute , at path))))
- (translate-pathname absolute-pathname wild-root (wilden new-base))))))
-
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
(declare (ignorable operation component))
@@ -2866,11 +2944,45 @@
(mapcar #'apply-output-translations files)))
t))
-(defun compile-file-pathname* (input-file &rest keys)
- (apply-output-translations
- (apply #'compile-file-pathname
- (truenamize (lispize-pathname input-file))
- keys)))
+(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)
+ (make-pathname
+ :name (format nil "ASDF-TMP-~A" (pathname-name x))
+ :defaults x))
+
+(defun delete-file-if-exists (x)
+ (when (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))
+ (tmp-file (tmpize-pathname output-file))
+ (status :error))
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (apply 'compile-file input-file :output-file tmp-file keys)
+ (cond
+ (failure-p
+ (setf status *compile-file-failure-behaviour*))
+ (warnings-p
+ (setf status *compile-file-warnings-behaviour*))
+ (t
+ (setf status :success)))
+ (ecase status
+ ((:success :warn :ignore)
+ (delete-file-if-exists output-file)
+ (when output-truename
+ (rename-file output-truename output-file)
+ (setf output-truename output-file)))
+ (:error
+ (delete-file-if-exists output-truename)
+ (setf output-truename nil)))
+ (values output-truename warnings-p failure-p))))
#+abcl
(defun translate-jar-pathname (source wildcard)
@@ -2998,11 +3110,13 @@
;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
;; Using ack 1.2 exclusions
-(defvar *default-exclusions*
+(defvar *default-source-registry-exclusions*
'(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"))
+(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+
(defvar *source-registry* ()
"Either NIL (for uninitialized), or a list of one element,
said element itself being a list of directory pathnames where to look for .asd files")
@@ -3024,34 +3138,6 @@
(setf *source-registry* '())
(values))
-(defun probe-asd (name defaults)
- (block nil
- (when (directory-pathname-p defaults)
- (let ((file
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name name
- :type "asd")))
- (when (probe-file file)
- (return file)))
- #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
- (let ((shortcut
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name (concatenate 'string name ".asd")
- :type "lnk")))
- (when (probe-file shortcut)
- (let ((target (parse-windows-shortcut shortcut)))
- (when target
- (return (pathname target)))))))))
-
-(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 validate-source-registry-directive (directive)
(unless
(or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3060,7 +3146,7 @@
((:include :directory :tree)
(and (length=n-p rest 1)
(typep (car rest) '(or pathname string null))))
- ((:exclude)
+ ((:exclude :also-exclude)
(every #'stringp rest))
(null rest))))
(error "Invalid directive ~S~%" directive))
@@ -3146,7 +3232,8 @@
(defun wrapping-source-registry ()
`(:source-registry
#+sbcl (:tree ,(getenv "SBCL_HOME"))
- :inherit-configuration))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")))
(defun default-source-registry ()
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(:source-registry
@@ -3185,6 +3272,11 @@
(getenv "CL_SOURCE_REGISTRY"))
(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)
+ process-source-registry-directive))
+
(defmethod process-source-registry ((x symbol) &key inherit register)
(process-source-registry (funcall x) :inherit inherit :register register))
(defmethod process-source-registry ((pathname pathname) &key inherit register)
@@ -3204,7 +3296,7 @@
(declare (ignorable x))
(inherit-source-registry inherit :register register))
(defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*default-exclusions* *default-exclusions*))
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
(dolist (directive (cdr (validate-source-registry-form form)))
(process-source-registry-directive directive :inherit inherit :register register))))
@@ -3225,15 +3317,18 @@
((:tree)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
+ (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
((:exclude)
- (setf *default-exclusions* rest))
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
((:default-registry)
(inherit-source-registry '(default-source-registry) :register register))
((:inherit-configuration)
(inherit-source-registry inherit :register register))
((:ignore-inherited-configuration)
- nil))))
+ nil)))
+ nil)
(defun flatten-source-registry (&optional parameter)
(remove-duplicates
@@ -3268,6 +3363,13 @@
(source-registry)
(initialize-source-registry)))
+(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))
+
;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
;;;;
@@ -3278,16 +3380,16 @@
((style-warning #'muffle-warning)
(missing-component (constantly nil))
(error (lambda (e)
- (format *error-output* "ASDF could not load ~A because ~A.~%"
+ (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
name e))))
(let* ((*verbose-out* (make-broadcast-stream))
- (system (find-system name nil)))
+ (system (find-system (string-downcase name) nil)))
(when system
- (load-system name)
+ (load-system system)
t))))
(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
- #+clozure ccl::*module-provider-functions*
+ #+clozure ccl:*module-provider-functions*
#+cmu ext:*module-provider-functions*
#+ecl si:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))
@@ -3312,7 +3414,7 @@
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
- (asdf-message ";; ASDF, version ~a" (asdf-version)))
+ (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
#+allegro
(eval-when (:compile-toplevel :execute)
@@ -3320,7 +3422,6 @@
(setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
(pushnew :asdf *features*)
-;; this is a release candidate for ASDF 2.0
(pushnew :asdf2 *features*)
(provide :asdf)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp Fri Jul 9 17:01:30 2010
@@ -92,15 +92,21 @@
(fmakunbound 'jmake-proxy))
(defgeneric jmake-proxy (interface implementation &optional lisp-this)
- (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters."))
+ (:documentation "Returns a proxy Java object implementing the provided interface(s) using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters."))
+
+(defun canonicalize-jproxy-interfaces (ifaces)
+ (if (listp ifaces)
+ (mapcar #'jclass ifaces)
+ (list (jclass ifaces))))
+
(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
"Basic implementation that directly uses an invocation handler."
- (%jmake-proxy (jclass interface) invocation-handler lisp-this))
+ (%jmake-proxy (canonicalize-jproxy-interfaces interface) invocation-handler lisp-this))
(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
"Implements a Java interface forwarding method calls to a Lisp function."
- (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
+ (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler implementation) lisp-this))
(defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
"Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function."
@@ -114,7 +120,7 @@
(setf last-lower-p (not upper-p))
(princ (char-upcase char) str)))
name)))))
- (%jmake-proxy (jclass interface)
+ (%jmake-proxy (canonicalize-jproxy-interfaces interface)
(jmake-invocation-handler
(lambda (obj method &rest args)
(let ((sym (find-symbol
@@ -133,7 +139,7 @@
(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
"Implements a Java interface using closures in an hash-table keyed by Java method name."
- (%jmake-proxy (jclass interface)
+ (%jmake-proxy (canonicalize-jproxy-interfaces interface)
(jmake-invocation-handler
(lambda (obj method &rest args)
(let ((fn (gethash method implementation)))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Fri Jul 9 17:01:30 2010
@@ -788,7 +788,9 @@
(let ((*precompile-env* (make-environment *precompile-env*))
(operator (car form))
(locals (cadr form))
- (body (cddr form)))
+ ;; precompile (thus macro-expand) the body before inspecting it
+ ;; for the use of our locals and optimizing them away
+ (body (mapcar #'precompile1 (cddr form))))
(dolist (local locals)
(let* ((name (car local))
(used-p (find-use name body)))
@@ -820,7 +822,7 @@
(return-from precompile-flet/labels (precompile1 new-form))))))
(list* (car form)
(precompile-local-functions locals)
- (mapcar #'precompile1 body))))
+ body)))
(defun precompile-function (form)
(if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
More information about the armedbear-cvs
mailing list