Changeset 12796


Ignore:
Timestamp:
07/09/10 21:01:30 (11 years ago)
Author:
ehuelsmann
Message:

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.

Location:
branches/generic-class-file/abcl
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/doc/asdf/asdf.texinfo

    r12655 r12796  
    171171
    172172@emph{Nota Bene}:
    173 We are preparing for a release of ASDF 2, hopefully for May 2010,
    174 which will have version 2.000 and later.
    175 Current releases, in the 1.700 series and beyond,
    176 should be considered as release candidates.
    177 We're still working on polishing the code and documentation.
     173We have released ASDF 2.000 on May 31st 2010.
     174It hopefully will have been it included
     175in all CL maintained implementations shortly afterwards.
    178176@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
    179177
     
    242240If it returns @code{NIL} then ASDF is not installed.
    243241
    244 If you are running a version older than 1.711,
     242If you are running a version older than 2.000,
    245243we recommend that you load a newer ASDF using the method below.
    246244
     
    341339
    342340The simplest way to add a path to your search path,
    343 say @file{/foo/bar/baz/quux/}
     341say @file{/home/luser/.asd-link-farm/}
    344342is to create the directory
    345343@file{~/.config/common-lisp/source-registry.conf.d/}
    346 and there create a file with any name of your choice,
    347 for instance @file{42-bazquux.conf}
     344and there create a file with any name of your choice but the type @file{conf},
     345for instance @file{42-asd-link-farm.conf}
    348346containing the line:
    349347
    350 @kbd{(:directory "/foo/bar/baz/quux/")}
    351 
    352 If you want all the subdirectories under @file{/foo/bar/baz/}
     348@kbd{(:directory "/home/luser/.asd-link-farm/")}
     349
     350If you want all the subdirectories under @file{/home/luser/lisp/}
    353351to be recursively scanned for @file{.asd} files, instead use:
    354352
    355 @kbd{(:tree "/foo/bar/baz/quux/")}
     353@kbd{(:tree "/home/luser/lisp/")}
    356354
    357355Note that your Operating System distribution or your system administrator
    358356may already have configured system-managed libraries for you.
    359357
    360 Also note that when choosing a filename, the convention is to use
    361 the @file{.conf} extension
    362 (and a non-empty extension is required for CLISP compatibility),
    363 and it is customary to start the filename with two digits
     358The required @file{.conf} extension allows you to have disabled files
     359or editor backups (ending in @file{~}), and works portably
     360(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
     361Excluded are files the name of which start with a @file{.} character.
     362It is customary to start the filename with two digits
    364363that specify the order in which the directories will be scanned.
    365364
     
    486485is to create the directory
    487486@file{~/.config/common-lisp/asdf-output-translations.conf.d/}
    488 and there create a file with any name of your choice,
     487and there create a file with any name of your choice and the type @file{conf},
    489488for instance @file{42-bazquux.conf}
    490489containing the line:
     
    511510@xref{Controlling where ASDF searches for systems}, for full details.
    512511
    513 
    514 Also note that when choosing a filename, the convention is to use
    515 the @file{.conf} extension
    516 (and a non-empty extension is required for CLISP compatibility),
    517 and it is customary to start the filename with two digits
     512The required @file{.conf} extension allows you to have disabled files
     513or editor backups (ending in @file{~}), and works portably
     514(for instance, it is a pain to allow both empty and non-empty extension on CLISP).
     515Excluded are files the name of which start with a @file{.} character.
     516It is customary to start the filename with two digits
    518517that specify the order in which the directories will be scanned.
    519518
     
    536535ASDF-Binary-Locations, cl-launch, common-lisp-controller.
    537536ASDF-Binary-Locations is now not needed anymore and should not be used.
    538 cl-launch 2.900 and common-lisp-controller 7.1 have been updated
     537cl-launch 3.000 and common-lisp-controller 7.2 have been updated
    539538to just delegate this functionality to ASDF.
    540539
     
    814813
    815814@subsection Pathname specifiers
     815@cindex pathname specifiers
    816816
    817817A pathname specifier (@code{pathname-specifier})
     
    846846will be interpreted as the pathname @file{#p"foo/bar.quux"}.
    847847
     848ASDF does not interpret the string @code{".."} to designate the parent
     849directory.  This string will be passed through to the underlying
     850operating system for interpretation.  We @emph{believe} that this will
     851work on all platforms where ASDF is deployed, but do not guarantee this
     852behavior.  A pathname object with a relative directory component of
     853@code{:up} or @code{:back} is the only guaranteed way to specify a
     854parent directory.
     855
    848856If a symbol is given, it will be translated into a string,
    849857and downcased in the process.
     
    857865which is reported not to work on some implementations.
    858866
    859 Pathnames objects may be given to override the path for a component.
     867Pathname objects may be given to override the path for a component.
    860868Such objects are typically specified using reader macros such as @code{#p}
    861869or @code{#.(make-pathname ...)}.
    862 Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)}
    863 and that the behavior @code{parse-namestring} is completely non-portable,
    864 unless you are using Common Lisp @code{logical-pathname}s.
    865 (@xref{The defsystem grammar,,Warning about logical pathnames}, below.)
     870Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)}
     871and that the behavior of @code{parse-namestring} is completely non-portable,
     872unless you are using Common Lisp @code{logical-pathname}s
     873(@pxref{The defsystem grammar,,Warning about logical pathnames}, below).
    866874Pathnames made with @code{#.(make-pathname ...)}
    867875can usually be done more easily with the string syntax above.
    868876The only case that you really need a pathname object is to override
    869877the component-type default file type for a given component.
    870 Therefore, it is a rare case that pathname objects should be used at all.
     878Therefore, pathname objects should only rarely be used.
    871879Unhappily, ASDF 1 didn't properly support
    872880parsing component names as strings specifying paths with directories,
    873881and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
    874 Note that when specifying pathname objects, no magic interpretation of the pathname
    875 is made depending on the component type.
     882
     883Note that when specifying pathname objects,
     884ASDF does not do any special interpretation of the pathname
     885influenced by the component type, unlike the procedure for
     886pathname-specifying strings.
    876887On the one hand, you have to be careful to provide a pathname that correctly
    877888fulfills whatever constraints are required from that component type
     
    882893
    883894@subsection Warning about logical pathnames
     895@cindex logical pathnames
     896
     897We recommend that you not use logical pathnames
     898in your asdf system definitions at this point,
     899but logical pathnames @emph{are} supported.
    884900
    885901To use logical pathnames,
     
    889905
    890906You only have to specify such logical pathname for your system or
    891 some top-level component, as sub-components using the usual string syntax
    892 for names will be properly merged with the pathname of their parent.
     907some top-level component.  Sub-components' relative pathnames, specified
     908using the string syntax
     909for names, will be properly merged with the pathnames of their parents.
    893910The specification of a logical pathname host however is @emph{not}
    894911otherwise directly supported in the ASDF syntax
    895912for pathname specifiers as strings.
    896913
    897 Logical pathnames are not specifically recommended to newcomers,
    898 but are otherwise supported.
    899 Moreover, the @code{asdf-output-translation} layer will
    900 avoid trying to resolve and translate logical-pathnames,
    901 so you can define yourself what translations you want to use
     914The @code{asdf-output-translation} layer will
     915avoid trying to resolve and translate logical-pathnames.
     916The advantage of this is that you can define yourself what translations you want to use
    902917with the logical pathname facility.
    903 
    904 The user of logical pathnames will have to configure logical pathnames himself,
    905 before they may be used, and ASDF provides no specific support for that.
     918The disadvantage is that if you do not define such translations, any
     919system that uses logical pathnames will be have differently under
     920asdf-output-translations than other systems you use.
     921
     922If you wish to use logical pathnames you will have to configure the
     923translations yourself before they may be used.
     924ASDF currently provides no specific support
     925for defining logical pathname translations.
    906926
    907927
    908928@subsection Serial dependencies
     929@cindex serial dependencies
    909930
    910931If the @code{:serial t} option is specified for a module,
     
    914935
    915936@lisp
     937:serial t
    916938:components ((:file "a") (:file "b") (:file "c"))
    917 :serial t
    918939@end lisp
    919940
     
    17141735;; A directive is one of the following:
    17151736DIRECTIVE :=
     1737    ;; INHERITANCE DIRECTIVE:
     1738    ;; Your configuration expression MUST contain
     1739    ;; exactly one of either of these:
     1740    :inherit-configuration | ; splices inherited configuration (often specified last)
     1741    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
     1742
    17161743    ;; add a single directory to be scanned (no recursion)
    17171744    (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
     
    17201747    (:tree DIRECTORY-PATHNAME-DESIGNATOR) |
    17211748
    1722     ;; override the default defaults for exclusion patterns
     1749    ;; override the defaults for exclusion patterns
    17231750    (:exclude PATTERN ...) |
     1751    ;; augment the defaults for exclusion patterns
     1752    (:also-exclude PATTERN ...) |
    17241753
    17251754    ;; splice the parsed contents of another config file
    17261755    (:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
    1727 
    1728     ;; Your configuration expression MUST contain
    1729     ;; exactly one of either of these:
    1730     :inherit-configuration | ; splices contents of inherited configuration
    1731     :ignore-inherited-configuration | ; drop contents of inherited configuration
    17321756
    17331757    ;; This directive specifies that some default must be spliced.
     
    17371761  against the name of a any subdirectory in the directory component
    17381762        of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
     1763@end example
     1764
     1765For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
     1766which is the default place ASDF looks for this configuration,
     1767once contained:
     1768@example
     1769(:source-registry
     1770  (:tree "/home/fare/cl/")
     1771  :inherit-configuration)
    17391772@end example
    17401773
     
    17471780the lists of directives of these files with be concatenated in order.
    17481781An implicit @code{:inherit-configuration} will be included
    1749 at the end of the list.
     1782at the @emph{end} of the list.
    17501783
    17511784This allows for packaging software that has file granularity
     
    17651798@example
    17661799  (:include "/foo/bar/")
     1800@end example
     1801
     1802Hence, to achieve the same effect as
     1803my example @file{~/.config/common-lisp/source-registry.conf} above,
     1804I could simply create a file
     1805@file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf}
     1806alone in its directory with the following contents:
     1807@example
     1808(:tree "/home/fare/cl/")
    17671809@end example
    17681810
     
    18091851If none is found, the search continues.
    18101852
    1811 Exclude statements specify patterns of subdirectories the systems of which
    1812 to ignore. Typically you don't want to use copies of files kept by such
     1853Exclude statements specify patterns of subdirectories
     1854the systems from which to ignore.
     1855Typically you don't want to use copies of files kept by such
    18131856version control systems as Darcs.
     1857Exclude statements are not propagated to further included or inherited
     1858configuration files or expressions;
     1859instead the defaults are reset around every configuration statement
     1860to the default defaults from @code{asdf::*default-source-registry-exclusions*}.
    18141861
    18151862Include statements cause the search to recurse with the path specifications
     
    20582105Recent versions of same packages use
    20592106the new @code{asdf-output-translations} API as defined below:
    2060 @code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00);
     2107@code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000).
    20612108@code{ASDF-Binary-Locations} is fully superseded and not to be used anymore.
    20622109
     
    21112158;; A directive is one of the following:
    21122159DIRECTIVE :=
     2160    ;; INHERITANCE DIRECTIVE:
     2161    ;; Your configuration expression MUST contain
     2162    ;; exactly one of either of these:
     2163    :inherit-configuration | ; splices inherited configuration (often specified last)
     2164    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
     2165
    21132166    ;; include a configuration file or directory
    21142167    (:include PATHNAME-DESIGNATOR) |
    2115 
    2116     ;; Your configuration expression MUST contain
    2117     ;; exactly one of either of these:
    2118     :inherit-configuration | ; splices contents of inherited configuration
    2119     :ignore-inherited-configuration | ; drop contents of inherited configuration
    21202168
    21212169    ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
     
    22332281the lists of directives of these files with be concatenated in order.
    22342282An implicit @code{:inherit-configuration} will be included
    2235 at the end of the list.
     2283at the @emph{end} of the list.
    22362284
    22372285This allows for packaging software that has file granularity
     
    24952543@subsection What are ASDF 1 and ASDF 2?
    24962544
    2497 We are preparing for a release of ASDF 2,
    2498 which will have version 2.000 and later.
    2499 While the code and documentation are essentially complete
    2500 we are still working on polishing them before release.
    2501 
    2502 Releases in the 1.700 series and beyond
    2503 should be considered as release candidates.
    2504 For all practical purposes,
    2505 ASDF 2 refers to releases later than 1.656,
    2506 and ASDF 1 to any release earlier than 1.369 or so.
    2507 If your ASDF doesn't have a version, it's old.
    2508 
    2509 ASDF 2 release candidates and beyond will have
     2545On May 31st 2010, we have released ASDF 2.
     2546ASDF 2 refers to release 2.000 and later.
     2547(Releases between 1.656 and 1.728 were development releases for ASDF 2.)
     2548ASDF 1 to any release earlier than 1.369 or so.
     2549If your ASDF doesn't sport a version, it's an old ASDF 1.
     2550
     2551ASDF 2 and its release candidates push
    25102552@code{:asdf2} onto @code{*features*} so that if you are writing
    25112553ASDF-dependent code you may check for this feature
     
    25142556
    25152557If you are experiencing problems or limitations of any sort with ASDF 1,
    2516 we recommend that you should upgrade to ASDF 2 or its latest release candidate.
     2558we recommend that you should upgrade to ASDF 2,
     2559or whatever is the latest release.
    25172560
    25182561
     
    25382581@code{asdf::merge-component-name-type}.
    25392582
     2583On the other hand, there are places where systems used to accept namestrings
     2584where you must now use an explicit pathname object:
     2585@code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
     2586must now be written with the @code{#p} syntax:
     2587@code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
     2588
    25402589@xref{The defsystem grammar,,Pathname specifiers}.
    25412590
     
    26362685The internal test suite used to massively fail on many implementations.
    26372686While still incomplete, it now fully passes
    2638 on all implementations supported by the test suite.
     2687on all implementations supported by the test suite,
     2688except for GCL (due to GCL bugs).
    26392689
    26402690@item
    26412691Support was lacking for some implementations.
    2642 ABCL was notably wholly broken.
     2692ABCL and GCL were notably wholly broken.
    26432693ECL extensions were not integrated in the ASDF release.
    26442694
     
    26612711that everyone can rely on from now on.
    26622712Use @code{#+asdf2} to detect presence of ASDF 2,
    2663 @code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
     2713@code{(asdf:version-satisfies (asdf:asdf-version) "2.000")}
    26642714to check the availability of a version no earlier than required.
    26652715
     
    27332783@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
    27342784But thou shall not load ABL on top of ASDF 2.
     2785
     2786@item
     2787ASDF pathname designators are now specified in places where they were unspecified,
     2788and a few small adjustments have to be made to some non-portable defsystems.
     2789Notably, in the @code{:pathname} argument to a @code{defsystem} and its components,
     2790a logical pathname (or implementation-dependent hierarchical pathname)
     2791must now be specified with @code{#p} syntax
     2792where the namestring might have previously sufficed;
     2793moreover when evaluation is desired @code{#.} must be used,
     2794where it wasn't necessary in the toplevel @code{:pathname} argument.
    27352795
    27362796@end itemize
     
    30903150@section Missing bits in implementation
    30913151
    3092 ** all of the above
    3093 
    30943152** reuse the same scratch package whenever a system is reloaded from disk
    3095 
    3096 ** rules for system pathname defaulting are not yet implemented properly
    30973153
    30983154** proclamations probably aren't
     
    31033159like take the list of kids and @code{setf} the slot to @code{nil},
    31043160then transfer children from old to new list as they're found.
    3105 
    3106 **  traverse may become a normal function
    3107 
    3108 If you're defining methods on @code{traverse}, speak up.
    3109 
    3110 
    3111 ** a lot of load-op methods can be rewritten to use input-files
    3112 
    3113 so should be.
    3114 
    31153161
    31163162** (stuff that might happen later)
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java

    r12749 r12796  
    515515        autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass");
    516516        autoload(PACKAGE_JAVA, "get-default-classloader", "JavaClassLoader");
     517        autoload(PACKAGE_JAVA, "make-classloader", "JavaClassLoader");
     518        autoload(PACKAGE_JAVA, "add-to-classpath", "JavaClassLoader");
     519        autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader");
    517520        autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
    518521        autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java

    r12749 r12796  
    4141    private int callCount;
    4242    private int hotCount;
    43 
    44     protected Function() {}
     43    /**
     44     * The value of *load-truename* which was current when this function
     45     * was loaded, used for fetching the class bytes in case of disassebly.
     46     */
     47    private final LispObject loadedFrom;
     48
     49    protected Function() {
     50  LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow();
     51  loadedFrom = loadTruename != null ? loadTruename : NIL;
     52    }
    4553
    4654    public Function(String name)
    4755    {
     56  this();
    4857        if (name != null) {
    4958            Symbol symbol = Symbol.addFunction(name.toUpperCase(), this);
     
    5665    public Function(Symbol symbol, String arglist)
    5766    {
     67  this();
    5868        symbol.setSymbolFunction(this);
    5969        if (cold)
     
    6575    public Function(Symbol symbol, String arglist, String docstring)
    6676    {
     77  this();
    6778        symbol.setSymbolFunction(this);
    6879        if (cold)
     
    101112                    String arglist, String docstring)
    102113    {
     114  this();
    103115        if (arglist instanceof String)
    104116            setLambdaList(new SimpleString(arglist));
     
    121133    public Function(LispObject name)
    122134    {
     135  this();
    123136        setLambdaName(name);
    124137    }
     
    126139    public Function(LispObject name, LispObject lambdaList)
    127140    {
     141  this();
    128142        setLambdaName(name);
    129143        setLambdaList(lambdaList);
     
    183197      ClassLoader c = getClass().getClassLoader();
    184198      if(c instanceof FaslClassLoader) {
    185     return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
     199    final LispThread thread = LispThread.currentThread();
     200    SpecialBindingsMark mark = thread.markSpecialBindings();
     201    try {
     202        thread.bindSpecial(Symbol.LOAD_TRUENAME, loadedFrom);
     203        return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
     204    } catch(Throwable t) {
     205        //This is because unfortunately getFunctionClassBytes uses
     206        //Debug.assertTrue(false) to signal errors
     207        if(t instanceof ControlTransfer) {
     208      throw (ControlTransfer) t;
     209        } else {
     210      return NIL;
     211        }
     212    } finally {
     213        thread.resetSpecialBindings(mark);
     214    }   
    186215      } else {
    187216    return NIL;
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java

    r12513 r12796  
    211211    private static final Primitive _JMAKE_PROXY =
    212212      new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
    213                     "interface invocation-handler") {
     213                    "interfaces invocation-handler") {
    214214   
    215215          public LispObject execute(final LispObject[] args) {
     
    218218              return error(new WrongNumberOfArgumentsException(this));
    219219            }
    220             if(!(args[0] instanceof JavaObject) ||
    221                !(((JavaObject) args[0]).javaInstance() instanceof Class)) {
    222               return error(new TypeError(args[0], new SimpleString(Class.class.getName())));
    223             }
    224             if(!(args[1] instanceof JavaObject) ||
    225                !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) {
    226               return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName())));
    227             }
    228             Class<?> iface = (Class<?>) ((JavaObject) args[0]).javaInstance();
    229             InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance();
     220            if(!(args[0] instanceof Cons)) {
     221          return error(new TypeError(args[0], new SimpleString("CONS")));
     222            }
     223      Class[] ifaces = new Class[args[0].length()];
     224      LispObject ifList = args[0];
     225      for(int i = 0; i < ifaces.length; i++) {
     226                          ifaces[i] = (Class) ifList.car().javaInstance(Class.class);
     227          ifList = ifList.cdr();
     228      }
     229            InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class);
    230230            Object proxy = Proxy.newProxyInstance(
    231                 iface.getClassLoader(),
    232                 new Class[] { iface },
     231                JavaClassLoader.getCurrentClassLoader(),
     232                ifaces,
    233233                invocationHandler);
    234234            synchronized(proxyMap) {
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java

    r12715 r12796  
    4040import java.util.Set;
    4141import java.net.URL;
    42 
    43 public class JavaClassLoader extends java.net.URLClassLoader {
     42import java.net.URLClassLoader;
     43
     44public class JavaClassLoader extends URLClassLoader {
    4445
    4546    private static JavaClassLoader persistentInstance;
     
    169170    };
    170171
     172    private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath();
     173    private static final class pf_dump_classpath extends Primitive
     174    {
     175        pf_dump_classpath()
     176        {
     177            super("dump-classpath", PACKAGE_JAVA, true, "&optional classloader");
     178        }
     179
     180        @Override
     181        public LispObject execute() {
     182      return execute(new JavaObject(getCurrentClassLoader()));
     183        }
     184
     185        @Override
     186        public LispObject execute(LispObject classloader) {
     187      LispObject list = NIL;
     188      Object o = classloader.javaInstance();
     189      while(o instanceof ClassLoader) {
     190    ClassLoader cl = (ClassLoader) o;
     191    list = list.push(dumpClassPath(cl));
     192    o = cl.getParent();
     193      }
     194      return list.nreverse();
     195        }
     196    };
     197
     198    private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath();
     199    private static final class pf_add_to_classpath extends Primitive
     200    {
     201        pf_add_to_classpath()
     202        {
     203            super("add-to-classpath", PACKAGE_JAVA, true, "jar-or-jars &optional (classloader (get-current-classloader))");
     204        }
     205
     206        @Override
     207        public LispObject execute(LispObject jarOrJars) {
     208      return execute(jarOrJars, new JavaObject(getCurrentClassLoader()));
     209        }
     210
     211        @Override
     212        public LispObject execute(LispObject jarOrJars, LispObject classloader) {
     213      Object o = classloader.javaInstance();
     214      if(o instanceof JavaClassLoader) {
     215    JavaClassLoader jcl = (JavaClassLoader) o;
     216    if(jarOrJars instanceof Cons) {
     217        while(jarOrJars != NIL) {
     218      addURL(jcl, jarOrJars.car());
     219      jarOrJars = jarOrJars.cdr();
     220        }
     221    } else {
     222        addURL(jcl, jarOrJars);
     223    }
     224    return T;
     225      } else {
     226    return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName()));
     227      }
     228        }
     229    };
     230
     231    protected static void addURL(JavaClassLoader jcl, LispObject jar) {
     232  try {
     233      if(jar instanceof Pathname) {
     234    jcl.addURL(((Pathname) jar).toURL());
     235      } else if(jar instanceof AbstractString) {
     236    jcl.addURL(new Pathname(jar.toString()).toURL());
     237      } else {
     238    error(new TypeError(jar + " must be a pathname designator"));
     239      }
     240  } catch(java.net.MalformedURLException e) {
     241      error(new LispError(jar + " is not a valid URL"));
     242  }
     243    }
     244
     245
     246    public static LispObject dumpClassPath(ClassLoader o) {
     247  if(o instanceof URLClassLoader) {
     248      LispObject list = NIL;
     249      for(URL u : ((URLClassLoader) o).getURLs()) {
     250    list = list.push(new Pathname(u));
     251      }
     252      return new Cons(new JavaObject(o), list.nreverse());
     253  } else {
     254      return new JavaObject(o);
     255  }
     256    }
     257
    171258    public static ClassLoader getCurrentClassLoader() {
    172259  LispObject classLoader = CLASSLOADER.symbolValueNoThrow();
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java

    r12696 r12796  
    607607        if (host != NIL) {
    608608            Debug.assertTrue(host instanceof AbstractString
    609                              || host instanceof Cons);
    610             if (host instanceof Cons) {
     609                             || isURL());
     610            if (isURL()) {
    611611                LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL);
    612612                LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL);
     
    632632        if (device == NIL) {
    633633        } else if (device == Keyword.UNSPECIFIC) {
    634         } else if (device instanceof Cons) {
     634        } else if (isJar()) {
    635635            LispObject[] jars = ((Cons) device).copyToArray();
    636636            StringBuilder prefix = new StringBuilder();
     
    644644            }
    645645            sb = prefix.append(sb);
    646         } else if (device instanceof AbstractString
    647           && device.getStringValue().startsWith("jar:")) {
    648             sb.append(device.getStringValue());
    649646        } else if (device instanceof AbstractString) {
    650647            sb.append(device.getStringValue());
     
    724721        }
    725722        namestring = sb.toString();
    726         // XXX Decide when this is necessary
     723        // XXX Decide if this is necessary
    727724        // if (isURL()) {
    728725        //     namestring = Utilities.uriEncode(namestring);
     
    12371234        } catch (IOException e) {
    12381235            Debug.trace("Failed to make a Pathname from "
    1239               + "." + file + "'");
     1236              + "'" + file + "'");
    12401237            return null;
    12411238        }
     
    12911288                host = defaults.host;
    12921289            }
    1293             if (directory == NIL && defaults != null) {
     1290            if (directory == NIL) {
    12941291                directory = defaults.directory;
    12951292            }
     
    20852082                result = new URL(pathname.getNamestring());
    20862083            } else {
    2087                 // XXX ensure that we have cannonical path.
     2084                // XXX Properly encode Windows drive letters and UNC paths
     2085                // XXX ensure that we have cannonical path?
    20882086                result = new URL("file://" + pathname.getNamestring());
    20892087            }
     
    23432341    }
    23442342
     2343    public URL toURL() throws MalformedURLException {
     2344  if(isURL()) {
     2345      return new URL(getNamestring());
     2346  } else {
     2347      return toFile().toURL();
     2348  }
     2349    }
     2350
     2351    public File toFile() {
     2352  if(!isURL()) {
     2353      return new File(getNamestring());
     2354  } else {
     2355      throw new RuntimeException(this + " does not represent a file");
     2356  }
     2357    }
     2358
    23452359    static {
    23462360        LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue();
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java

    r12749 r12796  
    524524        if (value == NIL) {
    525525            LispObject[] values = thread._values;
    526             if (values != null && values.length == 0)
     526            if (values != null && values.length == 0) {
    527527                value = null;
     528                thread._values = null; // reset 'no values' indicator
     529            }
    528530        }
    529531        return value;
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp

    r12666 r12796  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl-user)
    51 
    52 (declaim (optimize (speed 2) (debug 2) (safety 3))
    53          #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
    54 
    55 #+ecl (require :cmp)
    56 
    57 ;;;; Create packages in a way that is compatible with hot-upgrade.
    58 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    59 ;;;; See more at the end of the file.
    60 
    61 #+gcl
    62 (eval-when (:compile-toplevel :load-toplevel)
    63   (defpackage :asdf-utilities (:use :cl))
    64   (defpackage :asdf (:use :cl :asdf-utilities)))
    65 
    66 (eval-when (:load-toplevel :compile-toplevel :execute)
     50(cl:in-package :cl)
     51(defpackage :asdf-bootstrap (:use :cl))
     52(in-package :asdf-bootstrap)
     53
     54;; Implementation-dependent tweaks
     55(eval-when (:compile-toplevel :load-toplevel :execute)
     56  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
    6757  #+allegro
    6858  (setf excl::*autoload-package-name-alist*
    6959        (remove "asdf" excl::*autoload-package-name-alist*
    7060                :test 'equalp :key 'car))
    71   (let* ((asdf-version
    72           ;; the 1+ helps the version bumping script discriminate
    73           (subseq "VERSION:1.719" (1+ (length "VERSION"))))
     61  #+ecl (require :cmp)
     62  #+gcl
     63  (eval-when (:compile-toplevel :load-toplevel)
     64    (defpackage :asdf-utilities (:use :cl))
     65    (defpackage :asdf (:use :cl :asdf-utilities))))
     66
     67;;;; Create packages in a way that is compatible with hot-upgrade.
     68;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     69;;;; See more at the end of the file.
     70
     71(eval-when (:load-toplevel :compile-toplevel :execute)
     72  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
    7474         (existing-asdf (find-package :asdf))
    7575         (vername '#:*asdf-version*)
     
    8181      #-gcl
    8282      (when existing-asdf
    83         (format *error-output*
     83        (format *trace-output*
    8484                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8585                existing-version asdf-version))
     
    156156            ((pkgdcl (name &key nicknames use export
    157157                           redefined-functions unintern fmakunbound shadow)
    158                `(ensure-package
    159                  ',name :nicknames ',nicknames :use ',use :export ',export
    160                  :shadow ',shadow
    161                  :unintern ',(append #-(or gcl ecl) redefined-functions
    162                                      unintern)
    163                  :fmakunbound ',(append #+(or gcl ecl) redefined-functions
    164                                         fmakunbound))))
     158                 `(ensure-package
     159                   ',name :nicknames ',nicknames :use ',use :export ',export
     160                   :shadow ',shadow
     161                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
     162                   :fmakunbound ',(append fmakunbound))))
    165163          (pkgdcl
    166164           :asdf-utilities
     
    291289            #:ensure-output-translations
    292290            #:apply-output-translations
     291            #:compile-file*
    293292            #:compile-file-pathname*
    294293            #:enable-asdf-binary-locations-compatibility
     
    328327           ((m module) added deleted plist &key)
    329328         (declare (ignorable deleted plist))
     329         (format *trace-output* "Updating ~A~%" m)
    330330         (when (member 'components-by-name added)
    331331           (compute-module-components-by-name m))))))
     
    337337  "Exported interface to the version of ASDF currently installed. A string.
    338338You can compare this string with e.g.:
    339 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
     339(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
    340340  *asdf-version*)
    341341
     
    345345Defaults to `t`.")
    346346
    347 (defvar *compile-file-warnings-behaviour* :warn)
    348 
    349 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
     347(defvar *compile-file-warnings-behaviour* :warn
     348  "How should ASDF react if it encounters a warning when compiling a
     349file?  Valid values are :error, :warn, and :ignore.")
     350
     351(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
     352        "How should ASDF react if it encounters a failure \(per the
     353ANSI spec of COMPILE-FILE\) when compiling a file?  Valid values are
     354:error, :warn, and :ignore.  Note that ASDF ALWAYS raises an error
     355if it fails to create an output file when compiling.")
    350356
    351357(defvar *verbose-out* nil)
     
    366372;;;; -------------------------------------------------------------------------
    367373;;;; ASDF Interface, in terms of generic functions.
    368 
    369 (defgeneric perform-with-restarts (operation component))
    370 (defgeneric perform (operation component))
    371 (defgeneric operation-done-p (operation component))
    372 (defgeneric explain (operation component))
    373 (defgeneric output-files (operation component))
    374 (defgeneric input-files (operation component))
     374(defmacro defgeneric* (name formals &rest options)
     375  `(progn
     376     #+(or gcl ecl) (fmakunbound ',name)
     377     (defgeneric ,name ,formals ,@options)))
     378
     379(defgeneric* perform-with-restarts (operation component))
     380(defgeneric* perform (operation component))
     381(defgeneric* operation-done-p (operation component))
     382(defgeneric* explain (operation component))
     383(defgeneric* output-files (operation component))
     384(defgeneric* input-files (operation component))
    375385(defgeneric component-operation-time (operation component))
    376386
    377 (defgeneric system-source-file (system)
     387(defgeneric* system-source-file (system)
    378388  (:documentation "Return the source file in which system is defined."))
    379389
     
    397407(defgeneric version-satisfies (component version))
    398408
    399 (defgeneric find-component (base path)
     409(defgeneric* find-component (base path)
    400410  (:documentation "Finds the component with PATH starting from BASE module;
    401411if BASE is nil, then the component is assumed to be a system."))
     
    456466(defgeneric traverse (operation component)
    457467  (:documentation
    458 "Generate and return a plan for performing `operation` on `component`.
    459 
    460 The plan returned is a list of dotted-pairs. Each pair is the `cons`
    461 of ASDF operation object and a `component` object. The pairs will be
    462 processed in order by `operate`."))
     468"Generate and return a plan for performing OPERATION on COMPONENT.
     469
     470The plan returned is a list of dotted-pairs. Each pair is the CONS
     471of ASDF operation object and a COMPONENT object. The pairs will be
     472processed in order by OPERATE."))
    463473
    464474
     
    467477
    468478(defmacro while-collecting ((&rest collectors) &body body)
     479  "COLLECTORS should be a list of names for collections.  A collector
     480defines a function that, when applied to an argument inside BODY, will
     481add its argument to the corresponding collection.  Returns multiple values,
     482a list for each collection, in order.
     483   E.g.,
     484\(while-collecting \(foo bar\)
     485           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
     486             \(foo \(first x\)\)
     487             \(bar \(second x\)\)\)\)
     488Returns two values: \(A B C\) and \(1 2 3\)."
    469489  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
    470490        (initial-values (mapcar (constantly nil) collectors)))
     
    480500  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    481501and NIL NAME, TYPE and VERSION components"
    482   (make-pathname :name nil :type nil :version nil :defaults pathname))
    483 
    484 (defun current-directory ()
    485   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     502  (when pathname
     503    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    486504
    487505(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     
    494512         (defaults (pathname defaults))
    495513         (directory (pathname-directory specified))
    496          (directory (if (stringp directory) `(:absolute ,directory) directory))
     514         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
    497515         (name (or (pathname-name specified) (pathname-name defaults)))
    498516         (type (or (pathname-type specified) (pathname-type defaults)))
     
    517535             (values (pathname-host defaults)
    518536                     (pathname-device defaults)
    519                      (if (null (pathname-directory defaults))
    520                          directory
    521                          (append (pathname-directory defaults) (cdr directory)))
     537                     (if (pathname-directory defaults)
     538                         (append (pathname-directory defaults) (cdr directory))
     539                         directory)
    522540                     (unspecific-handler defaults)))
    523541            #+gcl
     
    539557  or "or a flag")
    540558
     559(defun first-char (s)
     560  (and (stringp s) (plusp (length s)) (char s 0)))
     561
     562(defun last-char (s)
     563  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     564
    541565(defun asdf-message (format-string &rest format-args)
    542566  (declare (dynamic-extent format-args))
     
    544568
    545569(defun split-string (string &key max (separator '(#\Space #\Tab)))
    546   "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
    547 return a list.
     570  "Split STRING into a list of components separated by
     571any of the characters in the sequence SEPARATOR.
    548572If MAX is specified, then no more than max(1,MAX) components will be returned,
    549573starting the separation from the end, e.g. when called with arguments
     
    596620    (multiple-value-bind (relative components)
    597621        (if (equal (first components) "")
    598             (if (and (plusp (length s)) (eql (char s 0) #\/))
     622            (if (equal (first-char s) #\/)
    599623                (values :absolute (cdr components))
    600624                (values :relative nil))
    601625          (values :relative components))
     626      (setf components (remove "" components :test #'equal))
    602627      (cond
    603628        ((equal last-comp "")
    604          (values relative (butlast components) nil))
     629         (values relative components nil)) ; "" already removed
    605630        (force-directory
    606631         (values relative components nil))
     
    618643    :unless (eq k key)
    619644    :append (list k v)))
    620 
    621 (defun resolve-symlinks (path)
    622   #-allegro (truenamize path)
    623   #+allegro (excl:pathname-resolve-symbolic-links path))
    624645
    625646(defun getenv (x)
     
    629650  (sb-ext:posix-getenv x)
    630651  #+clozure
    631   (ccl::getenv x)
     652  (ccl:getenv x)
    632653  #+clisp
    633654  (ext:getenv x)
     
    644665
    645666(defun directory-pathname-p (pathname)
    646   "Does `pathname` represent a directory?
     667  "Does PATHNAME represent a directory?
    647668
    648669A directory-pathname is a pathname _without_ a filename. The three
    649 ways that the filename components can be missing are for it to be `nil`,
    650 `:unspecific` or the empty string.
    651 
    652 Note that this does _not_ check to see that `pathname` points to an
     670ways that the filename components can be missing are for it to be NIL,
     671:UNSPECIFIC or the empty string.
     672
     673Note that this does _not_ check to see that PATHNAME points to an
    653674actually-existing directory."
    654675  (flet ((check-one (x)
     
    734755      (when (typep p 'logical-pathname) (return p))
    735756      (ignore-errors (return (truename p)))
    736       (when (stringp directory)
    737          (return p))
    738       (when (not (eq :absolute (car directory)))
    739         (return p))
     757      #-sbcl (when (stringp directory) (return p))
     758      (when (not (eq :absolute (car directory))) (return p))
    740759      (let ((sofar (ignore-errors (truename (pathname-root p)))))
    741760        (unless sofar (return p))
     
    761780            (return (solution nil))))))))
    762781
     782(defun resolve-symlinks (path)
     783  #-allegro (truenamize path)
     784  #+allegro (excl:pathname-resolve-symbolic-links path))
     785
     786(defun default-directory ()
     787  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     788
    763789(defun lispize-pathname (input-file)
    764790  (make-pathname :type "lisp" :defaults input-file))
     791
     792(defparameter *wild-path*
     793  (make-pathname :directory '(:relative :wild-inferiors)
     794                 :name :wild :type :wild :version :wild))
     795
     796(defun wilden (path)
     797  (merge-pathnames* *wild-path* path))
     798
     799(defun directorize-pathname-host-device (pathname)
     800  (let* ((root (pathname-root pathname))
     801         (wild-root (wilden root))
     802         (absolute-pathname (merge-pathnames* pathname root))
     803         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     804         (separator (last-char (namestring foo)))
     805         (root-namestring (namestring root))
     806         (root-string
     807          (substitute-if #\/
     808                         (lambda (x) (or (eql x #\:)
     809                                         (eql x separator)))
     810                         root-namestring)))
     811    (multiple-value-bind (relative path filename)
     812        (component-name-to-pathname-components root-string t)
     813      (declare (ignore relative filename))
     814      (let ((new-base
     815             (make-pathname :defaults root
     816                            :directory `(:absolute ,@path))))
     817        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    765818
    766819;;;; -------------------------------------------------------------------------
     
    775828  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    776829  #+cmu (:report print-object))
     830
     831(declaim (ftype (function (t) t)
     832                format-arguments format-control
     833                error-name error-pathname error-condition
     834                duplicate-names-name
     835                error-component error-operation
     836                module-components module-components-by-name)
     837         (ftype (function (t t) t) (setf module-components-by-name)))
     838
    777839
    778840(define-condition formatted-system-definition-error (system-definition-error)
     
    895957
    896958(defun compute-module-components-by-name (module)
    897   (let ((hash (module-components-by-name module)))
    898     (clrhash hash)
     959  (let ((hash (make-hash-table :test 'equal)))
     960    (setf (module-components-by-name module) hash)
    899961    (loop :for c :in (module-components module)
    900962      :for name = (component-name c)
     
    912974    :accessor module-components)
    913975   (components-by-name
    914     :initform (make-hash-table :test 'equal)
    915976    :accessor module-components-by-name)
    916977   ;; What to do if we can't satisfy a dependency of one of this module's
     
    9401001             (merge-pathnames*
    9411002             (component-relative-pathname component)
    942              (component-parent-pathname component))))
     1003             (pathname-directory-pathname (component-parent-pathname component)))))
    9431004        (unless (or (null pathname) (absolute-pathname-p pathname))
    9441005          (error "Invalid relative pathname ~S for component ~S" pathname component))
     
    10141075
    10151076(defun map-systems (fn)
    1016   "Apply `fn` to each defined system.
    1017 
    1018 `fn` should be a function of one argument. It will be
     1077  "Apply FN to each defined system.
     1078
     1079FN should be a function of one argument. It will be
    10191080called with an object of type asdf:system."
    10201081  (maphash (lambda (_ datum)
     
    10291090
    10301091(defparameter *system-definition-search-functions*
    1031   '(sysdef-central-registry-search sysdef-source-registry-search))
     1092  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    10321093
    10331094(defun system-definition-pathname (system)
     
    10541115Going forward, we recommend new users should be using the source-registry.
    10551116")
     1117
     1118(defun probe-asd (name defaults)
     1119  (block nil
     1120    (when (directory-pathname-p defaults)
     1121      (let ((file
     1122             (make-pathname
     1123              :defaults defaults :version :newest :case :local
     1124              :name name
     1125              :type "asd")))
     1126        (when (probe-file file)
     1127          (return file)))
     1128      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     1129      (let ((shortcut
     1130             (make-pathname
     1131              :defaults defaults :version :newest :case :local
     1132              :name (concatenate 'string name ".asd")
     1133              :type "lnk")))
     1134        (when (probe-file shortcut)
     1135          (let ((target (parse-windows-shortcut shortcut)))
     1136            (when target
     1137              (return (pathname target)))))))))
    10561138
    10571139(defun sysdef-central-registry-search (system)
     
    10731155                                   (message
    10741156                                    (format nil
    1075                                             "~@<While searching for system `~a`: `~a` evaluated ~
    1076 to `~a` which is not a directory.~@:>"
     1157                                            "~@<While searching for system ~S: ~S evaluated ~
     1158to ~S which is not a directory.~@:>"
    10771159                                            system dir defaults)))
    10781160                              (error message))
     
    11231205
    11241206(defun find-system (name &optional (error-p t))
    1125   (let* ((name (coerce-name name))
    1126          (in-memory (system-registered-p name))
    1127          (on-disk (system-definition-pathname name)))
    1128     (when (and on-disk
    1129                (or (not in-memory)
    1130                    (< (car in-memory) (safe-file-write-date on-disk))))
    1131       (let ((package (make-temporary-package)))
    1132         (unwind-protect
    1133              (handler-bind
    1134                  ((error (lambda (condition)
    1135                            (error 'load-system-definition-error
    1136                                   :name name :pathname on-disk
    1137                                   :condition condition))))
    1138                (let ((*package* package))
    1139                  (asdf-message
    1140                   "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    1141                   on-disk *package*)
    1142                  (load on-disk)))
    1143           (delete-package package))))
    1144     (let ((in-memory (system-registered-p name)))
    1145       (if in-memory
    1146           (progn (when on-disk (setf (car in-memory)
    1147                                      (safe-file-write-date on-disk)))
    1148                  (cdr in-memory))
    1149           (when error-p (error 'missing-component :requires name))))))
     1207  (catch 'find-system
     1208    (let* ((name (coerce-name name))
     1209           (in-memory (system-registered-p name))
     1210           (on-disk (system-definition-pathname name)))
     1211      (when (and on-disk
     1212                 (or (not in-memory)
     1213                     (< (car in-memory) (safe-file-write-date on-disk))))
     1214        (let ((package (make-temporary-package)))
     1215          (unwind-protect
     1216               (handler-bind
     1217                   ((error (lambda (condition)
     1218                             (error 'load-system-definition-error
     1219                                    :name name :pathname on-disk
     1220                                    :condition condition))))
     1221                 (let ((*package* package))
     1222                   (asdf-message
     1223                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1224                    on-disk *package*)
     1225                   (load on-disk)))
     1226            (delete-package package))))
     1227      (let ((in-memory (system-registered-p name)))
     1228        (if in-memory
     1229            (progn (when on-disk (setf (car in-memory)
     1230                                       (safe-file-write-date on-disk)))
     1231                   (cdr in-memory))
     1232            (when error-p (error 'missing-component :requires name)))))))
    11501233
    11511234(defun register-system (name system)
     
    11531236  (setf (gethash (coerce-name name) *defined-systems*)
    11541237        (cons (get-universal-time) system)))
     1238
     1239(defun sysdef-find-asdf (system)
     1240  (let ((name (coerce-name system)))
     1241    (when (equal name "asdf")
     1242      (let* ((registered (cdr (gethash name *defined-systems*)))
     1243             (asdf (or registered
     1244                       (make-instance
     1245                        'system :name "asdf"
     1246                        :source-file (or *compile-file-truename* *load-truename*)))))
     1247        (unless registered
     1248          (register-system "asdf" asdf))
     1249        (throw 'find-system asdf)))))
    11551250
    11561251
     
    11721267
    11731268(defmethod find-component ((module module) (name string))
    1174   (when (slot-boundp module 'components-by-name)
    1175     (values (gethash name (module-components-by-name module)))))
     1269  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
     1270    (compute-module-components-by-name module))
     1271  (values (gethash name (module-components-by-name module))))
    11761272
    11771273(defmethod find-component ((component component) (name symbol))
     
    16031699      flag))
    16041700
    1605 (defmethod traverse ((operation operation) (c component))
    1606   ;; cerror'ing a feature that seems to have NEVER EVER worked
    1607   ;; ever since danb created it in his 2003-03-16 commit e0d02781.
    1608   ;; It was both fixed and disabled in the 1.700 rewrite.
    1609   (when (consp (operation-forced operation))
    1610     (cerror "Continue nonetheless."
    1611             "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.")
    1612     (setf (operation-forced operation)
    1613           (mapcar #'coerce-name (operation-forced operation))))
    1614   (flatten-tree
    1615    (while-collecting (collect)
    1616      (do-traverse operation c #'collect))))
    1617 
    16181701(defun flatten-tree (l)
    16191702  ;; You collected things into a list.
     
    16321715      (r* l))))
    16331716
     1717(defmethod traverse ((operation operation) (c component))
     1718  ;; cerror'ing a feature that seems to have NEVER EVER worked
     1719  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
     1720  ;; It was both fixed and disabled in the 1.700 rewrite.
     1721  (when (consp (operation-forced operation))
     1722    (cerror "Continue nonetheless."
     1723            "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.")
     1724    (setf (operation-forced operation)
     1725          (mapcar #'coerce-name (operation-forced operation))))
     1726  (flatten-tree
     1727   (while-collecting (collect)
     1728     (do-traverse operation c #'collect))))
     1729
    16341730(defmethod perform ((operation operation) (c source-file))
    16351731  (sysdef-error
     
    16731769        (get-universal-time)))
    16741770
     1771(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1772                          (values t t t))
     1773                compile-file*))
     1774
    16751775;;; perform is required to check output-files to find out where to put
    16761776;;; its answers, in case it has been overridden for site policy
     
    16781778  #-:broken-fasl-loader
    16791779  (let ((source-file (component-pathname c))
    1680         (output-file (car (output-files operation c))))
     1780        (output-file (car (output-files operation c)))
     1781        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
     1782        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    16811783    (multiple-value-bind (output warnings-p failure-p)
    1682         (apply #'compile-file source-file :output-file output-file
     1784        (apply #'compile-file* source-file :output-file output-file
    16831785               (compile-op-flags operation))
    16841786      (when warnings-p
     
    18561958;;;; Invoking Operations
    18571959
    1858 (defgeneric operate (operation-class system &key &allow-other-keys))
     1960(defgeneric* operate (operation-class system &key &allow-other-keys))
    18591961
    18601962(defmethod operate (operation-class system &rest args
     
    19042006  "Operate does three things:
    19052007
    1906 1. It creates an instance of `operation-class` using any keyword parameters
     20081. It creates an instance of OPERATION-CLASS using any keyword parameters
    19072009as initargs.
    1908 2. It finds the  asdf-system specified by `system` (possibly loading
     20102. It finds the  asdf-system specified by SYSTEM (possibly loading
    19092011it from disk).
    1910 3. It then calls `traverse` with the operation and system as arguments
    1911 
    1912 The traverse operation is wrapped in `with-compilation-unit` and error
    1913 handling code. If a `version` argument is supplied, then operate also
    1914 ensures that the system found satisfies it using the `version-satisfies`
     20123. It then calls TRAVERSE with the operation and system as arguments
     2013
     2014The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
     2015handling code. If a VERSION argument is supplied, then operate also
     2016ensures that the system found satisfies it using the VERSION-SATISFIES
    19152017method.
    19162018
     
    19502052;;;; Defsystem
    19512053
     2054(defun load-pathname ()
     2055  (let ((pn (or *load-pathname* *compile-file-pathname*)))
     2056    (if *resolve-symlinks*
     2057        (and pn (resolve-symlinks pn))
     2058        pn)))
     2059
    19522060(defun determine-system-pathname (pathname pathname-supplied-p)
    1953   ;; called from the defsystem macro.
    1954   ;; the pathname of a system is either
     2061  ;; The defsystem macro calls us to determine
     2062  ;; the pathname of a system as follows:
    19552063  ;; 1. the one supplied,
    1956   ;; 2. derived from the *load-truename* (see below), or
    1957   ;; 3. taken from *default-pathname-defaults*
    1958   ;;
    1959   ;; if using *load-truename*, then we also deal with whether or not
    1960   ;; to resolve symbolic links. If not resolving symlinks, then we use
    1961   ;; *load-pathname* instead of *load-truename* since in some
    1962   ;; implementations, the latter has *already resolved it.
    1963   (let ((file-pathname
    1964          (when (or *load-pathname* *compile-file-pathname*)
    1965            (pathname-directory-pathname
    1966             (if *resolve-symlinks*
    1967                 (resolve-symlinks (or *load-truename* *compile-file-truename*))
    1968                 *load-pathname*)))))
    1969     (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
     2064  ;; 2. derived from *load-pathname* via load-pathname
     2065  ;; 3. taken from the *default-pathname-defaults* via default-directory
     2066  (let* ((file-pathname (load-pathname))
     2067         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
     2068    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    19702069        file-pathname
    1971         (current-directory))))
     2070        (default-directory))))
    19722071
    19732072(defmacro defsystem (name &body options)
     
    19902089                  (register-system (quote ,name)
    19912090                                   (make-instance ',class :name ',name))))
    1992            (%set-system-source-file *load-truename*
     2091           (%set-system-source-file (load-pathname)
    19932092                                    (cdr (system-registered-p ',name))))
    19942093         (parse-component-form
     
    19992098               ',component-options))))))
    20002099
    2001 
    20022100(defun class-for-type (parent type)
    2003   (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
    2004                               (find-symbol (symbol-name type)
    2005                                            (load-time-value
    2006                                             (package-name :asdf)))))
    2007          (class (dolist (symbol (if (keywordp type)
    2008                                     extra-symbols
    2009                                     (cons type extra-symbols)))
    2010                   (when (and symbol
    2011                              (find-class symbol nil)
    2012                              (subtypep symbol 'component))
    2013                     (return (find-class symbol))))))
    2014     (or class
    2015         (and (eq type :file)
    2016              (or (module-default-component-class parent)
    2017                  (find-class 'cl-source-file)))
    2018         (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     2101  (or (loop :for symbol :in (list
     2102                             (unless (keywordp type) type)
     2103                             (find-symbol (symbol-name type) *package*)
     2104                             (find-symbol (symbol-name type) :asdf))
     2105        :for class = (and symbol (find-class symbol nil))
     2106        :when (and class (subtypep class 'component))
     2107        :return class)
     2108      (and (eq type :file)
     2109           (or (module-default-component-class parent)
     2110               (find-class *default-component-class*)))
     2111      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    20192112
    20202113(defun maybe-add-tree (tree op1 op2 c)
     
    21792272
    21802273(defun run-shell-command (control-string &rest args)
    2181   "Interpolate `args` into `control-string` as if by `format`, and
     2274  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    21822275synchronously execute the result using a Bourne-compatible shell, with
    2183 output to `*verbose-out*`.  Returns the shell's exit code."
     2276output to *VERBOSE-OUT*.  Returns the shell's exit code."
    21842277  (let ((command (apply #'format nil control-string args)))
    21852278    (asdf-message "; $ ~A~%" command)
     
    23342427    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
    23352428    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2336     #+(or mcl sbcl scl) s
     2429    #+(or cormanlisp mcl sbcl scl) s
    23372430    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
    23382431          ecl gcl lispworks mcl sbcl scl) s))
     
    24542547    (funcall validator (car forms))))
    24552548
     2549(defun hidden-file-p (pathname)
     2550  (equal (first-char (pathname-name pathname)) #\.))
     2551
    24562552(defun validate-configuration-directory (directory tag validator)
    24572553  (let ((files (sort (ignore-errors
    2458                        (directory (make-pathname :name :wild :type :wild :defaults directory)
    2459                                   #+sbcl :resolve-symlinks #+sbcl nil))
     2554                       (remove-if
     2555                        'hidden-file-p
     2556                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
     2557                                   #+sbcl :resolve-symlinks #+sbcl nil)))
    24602558                     #'string< :key #'namestring)))
    24612559    `(,tag
     
    25142612  (values))
    25152613
    2516 (defparameter *wild-path*
    2517   (make-pathname :directory '(:relative :wild-inferiors)
    2518                  :name :wild :type :wild :version :wild))
    2519 
    25202614(defparameter *wild-asd*
    25212615  (make-pathname :directory '(:relative :wild-inferiors)
    25222616                 :name :wild :type "asd" :version :newest))
    25232617
    2524 (defun wilden (path)
    2525   (merge-pathnames* *wild-path* path))
     2618
     2619(declaim (ftype (function (t &optional boolean) (or null pathname))
     2620                resolve-location))
     2621
     2622(defun resolve-relative-location-component (super x &optional wildenp)
     2623  (let* ((r (etypecase x
     2624              (pathname x)
     2625              (string x)
     2626              (cons
     2627               (let ((car (resolve-relative-location-component super (car x) nil)))
     2628                 (if (null (cdr x))
     2629                     car
     2630                     (let ((cdr (resolve-relative-location-component
     2631                                 (merge-pathnames* car super) (cdr x) wildenp)))
     2632                       (merge-pathnames* cdr car)))))
     2633              ((eql :default-directory)
     2634               (relativize-pathname-directory (default-directory)))
     2635              ((eql :implementation) (implementation-identifier))
     2636              ((eql :implementation-type) (string-downcase (implementation-type)))
     2637              #-(and (or win32 windows mswindows mingw32) (not cygwin))
     2638              ((eql :uid) (princ-to-string (get-uid)))))
     2639         (d (if (pathnamep x) r (ensure-directory-pathname r)))
     2640         (s (if (and wildenp (not (pathnamep x)))
     2641                (wilden d)
     2642                d)))
     2643    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
     2644      (error "pathname ~S is not relative to ~S" s super))
     2645    (merge-pathnames* s super)))
    25262646
    25272647(defun resolve-absolute-location-component (x wildenp)
     
    25452665            ((eql :user-cache) (resolve-location *user-cache* nil))
    25462666            ((eql :system-cache) (resolve-location *system-cache* nil))
    2547             ((eql :current-directory) (current-directory))))
     2667            ((eql :default-directory) (default-directory))))
    25482668         (s (if (and wildenp (not (pathnamep x)))
    25492669                (wilden r)
     
    25522672      (error "Not an absolute pathname ~S" s))
    25532673    s))
    2554 
    2555 (defun resolve-relative-location-component (super x &optional wildenp)
    2556   (let* ((r (etypecase x
    2557               (pathname x)
    2558               (string x)
    2559               (cons
    2560                (let ((car (resolve-relative-location-component super (car x) nil)))
    2561                  (if (null (cdr x))
    2562                      car
    2563                      (let ((cdr (resolve-relative-location-component
    2564                                  (merge-pathnames* car super) (cdr x) wildenp)))
    2565                        (merge-pathnames* cdr car)))))
    2566               ((eql :current-directory)
    2567                (relativize-pathname-directory (current-directory)))
    2568               ((eql :implementation) (implementation-identifier))
    2569               ((eql :implementation-type) (string-downcase (implementation-type)))
    2570               ((eql :uid) (princ-to-string (get-uid)))))
    2571          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2572          (s (if (and wildenp (not (pathnamep x)))
    2573                 (wilden d)
    2574                 d)))
    2575     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    2576       (error "pathname ~S is not relative to ~S" s super))
    2577     (merge-pathnames* s super)))
    25782674
    25792675(defun resolve-location (x &optional wildenp)
     
    26822778    ;; so we must disable translations for implementation paths.
    26832779    #+sbcl (,(getenv "SBCL_HOME") ())
    2684     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    2685     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     2780    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
     2781    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
    26862782    ;; All-import, here is where we want user stuff to be:
    26872783    :inherit-configuration
     
    27072803
    27082804(defgeneric process-output-translations (spec &key inherit collect))
     2805(declaim (ftype (function (t &key (:collect (or symbol function))) t)
     2806                inherit-output-translations))
     2807(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
     2808                process-output-translations-directive))
     2809
    27092810(defmethod process-output-translations ((x symbol) &key
    27102811                                        (inherit *default-output-translations*)
     
    28342935       :finally (return p)))))
    28352936
    2836 (defun last-char (s)
    2837   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    2838 
    2839 (defun directorize-pathname-host-device (pathname)
    2840   (let* ((root (pathname-root pathname))
    2841          (wild-root (wilden root))
    2842          (absolute-pathname (merge-pathnames* pathname root))
    2843          (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
    2844          (separator (last-char (namestring foo)))
    2845          (root-namestring (namestring root))
    2846          (root-string
    2847           (substitute-if #\/
    2848                          (lambda (x) (or (eql x #\:)
    2849                                          (eql x separator)))
    2850                          root-namestring)))
    2851     (multiple-value-bind (relative path filename)
    2852         (component-name-to-pathname-components root-string t)
    2853       (declare (ignore relative filename))
    2854       (let ((new-base
    2855              (make-pathname :defaults root
    2856                             :directory `(:absolute ,@path))))
    2857         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    2858 
    28592937(defmethod output-files :around (operation component)
    28602938  "Translate output files, unless asked not to"
     
    28672945   t))
    28682946
    2869 (defun compile-file-pathname* (input-file &rest keys)
    2870   (apply-output-translations
    2871    (apply #'compile-file-pathname
    2872           (truenamize (lispize-pathname input-file))
    2873           keys)))
     2947(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     2948  (or output-file
     2949      (apply-output-translations
     2950       (apply 'compile-file-pathname
     2951              (truenamize (lispize-pathname input-file))
     2952              keys))))
     2953
     2954(defun tmpize-pathname (x)
     2955  (make-pathname
     2956   :name (format nil "ASDF-TMP-~A" (pathname-name x))
     2957   :defaults x))
     2958
     2959(defun delete-file-if-exists (x)
     2960  (when (probe-file x)
     2961    (delete-file x)))
     2962
     2963(defun compile-file* (input-file &rest keys &key &allow-other-keys)
     2964  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     2965         (tmp-file (tmpize-pathname output-file))
     2966         (status :error))
     2967    (multiple-value-bind (output-truename warnings-p failure-p)
     2968        (apply 'compile-file input-file :output-file tmp-file keys)
     2969      (cond
     2970        (failure-p
     2971         (setf status *compile-file-failure-behaviour*))
     2972        (warnings-p
     2973         (setf status *compile-file-warnings-behaviour*))
     2974        (t
     2975         (setf status :success)))
     2976      (ecase status
     2977        ((:success :warn :ignore)
     2978         (delete-file-if-exists output-file)
     2979         (when output-truename
     2980           (rename-file output-truename output-file)
     2981           (setf output-truename output-file)))
     2982        (:error
     2983         (delete-file-if-exists output-truename)
     2984         (setf output-truename nil)))
     2985      (values output-truename warnings-p failure-p))))
    28742986
    28752987#+abcl
     
    29993111
    30003112;; Using ack 1.2 exclusions
    3001 (defvar *default-exclusions*
     3113(defvar *default-source-registry-exclusions*
    30023114  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    30033115    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    30043116    "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3117
     3118(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    30053119
    30063120(defvar *source-registry* ()
     
    30243138  (setf *source-registry* '())
    30253139  (values))
    3026 
    3027 (defun probe-asd (name defaults)
    3028   (block nil
    3029     (when (directory-pathname-p defaults)
    3030       (let ((file
    3031              (make-pathname
    3032               :defaults defaults :version :newest :case :local
    3033               :name name
    3034               :type "asd")))
    3035         (when (probe-file file)
    3036           (return file)))
    3037       #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    3038       (let ((shortcut
    3039              (make-pathname
    3040               :defaults defaults :version :newest :case :local
    3041               :name (concatenate 'string name ".asd")
    3042               :type "lnk")))
    3043         (when (probe-file shortcut)
    3044           (let ((target (parse-windows-shortcut shortcut)))
    3045             (when target
    3046               (return (pathname target)))))))))
    3047 
    3048 (defun sysdef-source-registry-search (system)
    3049   (ensure-source-registry)
    3050   (loop :with name = (coerce-name system)
    3051     :for defaults :in (source-registry)
    3052     :for file = (probe-asd name defaults)
    3053     :when file :return file))
    30543140
    30553141(defun validate-source-registry-directive (directive)
     
    30613147               (and (length=n-p rest 1)
    30623148                    (typep (car rest) '(or pathname string null))))
    3063               ((:exclude)
     3149              ((:exclude :also-exclude)
    30643150               (every #'stringp rest))
    30653151              (null rest))))
     
    31473233  `(:source-registry
    31483234    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    3149    :inherit-configuration))
     3235    :inherit-configuration
     3236    #+cmu (:tree #p"modules:")))
    31503237(defun default-source-registry ()
    31513238  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     
    31863273
    31873274(defgeneric process-source-registry (spec &key inherit register))
     3275(declaim (ftype (function (t &key (:register (or symbol function))) t)
     3276                inherit-source-registry))
     3277(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
     3278                process-source-registry-directive))
     3279
    31883280(defmethod process-source-registry ((x symbol) &key inherit register)
    31893281  (process-source-registry (funcall x) :inherit inherit :register register))
     
    32053297  (inherit-source-registry inherit :register register))
    32063298(defmethod process-source-registry ((form cons) &key inherit register)
    3207   (let ((*default-exclusions* *default-exclusions*))
     3299  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    32083300    (dolist (directive (cdr (validate-source-registry-form form)))
    32093301      (process-source-registry-directive directive :inherit inherit :register register))))
     
    32263318       (destructuring-bind (pathname) rest
    32273319         (when pathname
    3228            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
     3320           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
    32293321      ((:exclude)
    3230        (setf *default-exclusions* rest))
     3322       (setf *source-registry-exclusions* rest))
     3323      ((:also-exclude)
     3324       (appendf *source-registry-exclusions* rest))
    32313325      ((:default-registry)
    32323326       (inherit-source-registry '(default-source-registry) :register register))
     
    32343328       (inherit-source-registry inherit :register register))
    32353329      ((:ignore-inherited-configuration)
    3236        nil))))
     3330       nil)))
     3331  nil)
    32373332
    32383333(defun flatten-source-registry (&optional parameter)
     
    32693364      (initialize-source-registry)))
    32703365
     3366(defun sysdef-source-registry-search (system)
     3367  (ensure-source-registry)
     3368  (loop :with name = (coerce-name system)
     3369    :for defaults :in (source-registry)
     3370    :for file = (probe-asd name defaults)
     3371    :when file :return file))
     3372
    32713373;;;; -----------------------------------------------------------------
    32723374;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
     
    32793381         (missing-component (constantly nil))
    32803382         (error (lambda (e)
    3281                   (format *error-output* "ASDF could not load ~A because ~A.~%"
     3383                  (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    32823384                          name e))))
    32833385      (let* ((*verbose-out* (make-broadcast-stream))
    3284              (system (find-system name nil)))
     3386             (system (find-system (string-downcase name) nil)))
    32853387        (when system
    3286           (load-system name)
     3388          (load-system system)
    32873389          t))))
    32883390  (pushnew 'module-provide-asdf
    32893391           #+abcl sys::*module-provider-functions*
    3290            #+clozure ccl::*module-provider-functions*
     3392           #+clozure ccl:*module-provider-functions*
    32913393           #+cmu ext:*module-provider-functions*
    32923394           #+ecl si:*module-provider-functions*
     
    33133415;;;; Done!
    33143416(when *load-verbose*
    3315   (asdf-message ";; ASDF, version ~a" (asdf-version)))
     3417  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
    33163418
    33173419#+allegro
     
    33213423
    33223424(pushnew :asdf *features*)
    3323 ;; this is a release candidate for ASDF 2.0
    33243425(pushnew :asdf2 *features*)
    33253426
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp

    r12715 r12796  
    9393
    9494(defgeneric jmake-proxy (interface implementation &optional lisp-this)
    95   (: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."))
     95  (: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."))
     96
     97(defun canonicalize-jproxy-interfaces (ifaces)
     98  (if (listp ifaces)
     99      (mapcar #'jclass ifaces)
     100      (list (jclass ifaces))))
     101
    96102
    97103(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
    98104  "Basic implementation that directly uses an invocation handler."
    99   (%jmake-proxy (jclass interface) invocation-handler lisp-this))
     105  (%jmake-proxy (canonicalize-jproxy-interfaces interface) invocation-handler lisp-this))
    100106
    101107(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
    102108  "Implements a Java interface forwarding method calls to a Lisp function."
    103   (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
     109  (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler implementation) lisp-this))
    104110
    105111(defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
     
    115121          (princ (char-upcase char) str)))
    116122        name)))))
    117     (%jmake-proxy (jclass interface)
     123    (%jmake-proxy (canonicalize-jproxy-interfaces interface)
    118124      (jmake-invocation-handler
    119125       (lambda (obj method &rest args)
     
    134140(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
    135141  "Implements a Java interface using closures in an hash-table keyed by Java method name."
    136   (%jmake-proxy (jclass interface)
     142  (%jmake-proxy (canonicalize-jproxy-interfaces interface)
    137143    (jmake-invocation-handler
    138144     (lambda (obj method &rest args)
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp

    r12749 r12796  
    789789        (operator (car form))
    790790        (locals (cadr form))
    791         (body (cddr form)))
     791        ;; precompile (thus macro-expand) the body before inspecting it
     792        ;; for the use of our locals and optimizing them away
     793        (body (mapcar #'precompile1 (cddr form))))
    792794    (dolist (local locals)
    793795      (let* ((name (car local))
     
    821823    (list* (car form)
    822824           (precompile-local-functions locals)
    823            (mapcar #'precompile1 body))))
     825           body)))
    824826
    825827(defun precompile-function (form)
Note: See TracChangeset for help on using the changeset viewer.