Changeset 12679


Ignore:
Timestamp:
05/13/10 21:15:07 (14 years ago)
Author:
astalla
Message:

Fixed missing probe-file in zipped fasl construction.
Advanced the branch to merge the latest trunk updates.

Location:
branches/less-reflection/abcl
Files:
29 edited

Legend:

Unmodified
Added
Removed
  • branches/less-reflection/abcl/CHANGES

    r12536 r12679  
     1Version 0.20
     2============
     3yet-to-be-tagged
     4(???)
     5
     6
     7Features
     8--------
     9
     10* [svn r12576] Support for CLOS METACLASS feature
     11
     12* [svn r12591-602] Consolidation of copy/paste code in the readers
     13
     14* [svn r12619] Update included ASDF (to ASDF2)
     15
     16* [svn r12620] Use interpreted function in FASL when compilation fails
     17
     18* [ticket 95] Pathname functions work with URLs and JARs
     19
     20* Many small speed improvements (by marking functions 'final')
     21
     22* [ticket #91] Threads started through MAKE-THREAD now have a
     23    thread-termination restart available in their debugger
     24
     25* [svn r12663] JCLASS supports an optional class-loader argument
     26
     27* [svn r12634] THREADS:THREAD-JOIN implemented
     28
     29Fixes
     30-----
     31
     32* [ticket 89] Inlining of READ-LINE broken when the return value
     33    is unused
     34
     35* [svn r12636] Java class verification error when compiling PROGV
     36    in a context wanting an unboxed return value (typically a
     37    logical expression)
     38
     39* [svn r12635] ABCL loads stale fasls instead of updated source
     40    even when LOAD is called with a file name without extension
     41
     42* [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly
     43    returned as characters from CODE-CHAR
     44
     45* [ticket #93] Reader doesn't handle zero returned values from
     46    macro functions correctly
     47
     48* [ticket #79] Different, yet similarly named, uninterned symbols
     49    are incorrectly coalesced into the same object in a fasl.
     50
     51* [ticket #86] No restarts available to kill a thread, if none
     52    bound by user code
     53
     54* [svn r12586] Increased function dispatch speed by eliminating
     55    FIND-CLASS calls (replacing them by constant references)
     56
     57Other
     58-----
     59
     60* [svn r12581] LispCharacter() constructors made private, in favor
     61    of getInstance() for better re-use of pre-constructed characters
     62
     63* [svn r12583] JAVA-CLASS reimplemented in Lisp
     64
     65
    166Version 0.19
    267============
     
    79144* [svn r12441] ZipCache now caches all references to ZipFiles based on
    80145  the last-modified time for local files.  Remote files are always
    81   retrieved due to problems in the underlying JVM code. 
    82  
     146  retrieved due to problems in the underlying JVM code.
     147
    83148  SYS:REMOVE-ZIP-CACHE implements a way to invalidate an entry given a
    84149  pathname.
     
    188253
    189254*  New toplevel 'doc' directory now contains:
    190    
     255
    191256   + [svn r12410] Design for the (in progress) reworking of the Stream
    192257     inheritance.
    193    
     258
    194259   + [svn r12433] Design and current status for the re-implementation
    195260     of jar pathnames.
     
    197262* [svn r12402] Change ABCL unit tests to use the ABCL-TEST-LISP definition
    198263  contained in 'abcl.asd'.  Fixed and renabled math-tests.  Added new
    199   tests for work related to handling jar pathnames. 
     264  tests for work related to handling jar pathnames.
    200265
    201266* [svn r12401] The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now
    202267  tracks whether local functions need the capture of an actual
    203268  function object.
    204    
     269
    205270
    206271Version 0.18.1
  • branches/less-reflection/abcl/abcl.asd

    r12610 r12679  
    3333                     ((:file "compiler-tests")
    3434                      (:file "condition-tests")
     35                      (:file "metaclass")
    3536                      (:file "mop-tests-setup")
    3637                      (:file "mop-tests" :depends-on ("mop-tests-setup"))
  • branches/less-reflection/abcl/abcl.properties.in

    r12543 r12679  
    1212# java.options sets the Java options in the abcl wrapper scripts
    1313#java.options=-Xmx1g
     14
     15# Additional site specific startup code to be merged in 'system.lisp'
     16#abcl.startup.file=${basedir}/startup.lisp
  • branches/less-reflection/abcl/build.xml

    r12621 r12679  
    102102      <echo>Compiled ABCL with Java version: ${java.version}</echo>
    103103    </target>
    104    
     104
    105105    <target name="abcl.clean.maybe" unless="abcl.build.incremental">
    106106      <echo>Cleaning all intermediate compilation artifacts.</echo>
     
    144144  <or>
    145145    <matches string="${java.version}" pattern="1\.5"/>
    146     <matches string="${java.version}" pattern="1\.6\.0_1[0-9]"/>
     146    <matches string="${java.version}" pattern="1\.6\.0_[12][0-9]"/>
    147147  </or> 
    148148      </condition>
     
    177177       debug="true"
    178178       target="1.5"
     179             includeantruntime="false"
    179180       failonerror="true">
    180181  <src path="${src.dir}"/>
     
    224225          location="${build.classes.dir}/org/armedbear/lisp/"/>
    225226    <pathconvert dirsep="/" property="abcl.lisp.output" refid="abcl.lisp.output.path"/>
     227
     228    <property name="system.lisp.file"
     229              value="${build.classes.dir}/org/armedbear/lisp/system.lisp"/>
    226230   
    227231    <target name="abcl.compile.lisp"
    228       depends="abcl.copy.lisp,abcl.compile.java,abcl.fasls.uptodate"
     232      depends="abcl.copy.lisp,abcl.compile.java,abcl.system.update.maybe,abcl.fasls.uptodate"
    229233      unless="abcl.fasls.uptodate.p">
    230234      <echo>
     
    239243        <jvmarg value="-Dabcl.home=${abcl.home.dir}${file.separator}"/>
    240244  <arg value="--noinit"/>
     245        <arg value="--nosystem"/>
    241246        <arg value="--eval"/>
    242247        <arg value="(setf *load-verbose* t)"/>
    243248      </java>
     249      <concat destfile="${system.lisp.file}" append="true">
     250        <fileset file="${abcl.startup.file}"/>
     251      </concat>
    244252    </target>
    245253
     
    270278      <exec executable="hostname" outputproperty="abcl.hostname"/>
    271279      <echo>abcl.hostname: ${abcl.hostname}</echo>
     280    </target>
     281
     282    <target name="abcl.system.uptodate">
     283      <condition property="abcl.system.needs-update.p">
     284        <and>
     285          <available file="${system.lisp.file}"/>
     286          <available file="${abcl.startup.file}"/>
     287          <uptodate
     288                srcfile="${system.lisp.file}"
     289                targetfile="${abcl.startup.file}"/>
     290        </and>
     291      </condition>
     292    </target>
     293   
     294    <target name="abcl.system.update.maybe" depends="abcl.system.uptodate"
     295            if="abcl.system.needs-update.p">
     296      <touch file="${src.dir}/org/armedbear/lisp/compile-system.lisp"/>
    272297    </target>
    273298
     
    672697      classpathref="abcl.test.run.classpath"
    673698      classname="org.junit.runner.JUnitCore">
    674   <arg value="org.armedbear.lisp.FastStringBufferTest"/>
    675699        <arg value="org.armedbear.lisp.PathnameTest"/>
    676700        <arg value="org.armedbear.lisp.StreamTest"/>
     701        <arg value="org.armedbear.lisp.UtilitiesTest"/>
    677702      </java>
    678703    </target>
     
    706731  <arg value="--eval"/><arg value="(require (quote asdf))"/>
    707732  <arg value="--eval"/><arg value="(asdf:operate (quote asdf:load-op) :abcl)"/>
    708   <arg value="--eval"/><arg value="(asdf:operate (quote asdf:test-op) :ansi-compiled)"/>
     733  <arg value="--eval"/><arg value="(let ((*compile-verbose* t)) (asdf:operate (quote asdf:test-op) :ansi-compiled))"/>
    709734        <arg value="--eval"/><arg value="(ext:exit)"/>
    710735      </java>
  • branches/less-reflection/abcl/contrib/asdf-install/installer.lisp

    r12487 r12679  
    542542
    543543(defmethod asdf:find-component :around
    544     ((module (eql nil)) name &optional version)
    545   (declare (ignore version))
     544    ((module (eql nil)) name)
    546545  (when (or (not *propagate-installation*)
    547546            (member name *systems-installed-this-time*
  • branches/less-reflection/abcl/doc/asdf/asdf.texinfo

    r12618 r12679  
    3232This manual describes ASDF, a system definition facility
    3333for Common Lisp programs and libraries.
     34
     35You can find the latest version of this manual at
     36@url{http://common-lisp.net/project/asdf/asdf.html}.
    3437
    3538ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
     
    168171
    169172@emph{Nota Bene}:
    170 We are preparing for a release of ASDF 2,
     173We are preparing for a release of ASDF 2, hopefully for May 2010,
    171174which will have version 2.000 and later.
    172 Current releases, in the 1.600 series and beyond,
     175Current releases, in the 1.700 series and beyond,
    173176should be considered as release candidates.
    174177We're still working on polishing the code and documentation.
    175 @ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
     178@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
    176179
    177180
     
    239242If it returns @code{NIL} then ASDF is not installed.
    240243
    241 If you are running a version older than 1.678,
     244If you are running a version older than 1.711,
    242245we recommend that you load a newer ASDF using the method below.
    243246
     
    533536ASDF-Binary-Locations, cl-launch, common-lisp-controller.
    534537ASDF-Binary-Locations is now not needed anymore and should not be used.
    535 cl-launch 3.0 and common-lisp-controller 7.1 have been updated
     538cl-launch 2.900 and common-lisp-controller 7.1 have been updated
    536539to just delegate this functionality to ASDF.
    537540
     
    550553@end example
    551554
    552 On some implementations (namely, SBCL and Clozure CL),
     555On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
    553556ASDF hooks into the @code{CL:REQUIRE} facility
    554557and you can just use:
     
    13171320which doesn't provide any obvious way to specify required features.
    13181321Furthermore, in 2009, discussions on the
    1319 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     1322@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    13201323suggested that the specification of required features may be broken,
    13211324and that no one may have been using them for a while.
    13221325Please contact the
    1323 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     1326@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    13241327if you are interested in getting this features feature fixed.}
    13251328
     
    16721675Mentions of XDG variables refer to that document.
    16731676
    1674 @uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
     1677@url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
    16751678
    16761679This specification allows the user to specify some environment variables
     
    24642467
    24652468You may get the ASDF source repository using git:
    2466 @kbd{git clone http://common-lisp.net/project/asdf/asdf.git}
     2469@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
    24672470
    24682471You will find the above referenced tags in this repository.
     
    24732476mailing list
    24742477@kbd{asdf-devel@@common-lisp.net}.
    2475 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
     2478@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
    24762479
    24772480
     
    24852488
    24862489If you're unsure about whether something is a bug, of for general discussion,
    2487 use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     2490use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    24882491
    24892492
     
    24972500we are still working on polishing them before release.
    24982501
    2499 Releases in the 1.600 series and beyond
     2502Releases in the 1.700 series and beyond
    25002503should be considered as release candidates.
    25012504For all practical purposes,
     
    25142517
    25152518
    2516 @subsection ASDF can portably name files inside systems and components
     2519@subsection ASDF can portably name files in subdirectories
    25172520
    25182521Common Lisp namestrings are not portable,
    25192522except maybe for logical pathnamestrings,
    2520 that themselves require a lot of setup that is itself ultimately non-portable.
    2521 The only portable ways to refer to pathnames inside systems and components
     2523that themselves have various limitations and require a lot of setup
     2524that is itself ultimately non-portable.
     2525
     2526In ASDF 1, the only portable ways to refer to pathnames inside systems and components
    25222527were very awkward, using @code{#.(make-pathname ...)} and
    25232528@code{#.(merge-pathnames ...)}.
     
    25352540@xref{The defsystem grammar,,Pathname specifiers}.
    25362541
     2542
    25372543@subsection Output translations
    25382544
     
    25722578and a coherent set of configuration files and hooks.
    25732579
     2580We believe it's a vast improvement because it decouples
     2581application distribution from library distribution.
     2582The application writer can avoid thinking where the libraries are,
     2583and the library distributor (dpkg, clbuild, advanced user, etc.)
     2584can configure them once and for every application.
     2585Yet settings can be easily overridden where needed,
     2586so whoever needs control has exactly as much as required.
     2587
    25742588At the same time, ASDF 2 remains compatible
    25752589with the old magic you may have in your build scripts
     2590(using @code{*central-registry*} and
     2591@code{*system-definition-search-functions*})
    25762592to tailor the ASDF configuration to your build automation needs,
    25772593and also allows for new magic, simpler and more powerful magic.
    25782594
    25792595@xref{Controlling where ASDF searches for systems}.
     2596
    25802597
    25812598@subsection Usual operations are made easier to the user
     
    25932610@subsection Many bugs have been fixed
    25942611
    2595 These issues and many others have been fixed,
    2596 including the following:
    2597 
    2598 Dependencies were not correctly propagated
    2599 across submodules within a system.
    2600 
     2612The following issues and many others have been fixed:
     2613
     2614@itemize
     2615@item
     2616The infamous TRAVERSE function has been revamped significantly,
     2617with many bugs squashed.
     2618In particular, dependencies were not correctly propagated
     2619across submodules within a system but now are.
     2620The :version and :feature features and
     2621the :force (system1 .. systemN) feature have been fixed.
     2622
     2623@item
     2624Performance has been notably improved for large systems
     2625(say with thousands of components) by using
     2626hash-tables instead of linear search,
     2627and linear-time list accumulation
     2628instead of quadratic-time recursive appends.
     2629
     2630@item
    26012631Many features used to not be portable,
    26022632especially where pathnames were involved.
    2603 
    2604 The internal test suite used to massively fail
    2605 in many implementations.
    2606 
    2607 Support was broken for some implementations (notably ABCL).
    2608 
     2633Windows support was notably quirky because of such non-portability.
     2634
     2635@item
     2636The internal test suite used to massively fail on many implementations.
     2637While still incomplete, it now fully passes
     2638on all implementations supported by the test suite.
     2639
     2640@item
     2641Support was lacking for some implementations.
     2642ABCL was notably wholly broken.
     2643ECL extensions were not integrated in the ASDF release.
     2644
     2645@item
    26092646The documentation was grossly out of date.
    26102647
    2611 ECL extensions were not integrated in the ASDF release.
     2648@end itemize
    26122649
    26132650
     
    26242661that everyone can rely on from now on.
    26252662Use @code{#+asdf2} to detect presence of ASDF 2,
    2626 @code{(asdf:version-satisfies (asdf:asdf-version) "1.678")}
     2663@code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
    26272664to check the availability of a version no earlier than required.
     2665
    26282666
    26292667@subsection ASDF can be upgraded
     
    26682706towards the latest version for everyone.
    26692707
     2708
     2709@subsection Pitfalls of ASDF 2
     2710
     2711The main pitfalls in upgrading to ASDF 2 seem to be related
     2712to the output translation mechanism.
     2713
     2714@itemize
     2715
     2716@item
     2717Output translations is enabled by default. This may surprise some users,
     2718most of them in pleasant way (we hope), a few of them in an unpleasant way.
     2719It is trivial to disable output translations.
     2720@xref{FAQ,,``How can I wholly disable the compiler output cache?''}.
     2721
     2722@item
     2723Some systems in the large have been known not to play well with output translations.
     2724They were relatively easy to fix.
     2725Once again, it is also easy to disable output translations,
     2726or to override its configuration.
     2727
     2728@item
     2729The new ASDF output translations are incompatible with ASDF-Binary-Locations.
     2730They replace A-B-L, and there is compatibility mode to emulate
     2731your previous A-B-L configuration.
     2732See @code{asdf:enable-asdf-binary-locations-compatibility} in
     2733@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
     2734But thou shall not load ABL on top of ASDF 2.
     2735
     2736@end itemize
     2737
     2738Other issues include the following:
     2739
     2740@itemize
     2741
     2742@item
     2743There is a slight performance bug, notably on SBCL,
     2744when initially searching for @file{asd} files,
     2745the implicit @code{(directory "/configured/path/**/*.asd")}
     2746for every configured path @code{(:tree "/configured/path/")}
     2747in your @code{source-registry} configuration can cause a slight pause.
     2748Try to @code{(time (asdf:initialize-source-registry))}
     2749to see how bad it is or isn't on your system.
     2750If you insist on not having this pause,
     2751you can avoid the pause by overriding the default source-registry configuration
     2752and not use any deep @code{:tree} entry but only @code{:directory} entries
     2753or shallow @code{:tree} entries.
     2754Or you can fix your implementation to not be quite that slow
     2755when recursing through directories.
     2756
     2757@item
     2758On Windows, only LispWorks supports proper default configuration pathnames
     2759based on the Windows registry.
     2760Other implementations make do.
     2761Windows support is largely untested, so please help report and fix bugs.
     2762
     2763@end itemize
     2764
     2765
    26702766@section Issues with installing the proper version of ASDF
    26712767
     
    26912787it's a bug that you should report upstream and that we will fix ASAP.
    26922788
    2693 As to how to include ASDF, we recommend that
    2694 if you do have a few magic systems in your implementation path,
    2695 that are specially treated in @code{wrapping-source-registry},
    2696 like SBCL does.
    2697 In this case, we explicitly ask you to @emph{NOT} distribute
    2698 @file{asdf.asd} together with your implementation's ASDF,
    2699 least you separate it from the other systems in this path,
    2700 or otherwise rename the system and its @file{asd} file
    2701 to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}.
    2702 
     2789As to how to include ASDF, we recommend the following:
     2790
     2791@itemize
     2792@item
     2793If ASDF isn't installed yet, then @code{(require :asdf)}
     2794should load the version of ASDF that is bundled with your system.
     2795You may have it load some other version configured by the user,
     2796if you allow such configuration.
     2797
     2798@item
     2799If your system provides a mechanism to hook into @code{CL:REQUIRE},
     2800then it would be nice to add ASDF to this hook the same way that
     2801ABCL, CCL, CMUCL, ECL and SBCL do it.
     2802
     2803@item
     2804You may, like SBCL, have ASDF be implicitly used to require systems
     2805that are bundled with your Lisp distribution.
     2806If you do have a few magic systems that come with your implementation
     2807in a precompiled way such that one should only use the binary version
     2808that goes with your distribution, like SBCL does,
     2809then you should add them in the beginning of @code{wrapping-source-registry}.
     2810
     2811@item
     2812If you have magic systems as above, like SBCL does,
     2813then we explicitly ask you to @emph{NOT} distribute
     2814@file{asdf.asd} as part of those magic systems.
     2815You should still include the file @file{asdf.lisp} in your source distribution
     2816and precompile it in your binary distribution,
     2817but @file{asdf.asd} if included at all,
     2818should be secluded from the magic systems,
     2819in a separate file hierarchy,
     2820or you may otherwise rename the system and its file to e.g.
     2821@code{asdf-ecl} and @file{asdf-ecl.asd}, or
     2822@code{sb-asdf} and @file{sb-asdf.asd}.
     2823Indeed, if you made @file{asdf.asd} a magic system,
     2824then users would no longer be able to upgrade ASDF using ASDF itself
     2825to some version of their preference that
     2826they maintain independently from your Lisp distribution.
     2827
     2828@item
    27032829If you do not have any such magic systems, or have other non-magic systems
    27042830that you want to bundle with your implementation,
     
    27062832and you are welcome to include @file{asdf.asd} amongst them.
    27072833
    2708 Please send upstream any patches you make to ASDF itself,
     2834@item
     2835Please send us upstream any patches you make to ASDF itself,
    27092836so we can merge them back in for the benefit of your users
    27102837when they upgrade to the upstream version.
     2838
     2839@end itemize
     2840
    27112841
    27122842
     
    27732903@code{test-op} has been
    27742904a topic of considerable discussion on the
    2775 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
     2905@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
    27762906and on the
    2777 @uref{https://launchpad.net/asdf,launchpad bug-tracker}.
     2907@url{https://launchpad.net/asdf,launchpad bug-tracker}.
    27782908
    27792909Here are some guidelines:
  • branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java

    r12513 r12679  
    5151        {
    5252            AUTOLOADING_CACHE, // allow loading local preloaded functions
    53             Load._FASL_ANONYMOUS_PACKAGE_, // package for uninterned symbols
     53            Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols
    5454            Symbol._PACKAGE_,              // current package
    5555            Symbol.LOAD_TRUENAME           // LOAD-TIME-VALUE depends on this
  • branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java

    r12604 r12679  
    142142        {
    143143            LispThread thread = LispThread.currentThread();
    144             Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance());
    145             LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread);
    146             Debug.assertTrue(pkg != NIL);
    147             symbol = ((Package)pkg).intern(symbol.getName());
    148             symbol.setPackage(NIL);
    149             return symbol;
     144            return stream.readSymbol(FaslReadtable.getInstance());
    150145        }
    151146    };
     
    278273        @Override
    279274        public LispObject execute(Stream stream, char c, int n)
    280 
    281275        {
    282276            return stream.readCharacterLiteral(FaslReadtable.getInstance(),
     
    284278        }
    285279    };
     280
     281    // ### fasl-sharp-question-mark
     282    public static final DispatchMacroFunction FASL_SHARP_QUESTION_MARK =
     283        new DispatchMacroFunction("fasl-sharp-question-mark", PACKAGE_SYS,
     284                                  false, "stream sub-char numarg")
     285    {
     286        @Override
     287        public LispObject execute(Stream stream, char c, int n)
     288        {
     289            LispThread thread = LispThread.currentThread();
     290            LispObject uninternedSymbols =
     291                Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread);
     292
     293            if (! (uninternedSymbols instanceof Cons)) // it must be a vector
     294                return uninternedSymbols.AREF(n);
     295
     296            // During normal loading, we won't get to this bit, however,
     297            // with eval-when processing, we may need to fall back to
     298            // *FASL-UNINTERNED-SYMBOLS* being an alist structure
     299            LispObject label = LispInteger.getInstance(n);
     300            while (uninternedSymbols != NIL)
     301              {
     302                LispObject item = uninternedSymbols.car();
     303                if (label.eql(item.cdr()))
     304                  return item.car();
     305
     306                uninternedSymbols = uninternedSymbols.cdr();
     307              }
     308            return error(new LispError("No entry for uninterned symbol."));
     309        }
     310    };
     311
    286312}
  • branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java

    r12591 r12679  
    101101        dtfunctions[12]   = LispReader.SHARP_ILLEGAL; // page
    102102        dtfunctions[13]   = LispReader.SHARP_ILLEGAL; // return
     103        dtfunctions['?']  = FaslReader.FASL_SHARP_QUESTION_MARK;
    103104        dispatchTables.constants['#'] = dt;
    104105
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java

    r12672 r12679  
    5353
    5454    private static boolean noinit = false;
     55    private static boolean nosystem = false;
    5556    private static boolean noinform = false;
    5657
     
    9394        initializeLisp();
    9495        initializeTopLevel();
     96        if (!nosystem)
     97            initializeSystem();
    9598        if (!noinit)
    9699            processInitializationFile();
     
    118121        initializeJLisp();
    119122        initializeTopLevel();
     123        initializeSystem();
    120124        processInitializationFile();
    121125        return interpreter;
     
    212216    }
    213217
     218    private static synchronized void initializeSystem()
     219    {
     220        Load.loadSystemFile("system");
     221    }
     222
    214223    // Check for --noinit; verify that arguments are supplied for --load and
    215224    // --eval options.  Copy all unrecognized arguments into
     
    225234                if (arg.equals("--noinit")) {
    226235                    noinit = true;
     236                } else if (arg.equals("--nosystem")) {
     237                    nosystem = true;
    227238                } else if (arg.equals("--noinform")) {
    228239                    noinform = true;
     
    281292                            sb.append(c.getCondition().writeToString());
    282293                            sb.append(separator);
    283                             System.err.print(sb.toString());
    284           System.err.println("backtrace: ");
    285           evaluate("(princ (sys::backtrace))");
     294                            System.err.println(sb);
     295          //evaluate("(pprint (sys::backtrace))");
    286296                            System.exit(2);
    287297                        }
     
    466476            throws UnhandledCondition
    467477        {
    468             final Condition condition = (Condition) first;
     478            final LispObject condition = first;
    469479            if (interpreter == null) {
    470480                final LispThread thread = LispThread.currentThread();
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java

    r12561 r12679  
    116116    }
    117117
    118     // ### jclass name-or-class-ref => class-ref
     118    // ### jclass name-or-class-ref &optional class-loader => class-ref
    119119    private static final Primitive JCLASS = new pf_jclass();
    120120    private static final class pf_jclass extends Primitive
     
    122122        pf_jclass()
    123123        {
    124             super(Symbol.JCLASS, "name-or-class-ref",
    125                   "Returns a reference to the Java class designated by NAME-OR-CLASS-REF.");
     124            super(Symbol.JCLASS, "name-or-class-ref &optional class-loader",
     125                  "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader.");
    126126        }
    127127
     
    130130        {
    131131            return JavaObject.getInstance(javaClass(arg));
     132        }
     133
     134        @Override
     135        public LispObject execute(LispObject className, LispObject classLoader)
     136        {
     137      ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class);
     138      if(loader != null) {
     139    return JavaObject.getInstance(javaClass(className, loader));
     140      } else {
     141    return JavaObject.getInstance(javaClass(className));
     142      }
    132143        }
    133144    };
     
    11501161    }
    11511162   
    1152     static Class classForName(String className)
    1153     {
     1163    private static Class classForName(String className) {
     1164  return classForName(className, JavaClassLoader.getPersistentInstance());
     1165    }
     1166
     1167    private static Class classForName(String className, ClassLoader classLoader) {
    11541168        try {
    1155             return Class.forName(className);
     1169            return Class.forName(className, true, classLoader);
    11561170        }
    11571171        catch (ClassNotFoundException e) {
    1158             try {
    1159                 return Class.forName(className, true, JavaClassLoader.getPersistentInstance());
    1160             }
    1161             catch (ClassNotFoundException ex) {
    1162                 error(new LispError("Class not found: " + className));
    1163                 // Not reached.
    1164                 return null;
    1165             }
    1166         }
     1172      error(new LispError("Class not found: " + className));
     1173      // Not reached.
     1174      return null;
     1175        }
     1176    }
     1177
     1178    private static Class javaClass(LispObject obj) {
     1179  return javaClass(obj, null);
    11671180    }
    11681181
    11691182    // Supports Java primitive types too.
    1170     static Class javaClass(LispObject obj)
     1183    static Class javaClass(LispObject obj, ClassLoader classLoader)
    11711184    {
    11721185        if (obj instanceof AbstractString || obj instanceof Symbol) {
     
    11891202                return Double.TYPE;
    11901203            // Not a primitive Java type.
    1191             Class c = classForName(s);
     1204            Class c;
     1205      if(classLoader != null) {
     1206    c = classForName(s, classLoader);
     1207      } else {
     1208    c = classForName(s);
     1209      }
    11921210            if (c == null)
    11931211                error(new LispError(s + " does not designate a Java class."));
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java

    r12672 r12679  
    352352
    353353  public static final LispObject error(LispObject condition)
    354 
    355354  {
    356355    pushJavaStackFrames();
     
    358357  }
    359358
     359  public static final int ierror(LispObject condition)
     360  {
     361    error(condition);
     362    return 0; // Not reached
     363  }
     364
     365  public static final String serror(LispObject condition)
     366  {
     367    error(condition);
     368    return ""; // Not reached
     369  }
     370
     371
    360372  public static final LispObject error(LispObject condition, LispObject message)
    361 
    362373  {
    363374    pushJavaStackFrames();
    364375    return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message);
    365376  }
     377
     378  public static final int ierror(LispObject condition, LispObject message)
     379  {
     380    error(condition, message);
     381    return 0; // Not reached
     382  }
     383
     384  public static final String serror(LispObject condition, LispObject message)
     385  {
     386    error(condition, message);
     387    return ""; // Not reached
     388  }
     389
     390
    366391
    367392  public static final LispObject type_error(LispObject datum,
  • branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java

    r12598 r12679  
    720720  }
    721721
    722   public String unreadableString(String s) {
     722  public final String unreadableString(String s) {
    723723     return unreadableString(s, true);
    724724  }
    725   public String unreadableString(Symbol sym) {
     725  public final String unreadableString(Symbol sym) {
    726726     return unreadableString(sym, true);
    727727  }
    728728
    729   public String unreadableString(String s, boolean identity)
     729  public final String unreadableString(String s, boolean identity)
    730730  {
    731731    StringBuilder sb = new StringBuilder("#<");
     
    740740  }
    741741
    742   public String unreadableString(Symbol symbol, boolean identity)
     742  public final String unreadableString(Symbol symbol, boolean identity)
    743743
    744744  {
  • branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java

    r12604 r12679  
    4747
    4848        {
    49           try 
     49          try
    5050            {
    5151              while (true) {
    5252                int n = stream._readChar();
    5353                if (n < 0)
    54                   return null;
     54                  return LispThread.currentThread().setValues();
    5555                if (n == '\n')
    56                   return null;
     56                  return LispThread.currentThread().setValues();
    5757              }
    5858            }
    5959          catch (java.io.IOException e)
    6060            {
    61               return null;
     61                return LispThread.currentThread().setValues();
    6262            }
    6363        }
     
    329329        {
    330330            stream.skipBalancedComment();
    331             return null;
     331            return LispThread.currentThread().setValues();
    332332        }
    333333    };
  • branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java

    r12587 r12679  
    4949       new ConcurrentHashMap<Thread,LispThread>();
    5050
     51    LispObject threadValue = NIL;
     52
    5153    private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){
    5254        @Override
     
    8890            {
    8991                try {
    90                     funcall(wrapper,
     92                    threadValue = funcall(wrapper,
    9193                            new LispObject[] { fun },
    9294                            LispThread.this);
     
    931933    };
    932934
     935    private static final Primitive THREAD_JOIN =
     936        new Primitive("thread-join", PACKAGE_THREADS, true, "thread",
     937                      "Waits for thread to finish.")
     938    {
     939        @Override
     940        public LispObject execute(LispObject arg)
     941        {
     942            // join the thread, and returns it's value.  The second return
     943            // value is T if the thread finishes normally, NIL if its
     944            // interrupted.
     945            if (arg instanceof LispThread) {               
     946                final LispThread joinedThread = (LispThread) arg;
     947                final LispThread waitingThread = currentThread();
     948                try {
     949                    joinedThread.javaThread.join();
     950                    return
     951                        waitingThread.setValues(joinedThread.threadValue, T);
     952                } catch (InterruptedException e) {
     953                    waitingThread.processThreadInterrupts();
     954                    return
     955                        waitingThread.setValues(joinedThread.threadValue, NIL);
     956                }
     957            } else {
     958                return type_error(arg, Symbol.THREAD);
     959            }
     960        }
     961    };
     962
     963
    933964    public static final long javaSleepInterval(LispObject lispSleep)
    934965
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java

    r12672 r12679  
    8585            LispObject abcl = Pathname.truename(abclPathname, false);
    8686            if (lisp instanceof Pathname && abcl instanceof Pathname) {
    87                 lispPathname = (Pathname)lisp;
    88                 abclPathname = (Pathname)abcl;
    89                 long lispLastModified = lispPathname.getLastModified();
    90                 long abclLastModified = abclPathname.getLastModified();
     87              lispPathname = (Pathname)lisp;
     88              abclPathname = (Pathname)abcl;
     89              long lispLastModified = lispPathname.getLastModified();
     90              long abclLastModified = abclPathname.getLastModified();
    9191              if (abclLastModified > lispLastModified) {
     92                  return abclPathname;  // fasl file is newer
     93              } else {
    9294                  return lispPathname;
    93               } else {
    94                   return abclPathname;
    9595              }
    9696            } else if (abcl instanceof Pathname) {
     
    364364    // internal symbol
    365365    static final Symbol _FASL_VERSION_ =
    366         exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(35));
     366        exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36));
    367367
    368368    // ### *fasl-external-format*
     
    372372                       new SimpleString("UTF-8"));
    373373
    374     // ### *fasl-anonymous-package*
     374    // ### *fasl-uninterned-symbols*
    375375    // internal symbol
    376376    /**
    377      * This variable gets bound to a package with no name in which the
    378      * reader can intern its uninterned symbols.
     377     * This variable gets bound to NIL upon loading a FASL, but
     378     * gets set to a vector of symbols as one of the first actions
     379     * by the FASL itself.
    379380     *
    380381     */
    381     public static final Symbol _FASL_ANONYMOUS_PACKAGE_ =
    382         internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL);
     382    public static final Symbol _FASL_UNINTERNED_SYMBOLS_ =
     383        internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL);
    383384
    384385    // ### init-fasl &key version
     
    396397                    // OK
    397398                    final LispThread thread = LispThread.currentThread();
    398                     thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL);
     399                    thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL);
    399400                    thread.bindSpecial(_SOURCE_, NIL);
    400401                    return faslLoadStream(thread);
     
    412413                                                       boolean auto)
    413414        {
    414             return loadFileFromStream(pathname == null ? NIL : pathname, 
    415                                       truename == null ? NIL : truename, 
     415            return loadFileFromStream(pathname == null ? NIL : pathname,
     416                                      truename == null ? NIL : truename,
    416417                                      in, verbose, print, auto, false);
    417418    }
     
    586587        LispObject result = NIL;
    587588        try {
    588             thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package());
    589589            thread.bindSpecial(AUTOLOADING_CACHE,
    590590                               AutoloadedFunctionProxy.makePreloadingContext());
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java

    r12617 r12679  
    346346            String scheme = url.getProtocol();
    347347            if (scheme.equals("file")) {
    348                 Pathname p = new Pathname(s);
     348                Pathname p = new Pathname(url.getFile());
    349349                this.host = p.host;
    350350                this.device = p.device;
     
    681681            if (type instanceof AbstractString) {
    682682                String t = type.getStringValue();
    683                 if (t.indexOf('.') >= 0) {
    684                     Debug.assertTrue(namestring == null);
    685                     return null;
    686                 }
     683    // Allow Windows shortcuts to include TYPE
     684    if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) {
     685        if (t.indexOf('.') >= 0) {
     686      Debug.assertTrue(namestring == null);
     687      return null;
     688        }
     689    }
    687690                sb.append(t);
    688691            } else if (type == Keyword.WILD) {
     
    738741        if (directory != NIL) {
    739742            final char separatorChar;
    740             if (device instanceof Cons) {
    741                 separatorChar = '/'; // Jar file.
     743            if (isJar() || isURL()) {
     744                separatorChar = '/';
    742745            } else {
    743746                separatorChar = File.separatorChar;
     
    16701673                return true;
    16711674            }
     1675            Cons d = (Cons) directory;
     1676            while (true) {
     1677                if (d.car() instanceof AbstractString) {
     1678                    String s = d.car().writeToString();
     1679                    if (s.contains("*")) {
     1680                        return true;
     1681                    }
     1682                }
     1683                if (d.cdr() == NIL || ! (d.cdr() instanceof Cons)) {
     1684                    break;
     1685                }
     1686                d = (Cons)d.cdr();
     1687            }
    16721688        }
    16731689        if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) {
    16741690            return true;
    16751691        }
     1692        if (name instanceof AbstractString) {
     1693            if (name.writeToString().contains("*")) {
     1694                return true;
     1695            }
     1696        }
    16761697        if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) {
    16771698            return true;
     1699        }
     1700        if (type instanceof AbstractString) {
     1701            if (type.writeToString().contains("*")) {
     1702                return true;
     1703            }
    16781704        }
    16791705        if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) {
     
    17931819            result.device = p.device;
    17941820        } else {
    1795             result.device = d.device;
     1821            if (!p.isURL()) {
     1822                result.device = d.device;
     1823            }
    17961824        }
    17971825
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java

    r12604 r12679  
    482482                if (rt.isWhitespace(c))
    483483                    continue;
    484                 LispObject result = processChar(c, rt);
     484                LispObject result = processChar(thread, c, rt);
    485485                if (result != null)
    486486                    return result;
     
    498498    }
    499499
    500     private final LispObject processChar(char c, Readtable rt)
    501 
     500    /** Dispatch macro function if 'c' has one associated,
     501     * read a token otherwise.
     502     *
     503     * When the macro function returns zero values, this function
     504     * returns null or the token or returned value otherwise.
     505     */
     506    private final LispObject processChar(LispThread thread,
     507                                         char c, Readtable rt)
    502508    {
    503509        final LispObject handler = rt.getReaderMacroFunction(c);
    504         if (handler instanceof ReaderMacroFunction)
    505             return ((ReaderMacroFunction)handler).execute(this, c);
    506         if (handler != null && handler != NIL)
    507             return handler.execute(this, LispCharacter.getInstance(c));
    508         return readToken(c, rt);
     510        LispObject value;
     511
     512        if (handler instanceof ReaderMacroFunction) {
     513            thread._values = null;
     514            value = ((ReaderMacroFunction)handler).execute(this, c);
     515        }
     516        else if (handler != null && handler != NIL) {
     517            thread._values = null;
     518            value = handler.execute(this, LispCharacter.getInstance(c));
     519        }
     520        else
     521            return readToken(c, rt);
     522
     523        // If we're looking at zero return values, set 'value' to null
     524        if (value == NIL) {
     525            LispObject[] values = thread._values;
     526            if (values != null && values.length == 0)
     527                value = null;
     528        }
     529        return value;
    509530    }
    510531
     
    584605        while (true) {
    585606          int n = _readChar();
    586           if (n < 0) {
    587             error(new EndOfFile(this));
    588             // Not reached.
    589             return null;
    590           }
     607          if (n < 0)
     608            return error(new EndOfFile(this));
     609
    591610          char c = (char) n; // ### BUG: Codepoint conversion
    592611          if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) {
    593612            // Single escape.
    594613            n = _readChar();
    595             if (n < 0) {
    596               error(new EndOfFile(this));
    597               // Not reached.
    598               return null;
    599             }
     614            if (n < 0)
     615              return error(new EndOfFile(this));
     616
    600617            sb.append((char)n); // ### BUG: Codepoint conversion
    601618            continue;
     
    658675                    _unreadChar(nextChar);
    659676                }
    660                 LispObject obj = processChar(c, rt);
    661                 if (obj == null) {
    662                     // A comment.
     677
     678                LispObject obj = processChar(thread, c, rt);
     679                if (obj == null)
    663680                    continue;
    664                 }
     681
     682
    665683                if (first == null) {
    666684                    first = new Cons(obj);
     
    949967            while (true) {
    950968                int n = _readChar();
    951                 if (n < 0) {
    952                     error(new EndOfFile(this));
    953                     // Not reached.
    954                     return null;
    955                 }
     969                if (n < 0)
     970                    return serror(new EndOfFile(this));
     971
    956972                char c = (char) n; // ### BUG: Codepoint conversion
    957973                byte syntaxType = rt.getSyntaxType(c);
    958974                if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) {
    959975                    n = _readChar();
    960                     if (n < 0) {
    961                         error(new EndOfFile(this));
    962                         // Not reached.
    963                         return null;
    964                     }
     976                    if (n < 0)
     977                        return serror(new EndOfFile(this));
     978
    965979                    sb.append((char)n); // ### BUG: Codepoint conversion
    966980                    continue;
     
    971985            }
    972986        } catch (IOException e) {
    973             error(new StreamError(this, e));
     987            return serror(new StreamError(this, e));
    974988        }
    975989        return sb.toString();
     
    11151129                if (n < 0) {
    11161130                    error(new EndOfFile(this));
    1117                     // Not reached.
    1118                     return flags;
    1119                 }
     1131                    return null; // Not reached
     1132                }
     1133
    11201134                sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion
    11211135                flags = new BitSet(1);
     
    12311245        if (readBaseObject instanceof Fixnum) {
    12321246            readBase = ((Fixnum)readBaseObject).value;
    1233         } else {
     1247        } else
    12341248            // The value of *READ-BASE* is not a Fixnum.
    1235             error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36)."));
    1236             // Not reached.
    1237             return 10;
    1238         }
    1239         if (readBase < 2 || readBase > 36) {
    1240             error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36)."));
    1241             // Not reached.
    1242             return 10;
    1243         }
     1249            return ierror(new LispError("The value of *READ-BASE* is not " +
     1250                                        "of type '(INTEGER 2 36)."));
     1251
     1252        if (readBase < 2 || readBase > 36)
     1253            return ierror(new LispError("The value of *READ-BASE* is not " +
     1254                                        "of type '(INTEGER 2 36)."));
     1255
    12441256        return readBase;
    12451257    }
    12461258
    12471259    private final LispObject makeNumber(String token, int length, int radix)
    1248 
    12491260    {
    12501261        if (length == 0)
     
    14151426            while (true) {
    14161427                int n = _readChar();
    1417                 if (n < 0) {
    1418                     error(new EndOfFile(this));
    1419                     // Not reached.
    1420                     return 0;
    1421                 }
     1428                if (n < 0)
     1429                    return (char)ierror(new EndOfFile(this));
     1430
    14221431                char c = (char) n; // ### BUG: Codepoint conversion
    14231432                if (!rt.isWhitespace(c))
     
    14401449            if (c == delimiter)
    14411450                break;
    1442             LispObject obj = processChar(c, rt);
     1451
     1452            LispObject obj = processChar(thread, c, rt);
    14431453            if (obj != null)
    14441454                result = new Cons(obj, result);
     
    18401850            return n; // Reads an 8-bit byte.
    18411851        } catch (IOException e) {
    1842             error(new StreamError(this, e));
    1843             // Not reached.
    1844             return -1;
     1852            return ierror(new StreamError(this, e));
    18451853        }
    18461854    }
  • branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java

    r12522 r12679  
    4242  public static String getVersion()
    4343  {
    44     return "0.20.0-dev";
     44    return "0.21.0-dev";
    4545  }
    4646 
  • branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java

    r12612 r12679  
    183183            if (url.getProtocol().equals("file")) {
    184184                entry = new Entry();
    185                 File f = new File(url.getPath());
     185                String path = url.getPath();
     186
     187                if (Utilities.isPlatformWindows) {
     188                    String authority = url.getAuthority();
     189                    if (authority != null) {
     190                        path = authority + path;
     191                    }
     192                }
     193                File f = new File(path);
    186194                entry.lastModified = f.lastModified();
    187195                try {
  • branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp

    r12618 r12679  
    5050(cl:in-package :cl-user)
    5151
    52 (declaim (optimize (speed 2) (debug 2) (safety 3)))
    53 
    54 #+ecl (require 'cmp)
     52(declaim (optimize (speed 2) (debug 2) (safety 3))
     53         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
     54
     55#+ecl (require :cmp)
    5556
    5657;;;; Create packages in a way that is compatible with hot-upgrade.
     
    5859;;;; See more at the end of the file.
    5960
     61#+gcl
     62(eval-when (:compile-toplevel :load-toplevel)
     63  (defpackage :asdf-utilities (:use :cl))
     64  (defpackage :asdf (:use :cl :asdf-utilities)))
     65
    6066(eval-when (:load-toplevel :compile-toplevel :execute)
     67  #+allegro
     68  (setf excl::*autoload-package-name-alist*
     69        (remove "asdf" excl::*autoload-package-name-alist*
     70                :test 'equalp :key 'car))
    6171  (let* ((asdf-version
    62           ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
    63           (subseq "VERSION:1.679" (1+ (length "VERSION"))))
    64          #+allegro (excl::*autoload-package-name-alist* nil)
     72          ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:1.719" (1+ (length "VERSION"))))
    6574         (existing-asdf (find-package :asdf))
    66          (versym '#:*asdf-version*)
    67          (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
    68          (redefined-functions
    69           '(#:perform #:explain #:output-files #:operation-done-p
     75         (vername '#:*asdf-version*)
     76         (versym (and existing-asdf
     77                      (find-symbol (string vername) existing-asdf)))
     78         (existing-version (and versym (boundp versym) (symbol-value versym)))
     79         (already-there (equal asdf-version existing-version)))
     80    (unless (and existing-asdf already-there)
     81      #-gcl
     82      (when existing-asdf
     83        (format *error-output*
     84                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
     85                existing-version asdf-version))
     86      (labels
     87          ((rename-away (package)
     88             (loop :with name = (package-name package)
     89               :for i :from 1 :for new = (format nil "~A.~D" name i)
     90               :unless (find-package new) :do
     91               (rename-package-name package name new)))
     92           (rename-package-name (package old new)
     93             (let* ((old-names (cons (package-name package)
     94                                     (package-nicknames package)))
     95                    (new-names (subst new old old-names :test 'equal))
     96                    (new-name (car new-names))
     97                    (new-nicknames (cdr new-names)))
     98               (rename-package package new-name new-nicknames)))
     99           (ensure-exists (name nicknames use)
     100             (let* ((previous
     101                     (remove-duplicates
     102                      (remove-if
     103                       #'null
     104                       (mapcar #'find-package (cons name nicknames)))
     105                      :from-end t)))
     106               (cond
     107                 (previous
     108                  ;; do away with packages with conflicting (nick)names
     109                  (map () #'rename-away (cdr previous))
     110                  ;; reuse previous package with same name
     111                  (let ((p (car previous)))
     112                    (rename-package p name nicknames)
     113                    (ensure-use p use)
     114                    p))
     115                 (t
     116                  (make-package name :nicknames nicknames :use use)))))
     117           (find-sym (symbol package)
     118             (find-symbol (string symbol) package))
     119           (intern* (symbol package)
     120             (intern (string symbol) package))
     121           (remove-symbol (symbol package)
     122             (let ((sym (find-sym symbol package)))
     123               (when sym
     124                 (unexport sym package)
     125                 (unintern sym package))))
     126           (ensure-unintern (package symbols)
     127             (dolist (sym symbols) (remove-symbol sym package)))
     128           (ensure-shadow (package symbols)
     129             (shadow symbols package))
     130           (ensure-use (package use)
     131             (dolist (used (reverse use))
     132               (do-external-symbols (sym used)
     133                 (unless (eq sym (find-sym sym package))
     134                   (remove-symbol sym package)))
     135               (use-package used package)))
     136           (ensure-fmakunbound (package symbols)
     137             (loop :for name :in symbols
     138               :for sym = (find-sym name package)
     139               :when sym :do (fmakunbound sym)))
     140           (ensure-export (package export)
     141             (let ((syms (loop :for x :in export :collect
     142                           (intern* x package))))
     143               (do-external-symbols (sym package)
     144                 (unless (member sym syms)
     145                   (remove-symbol sym package)))
     146               (dolist (sym syms)
     147                 (export sym package))))
     148           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     149             (let ((p (ensure-exists name nicknames use)))
     150               (ensure-unintern p unintern)
     151               (ensure-shadow p shadow)
     152               (ensure-export p export)
     153               (ensure-fmakunbound p fmakunbound)
     154               p)))
     155        (macrolet
     156            ((pkgdcl (name &key nicknames use export
     157                           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))))
     165          (pkgdcl
     166           :asdf-utilities
     167           :nicknames (#:asdf-extensions)
     168           :use (#:common-lisp)
     169           :unintern (#:split #:make-collector)
     170           :export
     171           (#:absolute-pathname-p
     172            #:aif
     173            #:appendf
     174            #:asdf-message
     175            #:coerce-name
     176            #:directory-pathname-p
     177            #:ends-with
     178            #:ensure-directory-pathname
     179            #:getenv
     180            #:get-uid
     181            #:length=n-p
     182            #:merge-pathnames*
     183            #:pathname-directory-pathname
     184            #:read-file-forms
     185            #:remove-keys
     186            #:remove-keyword
     187            #:resolve-symlinks
     188            #:split-string
     189            #:component-name-to-pathname-components
     190            #:split-name-type
     191            #:system-registered-p
     192            #:truenamize
     193            #:while-collecting))
     194          (pkgdcl
     195           :asdf
     196           :use (:common-lisp :asdf-utilities)
     197           :redefined-functions
     198           (#:perform #:explain #:output-files #:operation-done-p
    70199            #:perform-with-restarts #:component-relative-pathname
    71             #:system-source-file)))
    72     (unless (equal asdf-version existing-version)
    73       (labels ((rename-away (package)
    74                  (loop :with name = (package-name package)
    75                    :for i :from 1 :for new = (format nil "~A.~D" name i)
    76                    :unless (find-package new) :do
    77                    (rename-package-name package name new)))
    78                (rename-package-name (package old new)
    79                  (let* ((old-names (cons (package-name package) (package-nicknames package)))
    80                         (new-names (subst new old old-names :test 'equal))
    81                         (new-name (car new-names))
    82                         (new-nicknames (cdr new-names)))
    83                    (rename-package package new-name new-nicknames)))
    84                (ensure-exists (name nicknames use)
    85                  (let* ((previous
    86                          (remove-duplicates
    87                           (remove-if
    88                            #'null
    89                            (mapcar #'find-package (cons name nicknames)))
    90                           :from-end t)))
    91                    (cond
    92                      (previous
    93                       (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
    94                       (let ((p (car previous))) ;; previous package with same name
    95                         (rename-package p name nicknames)
    96                         (ensure-use p use)
    97                         p))
    98                      (t
    99                       (make-package name :nicknames nicknames :use use)))))
    100                (find-sym (symbol package)
    101                  (find-symbol (string symbol) package))
    102                (remove-symbol (symbol package)
    103                  (let ((sym (find-sym symbol package)))
    104                    (when sym
    105                      (unexport sym package)
    106                      (unintern sym package))))
    107                (ensure-unintern (package symbols)
    108                  (dolist (sym symbols) (remove-symbol sym package)))
    109                (ensure-shadow (package symbols)
    110                  (shadow symbols package))
    111                (ensure-use (package use)
    112                  (dolist (used (reverse use))
    113                    (do-external-symbols (sym used)
    114                      (unless (eq sym (find-sym sym package))
    115                        (remove-symbol sym package)))
    116                    (use-package used package)))
    117                (ensure-fmakunbound (package symbols)
    118                  (loop :for name :in symbols
    119                    :for sym = (find-sym name package)
    120                    :when sym :do (fmakunbound sym)))
    121                (ensure-export (package export)
    122                  (let ((syms (loop :for x :in export :collect
    123                                (intern (string x) package))))
    124                    (do-external-symbols (sym package)
    125                      (unless (member sym syms)
    126                        (remove-symbol sym package)))
    127                    (dolist (sym syms)
    128                      (export sym package))))
    129                (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
    130                  (let ((p (ensure-exists name nicknames use)))
    131                    (ensure-unintern p unintern)
    132                    (ensure-shadow p shadow)
    133                    (ensure-export p export)
    134                    (ensure-fmakunbound p fmakunbound)
    135                    p)))
    136         (ensure-package
    137          ':asdf-utilities
    138          :nicknames '(#:asdf-extensions)
    139          :use '(#:common-lisp)
    140          :unintern '(#:split #:make-collector)
    141          :export
    142          '(#:absolute-pathname-p
    143            #:aif
    144            #:appendf
    145            #:asdf-message
    146            #:coerce-name
    147            #:directory-pathname-p
    148            #:ends-with
    149            #:ensure-directory-pathname
    150            #:getenv
    151            #:get-uid
    152            #:length=n-p
    153            #:merge-pathnames*
    154            #:pathname-directory-pathname
    155            #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
    156            #:read-file-forms
    157            #:remove-keys
    158            #:remove-keyword
    159            #:resolve-symlinks
    160            #:split-string
    161            #:component-name-to-pathname-components
    162            #:split-name-type
    163            #:system-registered-p
    164            #:truenamize
    165            #:while-collecting))
    166         (ensure-package
    167          ':asdf
    168          :use '(:common-lisp :asdf-utilities)
    169          :unintern `(#-ecl ,@redefined-functions
    170                            #:*asdf-revision* #:around #:asdf-method-combination
    171                            #:split #:make-collector)
    172          :fmakunbound `(#+ecl ,@redefined-functions
    173                               #:system-source-file
    174                               #:component-relative-pathname #:system-relative-pathname
    175                               #:process-source-registry
    176                               #:inherit-source-registry #:process-source-registry-directive)
    177          :export
    178          '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
    179            #:system-definition-pathname #:find-component ; miscellaneous
    180            #:compile-system #:load-system #:test-system
    181            #:compile-op #:load-op #:load-source-op
    182            #:test-op
    183            #:operation               ; operations
    184            #:feature                 ; sort-of operation
    185            #:version                 ; metaphorically sort-of an operation
    186            #:version-satisfies
    187 
    188            #:input-files #:output-files #:perform ; operation methods
    189            #:operation-done-p #:explain
    190 
    191            #:component #:source-file
    192            #:c-source-file #:cl-source-file #:java-source-file
    193            #:static-file
    194            #:doc-file
    195            #:html-file
    196            #:text-file
    197            #:source-file-type
    198            #:module                     ; components
    199            #:system
    200            #:unix-dso
    201 
    202            #:module-components          ; component accessors
    203            #:component-pathname
    204            #:component-relative-pathname
    205            #:component-name
    206            #:component-version
    207            #:component-parent
    208            #:component-property
    209            #:component-system
    210 
    211            #:component-depends-on
    212 
    213            #:system-description
    214            #:system-long-description
    215            #:system-author
    216            #:system-maintainer
    217            #:system-license
    218            #:system-licence
    219            #:system-source-file
    220            #:system-source-directory
    221            #:system-relative-pathname
    222            #:map-systems
    223 
    224            #:operation-on-warnings
    225            #:operation-on-failure
    226                                         ;#:*component-parent-pathname*
    227            #:*system-definition-search-functions*
    228            #:*central-registry*         ; variables
    229            #:*compile-file-warnings-behaviour*
    230            #:*compile-file-failure-behaviour*
    231            #:*resolve-symlinks*
    232 
    233            #:asdf-version
    234 
    235            #:operation-error #:compile-failed #:compile-warned #:compile-error
    236            #:error-name
    237            #:error-pathname
    238            #:load-system-definition-error
    239            #:error-component #:error-operation
    240            #:system-definition-error
    241            #:missing-component
    242            #:missing-component-of-version
    243            #:missing-dependency
    244            #:missing-dependency-of-version
    245            #:circular-dependency        ; errors
    246            #:duplicate-names
    247 
    248            #:try-recompiling
    249            #:retry
    250            #:accept                     ; restarts
    251            #:coerce-entry-to-directory
    252            #:remove-entry-from-registry
    253 
    254            #:initialize-output-translations
    255            #:disable-output-translations
    256            #:clear-output-translations
    257            #:ensure-output-translations
    258            #:apply-output-translations
    259            #:compile-file-pathname*
    260            #:enable-asdf-binary-locations-compatibility
    261 
    262            #:*default-source-registries*
    263            #:initialize-source-registry
    264            #:compute-source-registry
    265            #:clear-source-registry
    266            #:ensure-source-registry
    267            #:process-source-registry))
    268         (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
    269 
    270 (in-package #:asdf)
     200            #:system-source-file #:operate #:find-component)
     201           :unintern
     202           (#:*asdf-revision* #:around #:asdf-method-combination
     203            #:split #:make-collector)
     204           :fmakunbound
     205           (#:system-source-file
     206            #:component-relative-pathname #:system-relative-pathname
     207            #:process-source-registry
     208            #:inherit-source-registry #:process-source-registry-directive)
     209           :export
     210           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     211            #:system-definition-pathname #:find-component ; miscellaneous
     212            #:compile-system #:load-system #:test-system
     213            #:compile-op #:load-op #:load-source-op
     214            #:test-op
     215            #:operation               ; operations
     216            #:feature                 ; sort-of operation
     217            #:version                 ; metaphorically sort-of an operation
     218            #:version-satisfies
     219
     220            #:input-files #:output-files #:perform ; operation methods
     221            #:operation-done-p #:explain
     222
     223            #:component #:source-file
     224            #:c-source-file #:cl-source-file #:java-source-file
     225            #:static-file
     226            #:doc-file
     227            #:html-file
     228            #:text-file
     229            #:source-file-type
     230            #:module                     ; components
     231            #:system
     232            #:unix-dso
     233
     234            #:module-components          ; component accessors
     235            #:module-components-by-name  ; component accessors
     236            #:component-pathname
     237            #:component-relative-pathname
     238            #:component-name
     239            #:component-version
     240            #:component-parent
     241            #:component-property
     242            #:component-system
     243
     244            #:component-depends-on
     245
     246            #:system-description
     247            #:system-long-description
     248            #:system-author
     249            #:system-maintainer
     250            #:system-license
     251            #:system-licence
     252            #:system-source-file
     253            #:system-source-directory
     254            #:system-relative-pathname
     255            #:map-systems
     256
     257            #:operation-on-warnings
     258            #:operation-on-failure
     259            ;;#:*component-parent-pathname*
     260            #:*system-definition-search-functions*
     261            #:*central-registry*         ; variables
     262            #:*compile-file-warnings-behaviour*
     263            #:*compile-file-failure-behaviour*
     264            #:*resolve-symlinks*
     265            #:*asdf-verbose*
     266
     267            #:asdf-version
     268
     269            #:operation-error #:compile-failed #:compile-warned #:compile-error
     270            #:error-name
     271            #:error-pathname
     272            #:load-system-definition-error
     273            #:error-component #:error-operation
     274            #:system-definition-error
     275            #:missing-component
     276            #:missing-component-of-version
     277            #:missing-dependency
     278            #:missing-dependency-of-version
     279            #:circular-dependency        ; errors
     280            #:duplicate-names
     281
     282            #:try-recompiling
     283            #:retry
     284            #:accept                     ; restarts
     285            #:coerce-entry-to-directory
     286            #:remove-entry-from-registry
     287
     288            #:initialize-output-translations
     289            #:disable-output-translations
     290            #:clear-output-translations
     291            #:ensure-output-translations
     292            #:apply-output-translations
     293            #:compile-file-pathname*
     294            #:enable-asdf-binary-locations-compatibility
     295
     296            #:*default-source-registries*
     297            #:initialize-source-registry
     298            #:compute-source-registry
     299            #:clear-source-registry
     300            #:ensure-source-registry
     301            #:process-source-registry)))
     302        (let* ((version (intern* vername :asdf))
     303               (upvar (intern* '#:*upgraded-p* :asdf))
     304               (upval0 (and (boundp upvar) (symbol-value upvar)))
     305               (upval1 (if existing-version (cons existing-version upval0) upval0)))
     306          (eval `(progn
     307                   (defparameter ,version ,asdf-version)
     308                   (defparameter ,upvar ',upval1))))))))
     309
     310(in-package :asdf)
     311
     312;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
     313#+gcl
     314(eval-when (:compile-toplevel :load-toplevel)
     315  (defvar *asdf-version* nil)
     316  (defvar *upgraded-p* nil))
     317(when *upgraded-p*
     318   #+ecl
     319   (when (find-class 'compile-op nil)
     320     (defmethod update-instance-for-redefined-class :after
     321         ((c compile-op) added deleted plist &key)
     322       (declare (ignore added deleted))
     323       (let ((system-p (getf plist 'system-p)))
     324         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
     325   (when (find-class 'module nil)
     326     (eval
     327      '(defmethod update-instance-for-redefined-class :after
     328           ((m module) added deleted plist &key)
     329         (declare (ignorable deleted plist))
     330         (when (member 'components-by-name added)
     331           (compute-module-components-by-name m))))))
    271332
    272333;;;; -------------------------------------------------------------------------
     
    276337  "Exported interface to the version of ASDF currently installed. A string.
    277338You can compare this string with e.g.:
    278 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
     339(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
    279340  *asdf-version*)
    280341
     
    289350
    290351(defvar *verbose-out* nil)
     352
     353(defvar *asdf-verbose* t)
    291354
    292355(defparameter +asdf-methods+
     
    302365
    303366;;;; -------------------------------------------------------------------------
    304 ;;;; Cleanups before hot-upgrade.
    305 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
    306 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    307 ;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
    308 ;;;;   for each of the classes we define that has changed incompatibly.
    309 (eval-when (:compile-toplevel :load-toplevel :execute)
    310   #+ecl
    311   (when (find-class 'compile-op nil)
    312     (defmethod update-instance-for-redefined-class :after
    313         ((c compile-op) added deleted plist &key)
    314       (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
    315       (let ((system-p (getf plist 'system-p)))
    316         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
    317 
    318 ;;;; -------------------------------------------------------------------------
    319367;;;; ASDF Interface, in terms of generic functions.
    320368
     
    325373(defgeneric output-files (operation component))
    326374(defgeneric input-files (operation component))
     375(defgeneric component-operation-time (operation component))
    327376
    328377(defgeneric system-source-file (system)
     
    348397(defgeneric version-satisfies (component version))
    349398
    350 (defgeneric find-component (module name &optional version)
    351   (:documentation "Finds the component with name NAME present in the
    352 MODULE module; if MODULE is nil, then the component is assumed to be a
    353 system."))
     399(defgeneric find-component (base path)
     400  (:documentation "Finds the component with PATH starting from BASE module;
     401if BASE is nil, then the component is assumed to be a system."))
    354402
    355403(defgeneric source-file-type (component system))
     
    366414of which is a computed key, so not interesting.  The
    367415CDR wil be the DATA value stored by VISIT-COMPONENT; recover
    368 it as \(cdr \(component-visited-p op c\)\).
     416it as (cdr (component-visited-p op c)).
    369417  In the current form of ASDF, the DATA value retrieved is
    370418effectively a boolean, indicating whether some operations are
     
    422470        (initial-values (mapcar (constantly nil) collectors)))
    423471    `(let ,(mapcar #'list vars initial-values)
    424        (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
     472       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
    425473         ,@body
    426          (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))
     474         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    427475
    428476(defmacro aif (test then &optional else)
    429477  `(let ((it ,test)) (if it ,then ,else)))
    430 
    431 (defun pathname-sans-name+type (pathname)
    432   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    433 and NIL NAME and TYPE components.
    434 Issue: doesn't override the VERSION component.
    435 
    436 Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
    437   (make-pathname :name nil :type nil :defaults pathname))
    438478
    439479(defun pathname-directory-pathname (pathname)
     
    463503               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    464504      (multiple-value-bind (host device directory unspecific-handler)
    465           (ecase (first directory)
     505          (#-gcl ecase #+gcl case (first directory)
    466506            ((nil)
    467507             (values (pathname-host defaults)
     
    477517             (values (pathname-host defaults)
    478518                     (pathname-device defaults)
    479                      (append (pathname-directory defaults) (cdr directory))
     519                     (if (null (pathname-directory defaults))
     520                         directory
     521                         (append (pathname-directory defaults) (cdr directory)))
     522                     (unspecific-handler defaults)))
     523            #+gcl
     524            (t
     525             (assert (stringp (first directory)))
     526             (values (pathname-host defaults)
     527                     (pathname-device defaults)
     528                     (append (pathname-directory defaults) directory)
    480529                     (unspecific-handler defaults))))
    481530        (make-pathname :host host :device device :directory directory
     
    485534
    486535(define-modify-macro appendf (&rest args)
    487   append "Append onto list")
     536  append "Append onto list") ;; only to be used on short lists.
     537
     538(define-modify-macro orf (&rest args)
     539  or "or a flag")
    488540
    489541(defun asdf-message (format-string &rest format-args)
     
    516568         ;; See CLHS make-pathname and 19.2.2.2.3.
    517569         ;; We only use it on implementations that support it.
    518          (or #+(or sbcl ccl ecl lispworks) :unspecific)))
     570         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
    519571    (destructuring-bind (name &optional (type unspecific))
    520572        (split-string filename :max 2 :separator ".")
     
    650702     :collect form)))
    651703
    652 #-windows
     704#-(and (or win32 windows mswindows mingw32) (not cygwin))
    653705(progn
    654706#+clisp (defun get-uid () (posix:uid))
     
    661713(defun get-uid ()
    662714  (let ((uid-string
    663          (with-output-to-string (asdf::*VERBOSE-OUT*)
    664            (asdf:run-shell-command "id -ur"))))
     715         (with-output-to-string (*verbose-out*)
     716           (run-shell-command "id -ur"))))
    665717    (with-input-from-string (stream uid-string)
    666718      (read-line stream)
     
    688740      (let ((sofar (ignore-errors (truename (pathname-root p)))))
    689741        (unless sofar (return p))
    690         (loop :for component :in (cdr directory)
    691           :for rest :on (cdr directory)
    692           :for more = (ignore-errors
    693                         (truename
    694                          (merge-pathnames*
    695                           (make-pathname :directory `(:relative ,component))
    696                           sofar))) :do
    697           (if more
    698               (setf sofar more)
    699               (return
    700                 (merge-pathnames*
    701                  (make-pathname :host nil :device nil
    702                                 :directory `(:relative ,@rest)
    703                                 :defaults p)
    704                  sofar)))
    705           :finally
    706           (return
    707             (merge-pathnames*
    708              (make-pathname :host nil :device nil
    709                             :directory nil
    710                             :defaults p)
    711              sofar)))))))
     742        (flet ((solution (directories)
     743                 (merge-pathnames*
     744                  (make-pathname :host nil :device nil
     745                                 :directory `(:relative ,@directories)
     746                                 :name (pathname-name p)
     747                                 :type (pathname-type p)
     748                                 :version (pathname-version p))
     749                  sofar)))
     750          (loop :for component :in (cdr directory)
     751            :for rest :on (cdr directory)
     752            :for more = (ignore-errors
     753                          (truename
     754                           (merge-pathnames*
     755                            (make-pathname :directory `(:relative ,component))
     756                            sofar))) :do
     757            (if more
     758                (setf sofar more)
     759                (return (solution rest)))
     760            :finally
     761            (return (solution nil))))))))
    712762
    713763(defun lispize-pathname (input-file)
     
    779829   (in-order-to :initform nil :initarg :in-order-to
    780830                :accessor component-in-order-to)
    781    ;; XXX crap name
     831   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     832   (load-dependencies :accessor component-load-dependencies :initform nil)
     833   ;; XXX crap name, but it's an official API name!
    782834   (do-first :initform nil :initarg :do-first
    783835             :accessor component-do-first)
     
    798850               :initform nil)))
    799851
     852(defun component-find-path (component)
     853  (reverse
     854   (loop :for c = component :then (component-parent c)
     855     :while c :collect (component-name c))))
     856
     857(defmethod print-object ((c component) stream)
     858  (print-unreadable-object (c stream :type t :identity nil)
     859    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
     860
     861
    800862;;;; methods: conditions
    801863
     
    830892       component))
    831893
    832 (defmethod print-object ((c component) stream)
    833   (print-unreadable-object (c stream :type t :identity t)
    834     (ignore-errors
    835       (prin1 (component-name c) stream))))
     894(defvar *default-component-class* 'cl-source-file)
     895
     896(defun compute-module-components-by-name (module)
     897  (let ((hash (module-components-by-name module)))
     898    (clrhash hash)
     899    (loop :for c :in (module-components module)
     900      :for name = (component-name c)
     901      :for previous = (gethash name (module-components-by-name module))
     902      :do
     903      (when previous
     904        (error 'duplicate-names :name name))
     905      :do (setf (gethash name (module-components-by-name module)) c))
     906    hash))
    836907
    837908(defclass module (component)
    838   ((components :initform nil :accessor module-components :initarg :components)
    839    ;; what to do if we can't satisfy a dependency of one of this module's
    840    ;; components.  This allows a limited form of conditional processing
    841    (if-component-dep-fails :initform :fail
    842                            :accessor module-if-component-dep-fails
    843                            :initarg :if-component-dep-fails)
    844    (default-component-class :accessor module-default-component-class
    845      :initform 'cl-source-file :initarg :default-component-class)))
     909  ((components
     910    :initform nil
     911    :initarg :components
     912    :accessor module-components)
     913   (components-by-name
     914    :initform (make-hash-table :test 'equal)
     915    :accessor module-components-by-name)
     916   ;; What to do if we can't satisfy a dependency of one of this module's
     917   ;; components.  This allows a limited form of conditional processing.
     918   (if-component-dep-fails
     919    :initform :fail
     920    :initarg :if-component-dep-fails
     921    :accessor module-if-component-dep-fails)
     922   (default-component-class
     923    :initform *default-component-class*
     924    :initarg :default-component-class
     925    :accessor module-default-component-class)))
    846926
    847927(defun component-parent-pathname (component)
     
    9851065               (when defaults
    9861066                 (cond ((directory-pathname-p defaults)
    987                         (let ((file (and defaults
    988                                          (make-pathname
    989                                           :defaults defaults :version :newest
    990                                           :name name :type "asd" :case :local)))
    991                                #+(and (or win32 windows) (not :clisp))
    992                                (shortcut (make-pathname
    993                                           :defaults defaults :version :newest
    994                                           :name name :type "asd.lnk" :case :local)))
    995                           (if (and file (probe-file file))
    996                               (return file))
    997                           #+(and (or win32 windows) (not :clisp))
    998                           (when (probe-file shortcut)
    999                             (let ((target (parse-windows-shortcut shortcut)))
    1000                               (when target
    1001                                 (return (pathname target)))))))
     1067                        (let ((file (probe-asd name defaults)))
     1068                          (when file
     1069                            (return file))))
    10021070                       (t
    10031071                        (restart-case
     
    10321100  (flet ((try (counter)
    10331101           (ignore-errors
    1034              (make-package (format nil "~a~D" 'asdf counter)
     1102             (make-package (format nil "~A~D" :asdf counter)
    10351103                           :use '(:cl :asdf)))))
    10361104    (do* ((counter 0 (+ counter 1))
     
    10391107
    10401108(defun safe-file-write-date (pathname)
    1041            ;; if FILE-WRITE-DATE returns NIL, it's possible that the
    1042            ;; user or some other agent has deleted an input file.  If
    1043            ;; that's the case, well, that's not good, but as long as
    1044            ;; the operation is otherwise considered to be done we
    1045            ;; could continue and survive.
    1046   (or (and pathname (file-write-date pathname))
     1109  ;; If FILE-WRITE-DATE returns NIL, it's possible that
     1110  ;; the user or some other agent has deleted an input file.
     1111  ;; Also, generated files will not exist at the time planning is done
     1112  ;; and calls operation-done-p which calls safe-file-write-date.
     1113  ;; So it is very possible that we can't get a valid file-write-date,
     1114  ;; and we can survive and we will continue the planning
     1115  ;; as if the file were very old.
     1116  ;; (or should we treat the case in a different, special way?)
     1117  (or (and pathname (probe-file pathname) (file-write-date pathname))
    10471118      (progn
    1048         (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
    1049               pathname)
     1119        (when pathname
     1120          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
     1121                pathname))
    10501122        0)))
    10511123
     
    10671139                 (asdf-message
    10681140                  "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    1069                   ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    1070                   ;; ON-DISK), but CMUCL barfs on that.
    1071                   on-disk
    1072                   *package*)
     1141                  on-disk *package*)
    10731142                 (load on-disk)))
    10741143          (delete-package package))))
     
    10891158;;;; Finding components
    10901159
    1091 (defmethod find-component ((module module) name &optional version)
    1092   (if (slot-boundp module 'components)
    1093       (let ((m (find name (module-components module)
    1094                      :test #'equal :key #'component-name)))
    1095         (if (and m (version-satisfies m version)) m))))
    1096 
    1097 
    1098 ;;; a component with no parent is a system
    1099 (defmethod find-component ((module (eql nil)) name &optional version)
    1100   (declare (ignorable module))
    1101   (let ((m (find-system name nil)))
    1102     (if (and m (version-satisfies m version)) m)))
     1160(defmethod find-component ((base string) path)
     1161  (let ((s (find-system base nil)))
     1162    (and s (find-component s path))))
     1163
     1164(defmethod find-component ((base symbol) path)
     1165  (cond
     1166    (base (find-component (coerce-name base) path))
     1167    (path (find-component path nil))
     1168    (t    nil)))
     1169
     1170(defmethod find-component ((base cons) path)
     1171  (find-component (car base) (cons (cdr base) path)))
     1172
     1173(defmethod find-component ((module module) (name string))
     1174  (when (slot-boundp module 'components-by-name)
     1175    (values (gethash name (module-components-by-name module)))))
     1176
     1177(defmethod find-component ((component component) (name symbol))
     1178  (if name
     1179      (find-component component (coerce-name name))
     1180      component))
     1181
     1182(defmethod find-component ((module module) (name cons))
     1183  (find-component (find-component module (car name)) (cdr name)))
     1184
    11031185
    11041186;;; component subclasses
     
    11181200  ((type :initform "html")))
    11191201
    1120 (defmethod source-file-type ((component module) (s module)) :directory)
     1202(defmethod source-file-type ((component module) (s module))
     1203  (declare (ignorable component s))
     1204  :directory)
    11211205(defmethod source-file-type ((component source-file) (s module))
     1206  (declare (ignorable s))
    11221207  (source-file-explicit-type component))
    11231208
     
    11671252(defclass operation ()
    11681253  (
    1169    ;; what is the TYPE of this slot?  seems like it should be boolean,
    1170    ;; but TRAVERSE checks to see if it's a list of component names...
    1171    ;; [2010/02/07:rpg]
     1254   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1255   ;; T to force the inside of existing system,
     1256   ;;   but not recurse to other systems we depend on.
     1257   ;; :ALL (or any other atom) to force all systems
     1258   ;;   including other systems we depend on.
     1259   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
     1260   ;;   to force systems named in a given list
     1261   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
    11721262   (forced :initform nil :initarg :force :accessor operation-forced)
    11731263   (original-initargs :initform nil :initarg :original-initargs
    11741264                      :accessor operation-original-initargs)
    1175    (visited-nodes :initform nil :accessor operation-visited-nodes)
    1176    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     1265   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
     1266   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    11771267   (parent :initform nil :initarg :parent :accessor operation-parent)))
    11781268
     
    12231313(defmethod visit-component ((o operation) (c component) data)
    12241314  (unless (component-visited-p o c)
    1225     (push (cons (node-for o c) data)
    1226           (operation-visited-nodes (operation-ancestor o)))))
     1315    (setf (gethash (node-for o c)
     1316                   (operation-visited-nodes (operation-ancestor o)))
     1317          (cons t data))))
    12271318
    12281319(defmethod component-visited-p ((o operation) (c component))
    1229   (assoc (node-for o c)
    1230          (operation-visited-nodes (operation-ancestor o))
    1231          :test 'equal))
     1320  (gethash (node-for o c)
     1321           (operation-visited-nodes (operation-ancestor o))))
    12321322
    12331323(defmethod (setf visiting-component) (new-value operation component)
     
    12401330        (a (operation-ancestor o)))
    12411331    (if new-value
    1242         (pushnew node (operation-visiting-nodes a) :test 'equal)
    1243         (setf (operation-visiting-nodes a)
    1244               (remove node  (operation-visiting-nodes a) :test 'equal))))
    1245   new-value)
     1332        (setf (gethash node (operation-visiting-nodes a)) t)
     1333        (remhash node (operation-visiting-nodes a)))
     1334    new-value))
    12461335
    12471336(defmethod component-visiting-p ((o operation) (c component))
    12481337  (let ((node (node-for o c)))
    1249     (member node (operation-visiting-nodes (operation-ancestor o))
    1250             :test 'equal)))
     1338    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
    12511339
    12521340(defmethod component-depends-on ((op-spec symbol) (c component))
     
    12761364        (list (component-pathname c)))))
    12771365
    1278 (defmethod input-files ((operation operation) (c module)) nil)
     1366(defmethod input-files ((operation operation) (c module))
     1367  (declare (ignorable operation c))
     1368  nil)
     1369
     1370(defmethod component-operation-time (o c)
     1371  (gethash (type-of o) (component-operation-times c)))
    12791372
    12801373(defmethod operation-done-p ((o operation) (c component))
    12811374  (let ((out-files (output-files o c))
    12821375        (in-files (input-files o c))
    1283         (op-time (gethash (type-of o) (component-operation-times c))))
     1376        (op-time (component-operation-time o c)))
    12841377    (flet ((earliest-out ()
    12851378             (reduce #'min (mapcar #'safe-file-write-date out-files)))
     
    13241417
    13251418
    1326 ;;; So you look at this code and think "why isn't it a bunch of
    1327 ;;; methods".  And the answer is, because standard method combination
    1328 ;;; runs :before methods most->least-specific, which is back to front
    1329 ;;; for our purposes.
     1419
     1420;;; For 1.700 I've done my best to refactor TRAVERSE
     1421;;; by splitting it up in a bunch of functions,
     1422;;; so as to improve the collection and use-detection algorithm. --fare
     1423;;; The protocol is as follows: we pass around operation, dependency,
     1424;;; bunch of other stuff, and a force argument. Return a force flag.
     1425;;; The returned flag is T if anything has changed that requires a rebuild.
     1426;;; The force argument is a list of components that will require a rebuild
     1427;;; if the flag is T, at which point whoever returns the flag has to
     1428;;; mark them all as forced, and whoever recurses again can use a NIL list
     1429;;; as a further argument.
    13301430
    13311431(defvar *forcing* nil
     
    13331433recursive calls to traverse.")
    13341434
    1335 (defmethod traverse ((operation operation) (c component))
    1336   (let ((forced nil))                   ;return value -- everyone side-effects onto this
    1337     (labels ((%do-one-dep (required-op required-c required-v)
    1338                ;; returns a partial plan that results from performing required-op
    1339                ;; on required-c, possibly with a required-vERSION
    1340                (let* ((dep-c (or (find-component
    1341                                   (component-parent c)
    1342                                   ;; XXX tacky.  really we should build the
    1343                                   ;; in-order-to slot with canonicalized
    1344                                   ;; names instead of coercing this late
    1345                                   (coerce-name required-c) required-v)
    1346                                  (if required-v
    1347                                      (error 'missing-dependency-of-version
    1348                                             :required-by c
    1349                                             :version required-v
    1350                                             :requires required-c)
    1351                                      (error 'missing-dependency
    1352                                             :required-by c
    1353                                             :requires required-c))))
    1354                       (op (make-sub-operation c operation dep-c required-op)))
    1355                  (traverse op dep-c)))
    1356              (do-one-dep (required-op required-c required-v)
    1357                ;; this function is a thin, error-handling wrapper around
    1358                ;; %do-one-dep.  Returns a partial plan per that function.
    1359                (loop
    1360                  (restart-case
    1361                      (return (%do-one-dep required-op required-c required-v))
    1362                    (retry ()
    1363                      :report (lambda (s)
    1364                                (format s "~@<Retry loading component ~S.~@:>"
    1365                                        required-c))
    1366                      :test
    1367                      (lambda (c)
    1368 #|
    1369                         (print (list :c1 c (typep c 'missing-dependency)))
    1370                         (when (typep c 'missing-dependency)
    1371                           (print (list :c2 (missing-requires c) required-c
    1372                                        (equalp (missing-requires c)
    1373                                                required-c))))
    1374 |#
    1375                        (or (null c)
    1376                            (and (typep c 'missing-dependency)
    1377                                 (equalp (missing-requires c)
    1378                                         required-c))))))))
    1379              (do-dep (op dep)
    1380                ;; type of arguments uncertain:  op seems to at least potentially be a
    1381                ;; symbol, rather than an operation
    1382                ;; dep is either a list of component names (?) or (we hope) a single
    1383                ;; component name.
    1384                ;; handle a single dependency, returns nothing of interest --- side-
    1385                ;; effects onto the FORCED variable, which is scoped over TRAVERSE
    1386                (cond ((eq op 'feature)
    1387                       (or (member (car dep) *features*)
    1388                           (error 'missing-dependency
    1389                                  :required-by c
    1390                                  :requires (car dep))))
    1391                      (t
    1392                       (dolist (d dep)
    1393                         ;; structured dependencies --- this parses keywords
    1394                         ;; the keywords could be broken out and cleanly (extensibly)
    1395                         ;; processed by EQL methods, but for the pervasive side-effecting
    1396                         ;; onto FORCED
    1397                         (cond ((consp d)
    1398                                (cond ((string-equal
    1399                                        (symbol-name (first d))
    1400                                        "VERSION")
    1401                                       ;; https://bugs.launchpad.net/asdf/+bug/527788
    1402                                       (appendf
    1403                                        forced
    1404                                        (do-one-dep op (second d) (third d))))
    1405                                      ;; this particular subform is not documented, indeed
    1406                                      ;; clashes with the documentation, since it assumes a
    1407                                      ;; third component.
    1408                                      ;; See https://bugs.launchpad.net/asdf/+bug/518467
    1409                                      ((and (string-equal
    1410                                             (symbol-name (first d))
    1411                                             "FEATURE")
    1412                                            (find (second d) *features*
    1413                                                  :test 'string-equal))
    1414                                       (appendf
    1415                                        forced
    1416                                        (do-one-dep op (third d) nil)))
    1417                                      (t
    1418                                       (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
    1419                               (t
    1420                                (appendf forced (do-one-dep op d nil)))))))))
     1435(defgeneric do-traverse (operation component collect))
     1436
     1437(defun %do-one-dep (operation c collect required-op required-c required-v)
     1438  ;; collects a partial plan that results from performing required-op
     1439  ;; on required-c, possibly with a required-vERSION
     1440  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
     1441                      (and d (version-satisfies d required-v) d))
     1442                    (if required-v
     1443                        (error 'missing-dependency-of-version
     1444                               :required-by c
     1445                               :version required-v
     1446                               :requires required-c)
     1447                        (error 'missing-dependency
     1448                               :required-by c
     1449                               :requires required-c))))
     1450         (op (make-sub-operation c operation dep-c required-op)))
     1451    (do-traverse op dep-c collect)))
     1452
     1453(defun do-one-dep (operation c collect required-op required-c required-v)
     1454  ;; this function is a thin, error-handling wrapper around
     1455  ;; %do-one-dep.  Returns a partial plan per that function.
     1456  (loop
     1457    (restart-case
     1458        (return (%do-one-dep operation c collect
     1459                             required-op required-c required-v))
     1460      (retry ()
     1461        :report (lambda (s)
     1462                  (format s "~@<Retry loading component ~S.~@:>"
     1463                          required-c))
     1464        :test
     1465        (lambda (c)
     1466          #|
     1467          (print (list :c1 c (typep c 'missing-dependency)))
     1468          (when (typep c 'missing-dependency)
     1469          (print (list :c2 (missing-requires c) required-c
     1470          (equalp (missing-requires c)
     1471          required-c))))
     1472          |#
     1473          (or (null c)
     1474              (and (typep c 'missing-dependency)
     1475                   (equalp (missing-requires c)
     1476                           required-c))))))))
     1477
     1478(defun do-dep (operation c collect op dep)
     1479  ;; type of arguments uncertain:
     1480  ;; op seems to at least potentially be a symbol, rather than an operation
     1481  ;; dep is a list of component names
     1482  (cond ((eq op 'feature)
     1483         (if (member (car dep) *features*)
     1484             nil
     1485             (error 'missing-dependency
     1486                    :required-by c
     1487                    :requires (car dep))))
     1488        (t
     1489         (let ((flag nil))
     1490           (flet ((dep (op comp ver)
     1491                    (when (do-one-dep operation c collect
     1492                                      op comp ver)
     1493                      (setf flag t))))
     1494             (dolist (d dep)
     1495               (if (atom d)
     1496                   (dep op d nil)
     1497                   ;; structured dependencies --- this parses keywords
     1498                   ;; the keywords could be broken out and cleanly (extensibly)
     1499                   ;; processed by EQL methods
     1500                   (cond ((eq :version (first d))
     1501                          ;; https://bugs.launchpad.net/asdf/+bug/527788
     1502                          (dep op (second d) (third d)))
     1503                         ;; This particular subform is not documented and
     1504                         ;; has always been broken in the past.
     1505                         ;; Therefore no one uses it, and I'm cerroring it out,
     1506                         ;; after fixing it
     1507                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
     1508                         ((eq :feature (first d))
     1509                          (cerror "Continue nonetheless."
     1510                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
     1511                          (when (find (second d) *features* :test 'string-equal)
     1512                            (dep op (third d) nil)))
     1513                         (t
     1514                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
     1515           flag))))
     1516
     1517(defun do-collect (collect x)
     1518  (funcall collect x))
     1519
     1520(defmethod do-traverse ((operation operation) (c component) collect)
     1521  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1522    (labels
     1523        ((update-flag (x)
     1524           (when x
     1525             (setf flag t)))
     1526         (dep (op comp)
     1527           (update-flag (do-dep operation c collect op comp))))
     1528      ;; Have we been visited yet? If so, just process the result.
    14211529      (aif (component-visited-p operation c)
    1422            (return-from traverse
    1423              (if (cdr it) (list (cons 'pruned-op c)) nil)))
     1530           (progn
     1531             (update-flag (cdr it))
     1532             (return-from do-traverse flag)))
    14241533      ;; dependencies
    1425       (if (component-visiting-p operation c)
    1426           (error 'circular-dependency :components (list c)))
     1534      (when (component-visiting-p operation c)
     1535        (error 'circular-dependency :components (list c)))
    14271536      (setf (visiting-component operation c) t)
    14281537      (unwind-protect
    1429           (progn
    1430             ;; first we check and do all the dependencies for the
    1431             ;; module.  Operations planned in this loop will show up
    1432             ;; in the contents of the FORCED variable, and are consumed
    1433             ;; downstream (watch out for the shadowing FORCED variable
    1434             ;; around the DOLIST below!)
    1435             (let ((*forcing* nil))
    1436               ;; upstream dependencies are never forced to happen just because
    1437               ;; the things that depend on them are....
    1438               (loop :for (required-op . deps) :in
    1439                                               (component-depends-on operation c)
    1440                     :do (do-dep required-op deps)))
    1441             ;; constituent bits
    1442             (let ((module-ops
    1443                    (when (typep c 'module)
    1444                      (let ((at-least-one nil)
    1445                            (forced nil)
    1446                            ;; this is set based on the results of the
    1447                            ;; dependencies and whether we are in the
    1448                            ;; context of a *forcing* call...
    1449                            (must-operate (or *forcing*
    1450                                              ;; inter-system dependencies do NOT trigger
    1451                                              ;; building components
    1452                                              (and
    1453                                               (not (typep c 'system))
    1454                                               forced)))
    1455                            (error nil))
    1456                        (dolist (kid (module-components c))
    1457                            (handler-case
    1458                                (let ((*forcing* must-operate))
    1459                                  (appendf forced (traverse operation kid)))
    1460                              (missing-dependency (condition)
    1461                                (when (eq (module-if-component-dep-fails c)
    1462                                        :fail)
    1463                                    (error condition))
    1464                                (setf error condition))
    1465                              (:no-error (c)
    1466                                (declare (ignore c))
    1467                                (setf at-least-one t))))
    1468                        (when (and (eq (module-if-component-dep-fails c)
    1469                                       :try-next)
    1470                                   (not at-least-one))
    1471                          (error error))
    1472                        forced))))
    1473               ;; now the thing itself
    1474               ;; the test here is a bit oddly written.  FORCED here doesn't
    1475               ;; mean that this operation is forced on this component, but that
    1476               ;; something upstream of this component has been forced.
    1477               (when (or forced module-ops
    1478                         *forcing*
    1479                         (not (operation-done-p operation c))
    1480                         (let ((f (operation-forced
    1481                                   (operation-ancestor operation))))
    1482                           ;; does anyone fully understand the following condition?
    1483                           ;; if so, please add a comment to explain it...
    1484                           (and f (or (not (consp f))
    1485                                      (member (component-name
    1486                                               (operation-ancestor operation))
    1487                                              (mapcar #'coerce-name f)
    1488                                              ;; this was string=, but for the benefit
    1489                                              ;; of mlisp, we use string-equal for this
    1490                                              ;; purpose.
    1491                                              :test #'string-equal)))))
    1492                 (let ((do-first (cdr (assoc (class-name (class-of operation))
    1493                                             (component-do-first c)))))
    1494                   (loop :for (required-op . deps) :in do-first
    1495                         :do (do-dep required-op deps)))
    1496                 (setf forced (append (delete 'pruned-op forced :key #'car)
    1497                                      (delete 'pruned-op module-ops :key #'car)
    1498                                      (list (cons operation c)))))))
    1499         (setf (visiting-component operation c) nil))
    1500       (visit-component operation c (and forced t))
    1501       forced)))
    1502 
     1538           (progn
     1539             ;; first we check and do all the dependencies for the module.
     1540             ;; Operations planned in this loop will show up
     1541             ;; in the results, and are consumed below.
     1542             (let ((*forcing* nil))
     1543               ;; upstream dependencies are never forced to happen just because
     1544               ;; the things that depend on them are....
     1545               (loop
     1546                 :for (required-op . deps) :in (component-depends-on operation c)
     1547                 :do (dep required-op deps)))
     1548             ;; constituent bits
     1549             (let ((module-ops
     1550                    (when (typep c 'module)
     1551                      (let ((at-least-one nil)
     1552                            ;; This is set based on the results of the
     1553                            ;; dependencies and whether we are in the
     1554                            ;; context of a *forcing* call...
     1555                            ;; inter-system dependencies do NOT trigger
     1556                            ;; building components
     1557                            (*forcing*
     1558                             (or *forcing*
     1559                                 (and flag (not (typep c 'system)))))
     1560                            (error nil))
     1561                        (while-collecting (internal-collect)
     1562                          (dolist (kid (module-components c))
     1563                            (handler-case
     1564                                (update-flag
     1565                                 (do-traverse operation kid #'internal-collect))
     1566                              (missing-dependency (condition)
     1567                                (when (eq (module-if-component-dep-fails c)
     1568                                          :fail)
     1569                                  (error condition))
     1570                                (setf error condition))
     1571                              (:no-error (c)
     1572                                (declare (ignore c))
     1573                                (setf at-least-one t))))
     1574                          (when (and (eq (module-if-component-dep-fails c)
     1575                                         :try-next)
     1576                                     (not at-least-one))
     1577                            (error error)))))))
     1578               (update-flag
     1579                (or
     1580                 *forcing*
     1581                 (not (operation-done-p operation c))
     1582                 ;; For sub-operations, check whether
     1583                 ;; the original ancestor operation was forced,
     1584                 ;; or names us amongst an explicit list of things to force...
     1585                 ;; except that this check doesn't distinguish
     1586                 ;; between all the things with a given name. Sigh.
     1587                 ;; BROKEN!
     1588                 (let ((f (operation-forced
     1589                           (operation-ancestor operation))))
     1590                   (and f (or (not (consp f)) ;; T or :ALL
     1591                              (and (typep c 'system) ;; list of names of systems to force
     1592                                   (member (component-name c) f
     1593                                           :test #'string=)))))))
     1594               (when flag
     1595                 (let ((do-first (cdr (assoc (class-name (class-of operation))
     1596                                             (component-do-first c)))))
     1597                   (loop :for (required-op . deps) :in do-first
     1598                     :do (do-dep operation c collect required-op deps)))
     1599                 (do-collect collect (vector module-ops))
     1600                 (do-collect collect (cons operation c)))))
     1601             (setf (visiting-component operation c) nil)))
     1602      (visit-component operation c flag)
     1603      flag))
     1604
     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
     1618(defun flatten-tree (l)
     1619  ;; You collected things into a list.
     1620  ;; Most elements are just things to collect again.
     1621  ;; A (simple-vector 1) indicate that you should recurse into its contents.
     1622  ;; This way, in two passes (rather than N being the depth of the tree),
     1623  ;; you can collect things with marginally constant-time append,
     1624  ;; achieving linear time collection instead of quadratic time.
     1625  (while-collecting (c)
     1626    (labels ((r (x)
     1627               (if (typep x '(simple-vector 1))
     1628                   (r* (svref x 0))
     1629                   (c x)))
     1630             (r* (l)
     1631               (dolist (x l) (r x))))
     1632      (r* l))))
    15031633
    15041634(defmethod perform ((operation operation) (c source-file))
     
    15091639
    15101640(defmethod perform ((operation operation) (c module))
     1641  (declare (ignorable operation c))
    15111642  nil)
    15121643
     
    15331664  ;; Note how we use OUTPUT-FILES to find the binary locations
    15341665  ;; This allows the user to override the names.
    1535   (let* ((input (output-files o c))
    1536          (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
    1537     (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
     1666  (let* ((files (output-files o c))
     1667         (object (first files))
     1668         (fasl (second files)))
     1669    (c:build-fasl fasl :lisp-files (list object))))
    15381670
    15391671(defmethod perform :after ((operation operation) (c component))
     
    15681700
    15691701(defmethod output-files ((operation compile-op) (c cl-source-file))
     1702  (declare (ignorable operation))
    15701703  (let ((p (lispize-pathname (component-pathname c))))
    15711704    #-:broken-fasl-loader
    1572     (list #-ecl (compile-file-pathname p)
    1573           #+ecl (compile-file-pathname p :type :object)
     1705    (list (compile-file-pathname p #+ecl :type #+ecl :object)
    15741706          #+ecl (compile-file-pathname p :type :fasl))
    15751707    #+:broken-fasl-loader (list p)))
    15761708
    15771709(defmethod perform ((operation compile-op) (c static-file))
     1710  (declare (ignorable operation c))
    15781711  nil)
    15791712
    15801713(defmethod output-files ((operation compile-op) (c static-file))
     1714  (declare (ignorable operation c))
    15811715  nil)
    15821716
    1583 (defmethod input-files ((op compile-op) (c static-file))
     1717(defmethod input-files ((operation compile-op) (c static-file))
     1718  (declare (ignorable operation c))
    15841719  nil)
    15851720
     
    16031738
    16041739(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    1605   (let ((state :initial))
    1606     (loop :until (or (eq state :success)
    1607                      (eq state :failure)) :do
    1608          (case state
    1609            (:recompiled
    1610             (setf state :failure)
    1611             (call-next-method)
    1612             (setf state :success))
    1613            (:failed-load
    1614             (setf state :recompiled)
    1615             (perform (make-instance 'compile-op) c))
    1616            (t
    1617             (with-simple-restart
    1618                 (try-recompiling "Recompile ~a and try loading it again"
    1619                                   (component-name c))
    1620               (setf state :failed-load)
    1621               (call-next-method)
    1622               (setf state :success)))))))
     1740  (declare (ignorable o))
     1741  (loop :with state = :initial
     1742    :until (or (eq state :success)
     1743               (eq state :failure)) :do
     1744    (case state
     1745      (:recompiled
     1746       (setf state :failure)
     1747       (call-next-method)
     1748       (setf state :success))
     1749      (:failed-load
     1750       (setf state :recompiled)
     1751       (perform (make-instance 'compile-op) c))
     1752      (t
     1753       (with-simple-restart
     1754           (try-recompiling "Recompile ~a and try loading it again"
     1755                            (component-name c))
     1756         (setf state :failed-load)
     1757         (call-next-method)
     1758         (setf state :success))))))
     1759
     1760(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
     1761  (loop :with state = :initial
     1762    :until (or (eq state :success)
     1763               (eq state :failure)) :do
     1764    (case state
     1765      (:recompiled
     1766       (setf state :failure)
     1767       (call-next-method)
     1768       (setf state :success))
     1769      (:failed-compile
     1770       (setf state :recompiled)
     1771       (perform-with-restarts o c))
     1772      (t
     1773       (with-simple-restart
     1774           (try-recompiling "Try recompiling ~a"
     1775                            (component-name c))
     1776         (setf state :failed-compile)
     1777         (call-next-method)
     1778         (setf state :success))))))
    16231779
    16241780(defmethod perform ((operation load-op) (c static-file))
     1781  (declare (ignorable operation c))
    16251782  nil)
    16261783
    16271784(defmethod operation-done-p ((operation load-op) (c static-file))
     1785  (declare (ignorable operation c))
    16281786  t)
    16291787
    1630 (defmethod output-files ((o operation) (c component))
     1788(defmethod output-files ((operation operation) (c component))
     1789  (declare (ignorable operation c))
    16311790  nil)
    16321791
    16331792(defmethod component-depends-on ((operation load-op) (c component))
     1793  (declare (ignorable operation))
    16341794  (cons (list 'compile-op (component-name c))
    16351795        (call-next-method)))
     
    16411801
    16421802(defmethod perform ((o load-source-op) (c cl-source-file))
     1803  (declare (ignorable o))
    16431804  (let ((source (component-pathname c)))
    16441805    (setf (component-property c 'last-loaded-as-source)
     
    16471808
    16481809(defmethod perform ((operation load-source-op) (c static-file))
     1810  (declare (ignorable operation c))
    16491811  nil)
    16501812
    16511813(defmethod output-files ((operation load-source-op) (c component))
     1814  (declare (ignorable operation c))
    16521815  nil)
    16531816
    16541817;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
    16551818(defmethod component-depends-on ((o load-source-op) (c component))
     1819  (declare (ignorable o))
    16561820  (let ((what-would-load-op-do (cdr (assoc 'load-op
    16571821                                           (component-in-order-to c)))))
     
    16631827
    16641828(defmethod operation-done-p ((o load-source-op) (c source-file))
     1829  (declare (ignorable o))
    16651830  (if (or (not (component-property c 'last-loaded-as-source))
    16661831          (> (safe-file-write-date (component-pathname c))
     
    16751840
    16761841(defmethod perform ((operation test-op) (c component))
     1842  (declare (ignorable operation c))
    16771843  nil)
    16781844
    16791845(defmethod operation-done-p ((operation test-op) (c system))
    16801846  "Testing a system is _never_ done."
     1847  (declare (ignorable operation c))
    16811848  nil)
    16821849
    16831850(defmethod component-depends-on :around ((o test-op) (c system))
     1851  (declare (ignorable o))
    16841852  (cons `(load-op ,(component-name c)) (call-next-method)))
    16851853
     
    16881856;;;; Invoking Operations
    16891857
    1690 (defun operate (operation-class system &rest args &key (verbose t) version force
    1691                 &allow-other-keys)
     1858(defgeneric operate (operation-class system &key &allow-other-keys))
     1859
     1860(defmethod operate (operation-class system &rest args
     1861                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
     1862                    &allow-other-keys)
    16921863  (declare (ignore force))
    16931864  (let* ((*package* *package*)
     
    16961867                    :original-initargs args
    16971868                    args))
    1698          (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     1869         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    16991870         (system (if (typep system 'component) system (find-system system))))
    17001871    (unless (version-satisfies system version)
     
    17051876          (loop
    17061877            (restart-case
    1707                 (progn (perform-with-restarts op component)
    1708                        (return))
     1878                (progn
     1879                  (perform-with-restarts op component)
     1880                  (return))
    17091881              (retry ()
    17101882                :report
     
    17241896    op))
    17251897
    1726 (defun oos (operation-class system &rest args &key force (verbose t) version
     1898(defun oos (operation-class system &rest args &key force verbose version
    17271899            &allow-other-keys)
    17281900  (declare (ignore force verbose version))
     
    17541926        operate-docstring))
    17551927
    1756 (defun load-system (system &rest args &key force (verbose t) version
     1928(defun load-system (system &rest args &key force verbose version
    17571929                    &allow-other-keys)
    17581930  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
     
    17611933  (apply #'operate 'load-op system args))
    17621934
    1763 (defun compile-system (system &rest args &key force (verbose t) version
     1935(defun compile-system (system &rest args &key force verbose version
    17641936                       &allow-other-keys)
    17651937  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     
    17681940  (apply #'operate 'compile-op system args))
    17691941
    1770 (defun test-system (system &rest args &key force (verbose t) version
     1942(defun test-system (system &rest args &key force verbose version
    17711943                    &allow-other-keys)
    17721944  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     
    18011973(defmacro defsystem (name &body options)
    18021974  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    1803                             &allow-other-keys)
     1975                            defsystem-depends-on &allow-other-keys)
    18041976      options
    1805     (let ((component-options (remove-keyword :class options)))
     1977    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
    18061978      `(progn
    18071979         ;; system must be registered before we parse the body, otherwise
    18081980         ;; we recur when trying to find an existing system of the same name
    18091981         ;; to reuse options (e.g. pathname) from
     1982         ,@(loop :for system :in defsystem-depends-on
     1983             :collect `(load-system ,system))
    18101984         (let ((s (system-registered-p ',name)))
    18111985           (cond ((and s (eq (type-of (cdr s)) ',class))
     
    18191993                                    (cdr (system-registered-p ',name))))
    18201994         (parse-component-form
    1821           nil (apply
    1822                #'list
     1995          nil (list*
    18231996               :module (coerce-name ',name)
    18241997               :pathname
     
    18712044
    18722045
    1873 (defvar *serial-depends-on*)
     2046(defvar *serial-depends-on* nil)
    18742047
    18752048(defun sysdef-error-component (msg type name value)
    18762049  (sysdef-error (concatenate 'string msg
    1877                              "~&The value specified for ~(~A~) ~A is ~W")
     2050                             "~&The value specified for ~(~A~) ~A is ~S")
    18782051                type name value))
    18792052
     
    19252098
    19262099(defun parse-component-form (parent options)
    1927 
    19282100  (destructuring-bind
    19292101        (type name &rest rest &key
     
    19572129                (make-instance (class-for-type parent type)))))
    19582130      (when weakly-depends-on
    1959         (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    1960       (when (boundp '*serial-depends-on*)
    1961         (setf depends-on
    1962               (concatenate 'list *serial-depends-on* depends-on)))
     2131        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
     2132      (when *serial-depends-on*
     2133        (push *serial-depends-on* depends-on))
    19632134      (apply #'reinitialize-instance ret
    19642135             :name (coerce-name name)
     
    19742145        (let ((*serial-depends-on* nil))
    19752146          (setf (module-components ret)
    1976                 (loop :for c-form :in components
     2147                (loop
     2148                  :for c-form :in components
    19772149                  :for c = (parse-component-form ret c-form)
     2150                  :for name = (component-name c)
    19782151                  :collect c
    1979                   :if serial
    1980                   :do (push (component-name c) *serial-depends-on*))))
    1981 
    1982         ;; check for duplicate names
    1983         (let ((name-hash (make-hash-table :test #'equal)))
    1984           (loop :for c in (module-components ret) :do
    1985             (if (gethash (component-name c)
    1986                          name-hash)
    1987                 (error 'duplicate-names :name (component-name c))
    1988                 (setf (gethash (component-name c)
    1989                                name-hash)
    1990                       t)))))
     2152                  :when serial :do (setf *serial-depends-on* name))))
     2153        (compute-module-components-by-name ret))
     2154
     2155      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
    19912156
    19922157      (setf (component-in-order-to ret)
     
    19942159             in-order-to
    19952160             `((compile-op (compile-op ,@depends-on))
    1996                (load-op (load-op ,@depends-on))))
    1997             (component-do-first ret) `((compile-op (load-op ,@depends-on))))
     2161               (load-op (load-op ,@depends-on)))))
     2162      (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
    19982163
    19992164      (%refresh-component-inline-methods ret rest)
     
    20192184  (let ((command (apply #'format nil control-string args)))
    20202185    (asdf-message "; $ ~A~%" command)
    2021     #+sbcl
    2022     (sb-ext:process-exit-code
    2023      (apply #'sb-ext:run-program
    2024             #+win32 "sh" #-win32 "/bin/sh"
    2025             (list  "-c" command)
    2026             :input nil :output *verbose-out*
    2027             #+win32 '(:search t) #-win32 nil))
    2028 
    2029     #+(or cmu scl)
    2030     (ext:process-exit-code
    2031      (ext:run-program
    2032       "/bin/sh"
    2033       (list  "-c" command)
    2034       :input nil :output *verbose-out*))
     2186
     2187    #+abcl
     2188    (ext:run-shell-command command :output *verbose-out*)
    20352189
    20362190    #+allegro
     
    20462200      exit-code)
    20472201
     2202    #+clisp                     ;XXX not exactly *verbose-out*, I know
     2203    (ext:run-shell-command  command :output :terminal :wait t)
     2204
     2205    #+clozure
     2206    (nth-value 1
     2207               (ccl:external-process-status
     2208                (ccl:run-program "/bin/sh" (list "-c" command)
     2209                                 :input nil :output *verbose-out*
     2210                                 :wait t)))
     2211
     2212    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     2213    (si:system command)
     2214
     2215    #+gcl
     2216    (lisp:system command)
     2217
    20482218    #+lispworks
    20492219    (system:call-system-showing-output
     
    20542224     :output-stream *verbose-out*)
    20552225
    2056     #+clisp                     ;XXX not exactly *verbose-out*, I know
    2057     (ext:run-shell-command  command :output :terminal :wait t)
    2058 
    2059     #+openmcl
    2060     (nth-value 1
    2061                (ccl:external-process-status
    2062                 (ccl:run-program "/bin/sh" (list "-c" command)
    2063                                  :input nil :output *verbose-out*
    2064                                  :wait t)))
    2065 
    2066     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    2067     (si:system command)
    2068 
    2069     #+abcl
    2070     (ext:run-shell-command command :output *verbose-out*)
    2071 
    2072     #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
    2073     (error "RUN-SHELL-COMMAND not implemented for this Lisp")
    2074     ))
     2226    #+sbcl
     2227    (sb-ext:process-exit-code
     2228     (apply #'sb-ext:run-program
     2229            #+win32 "sh" #-win32 "/bin/sh"
     2230            (list  "-c" command)
     2231            :input nil :output *verbose-out*
     2232            #+win32 '(:search t) #-win32 nil))
     2233
     2234    #+(or cmu scl)
     2235    (ext:process-exit-code
     2236     (ext:run-program
     2237      "/bin/sh"
     2238      (list  "-c" command)
     2239      :input nil :output *verbose-out*))
     2240
     2241    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2242    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    20752243
    20762244;;;; ---------------------------------------------------------------------------
     
    20912259
    20922260(defun relativize-directory (directory)
    2093   (if (eq (car directory) :absolute)
    2094       (cons :relative (cdr directory))
    2095       directory))
     2261  (cond
     2262    ((stringp directory)
     2263     (list :relative directory))
     2264    ((eq (car directory) :absolute)
     2265     (cons :relative (cdr directory)))
     2266    (t
     2267     directory)))
    20962268
    20972269(defun relativize-pathname-directory (pathspec)
     
    21202292  '((:windows :mswindows :win32 :mingw32)
    21212293    (:solaris :sunos)
     2294    :linux ;; for GCL at least, must appear before :bsd.
    21222295    :macosx :darwin :apple
    21232296    :freebsd :netbsd :openbsd :bsd
    2124     :linux :unix))
     2297    :unix))
    21252298
    21262299(defparameter *architecture-features*
    21272300  '((:x86-64 :amd64 :x86_64 :x8664-target)
    21282301    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    2129     :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
     2302    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
     2303    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
    21302304
    21312305(defun lisp-version-string ()
    21322306  (let ((s (lisp-implementation-version)))
    21332307    (declare (ignorable s))
    2134     #+(or scl sbcl ecl armedbear cormanlisp mcl) s
    2135     #+cmu (substitute #\- #\/ s)
    2136     #+clozure (format nil "~d.~d~@[-~d~]"
    2137                       ccl::*openmcl-major-version*
    2138                       ccl::*openmcl-minor-version*
    2139                       #+ppc64-target 64
    2140                       #-ppc64-target nil)
    2141     #+lispworks (format nil "~A~@[~A~]" s
    2142                         (when (member :lispworks-64bit *features*) "-64bit"))
    21432308    #+allegro (format nil
    21442309                      "~A~A~A~A"
     
    21532318                       (:+ics ""))
    21542319                      (if (member :64bit *features*) "-64bit" ""))
    2155     #+(or clisp gcl) (subseq s 0 (position #\space s))
    2156     #+digitool (subseq s 8)))
     2320    #+clisp (subseq s 0 (position #\space s))
     2321    #+clozure (format nil "~d.~d-fasl~d"
     2322                      ccl::*openmcl-major-version*
     2323                      ccl::*openmcl-minor-version*
     2324                      (logand ccl::fasl-version #xFF))
     2325    #+cmu (substitute #\- #\/ s)
     2326    #+digitool (subseq s 8)
     2327    #+ecl (format nil "~A~@[-~A~]" s
     2328                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2329                    (when (>= (length vcs-id) 8)
     2330                      (subseq vcs-id 0 8))))
     2331    #+gcl (subseq s (1+ (position #\space s)))
     2332    #+lispworks (format nil "~A~@[~A~]" s
     2333                        (when (member :lispworks-64bit *features*) "-64bit"))
     2334    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
     2335    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     2336    #+(or  mcl sbcl scl) s
     2337    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
     2338          ecl gcl lispworks mcl sbcl scl) s))
    21572339
    21582340(defun first-feature (features)
     
    22222404           :for dir :in (split-string dirs :separator ":")
    22232405           :collect (try dir "common-lisp/"))
    2224        #+windows
     2406       #+(and (or win32 windows mswindows mingw32) (not cygwin))
    22252407        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    22262408            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2227            #+(not cygwin)
    2228            ,(try (or (getenv "USERPROFILE") (user-homedir))
    2229                  "Application Data/common-lisp/config/"))
     2409           ,(try (getenv "APPDATA") "common-lisp/config/"))
    22302410       ,(try (user-homedir) ".config/common-lisp/")))))
    22312411(defun system-configuration-directories ()
     
    22332413   #'null
    22342414   (append
    2235     #+windows
     2415    #+(and (or win32 windows mswindows mingw32) (not cygwin))
    22362416    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2237       `(
    2238        ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
     2417      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    22392418           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2240            #+(not cygwin)
    2241            ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2419        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    22422420    (list #p"/etc/"))))
    22432421(defun in-first-directory (dirs x)
    22442422  (loop :for dir :in dirs
    2245     :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
     2423    :thereis (and dir (ignore-errors
     2424                        (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
    22462425(defun in-user-configuration-directory (x)
    22472426  (in-first-directory (user-configuration-directories) x))
     
    23002479
    23012480(defvar *user-cache*
    2302   (or
    2303    (let ((h (getenv "XDG_CACHE_HOME")))
    2304      (and h `(,h "common-lisp" :implementation)))
    2305    #+(and windows lispworks)
    2306    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
    2307      (and h `(,h "common-lisp" "cache")))
    2308    #+(and windows (not cygwin))
    2309    ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
    2310    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
    2311      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
    2312    '(:home ".cache" "common-lisp" :implementation)))
     2481  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
     2482    (or
     2483     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
     2484     #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2485     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
     2486     '(:home ".cache" "common-lisp" :implementation))))
    23132487(defvar *system-cache*
    2314   (or
    2315    #+(and windows lispworks)
    2316    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
    2317      (and h `(,h "common-lisp" "cache")))
    2318    #+windows
    2319    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
    2320      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
    2321    #+(or unix cygwin)
    2322    '("/var/cache/common-lisp" :uid :implementation)))
     2488  ;; No good default, plus there's a security problem
     2489  ;; with other users messing with such directories.
     2490  *user-cache*)
    23232491
    23242492(defun output-translations ()
     
    25162684    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    25172685    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
    2518     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2519     #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
    25202686    ;; All-import, here is where we want user stuff to be:
    25212687    :inherit-configuration
     2688    ;; These are for convenience, and can be overridden by the user:
     2689    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     2690    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    25222691    ;; If we want to enable the user cache by default, here would be the place:
    25232692    :enable-user-cache))
     
    27072876(defun translate-jar-pathname (source wildcard)
    27082877  (declare (ignore wildcard))
    2709   (let ((root (apply-output-translations
    2710                (concatenate 'string
    2711                             "/:jar:file/"
    2712                             (namestring (first (pathname-device
    2713                                                 source))))))
    2714         (entry (make-pathname :directory (pathname-directory source)
    2715                               :name (pathname-name source)
    2716                               :type (pathname-type source))))
    2717     (concatenate 'string (namestring root) (namestring entry))))
     2878  (let* ((p (pathname (first (pathname-device source))))
     2879         (root (format nil "/___jar___file___root___/~@[~A/~]"
     2880                       (and (find :windows *features*)
     2881                            (pathname-device p)))))
     2882    (apply-output-translations
     2883     (merge-pathnames*
     2884      (relativize-pathname-directory source)
     2885      (merge-pathnames*
     2886       (relativize-pathname-directory (ensure-directory-pathname p))
     2887       root)))))
    27182888
    27192889;;;; -----------------------------------------------------------------
     
    28553025  (values))
    28563026
     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
    28573048(defun sysdef-source-registry-search (system)
    28583049  (ensure-source-registry)
    2859   (let ((name (coerce-name system)))
    2860     (block nil
    2861       (dolist (dir (source-registry))
    2862         (let ((defaults (eval dir)))
    2863           (when defaults
    2864             (cond ((directory-pathname-p defaults)
    2865                    (let ((file (and defaults
    2866                                     (make-pathname
    2867                                      :defaults defaults :version :newest
    2868                                      :name name :type "asd" :case :local)))
    2869                          #+(and (or win32 windows) (not :clisp))
    2870                          (shortcut (make-pathname
    2871                                     :defaults defaults :version :newest
    2872                                     :name name :type "asd.lnk" :case :local)))
    2873                      (when (and file (probe-file file))
    2874                        (return file))
    2875                      #+(and (or win32 windows) (not :clisp))
    2876                      (when (probe-file shortcut)
    2877                        (let ((target (parse-windows-shortcut shortcut)))
    2878                          (when target
    2879                            (return (pathname target))))))))))))))
     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))
    28803054
    28813055(defun validate-source-registry-directive (directive)
     
    29423116  (if (not recurse)
    29433117      (funcall collect directory)
    2944       (let* ((files (ignore-errors
    2945                       (directory (merge-pathnames* *wild-asd* directory)
    2946                                  #+sbcl #+sbcl :resolve-symlinks nil
    2947                                  #+clisp #+clisp :circle t)))
     3118      (let* ((files
     3119              (handler-case
     3120                  (directory (merge-pathnames* *wild-asd* directory)
     3121                             #+sbcl #+sbcl :resolve-symlinks nil
     3122                             #+clisp #+clisp :circle t)
     3123                (error (c)
     3124                  (warn "Error while scanning system definitions under directory ~S:~%~A"
     3125                        directory c)
     3126                  nil)))
    29483127             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    29493128                                      :test #'equal :from-end t)))
     
    29823161           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    29833162          (dirs (cons datahome (split-string datadirs :separator ":"))))
    2984          #+(and windows (not cygwin))
    2985          ((datahome
    2986            #+lispworks (sys:get-folder-path :common-appdata)
    2987            #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
    2988                             "Application Data"))
     3163         #+(and (or win32 windows mswindows mingw32) (not cygwin))
     3164         ((datahome (getenv "APPDATA"))
    29893165          (datadir
    29903166           #+lispworks (sys:get-folder-path :local-appdata)
     
    29923168                            "Application Data"))
    29933169          (dirs (list datahome datadir)))
    2994          #+(and (not unix) (not windows) (not cygwin))
     3170         #-(or unix win32 windows mswindows mingw32 cygwin)
    29953171         ((dirs ()))
    29963172         (loop :for dir :in dirs
     
    30943270
    30953271;;;; -----------------------------------------------------------------
    3096 ;;;; SBCL and ClozureCL hook into REQUIRE
     3272;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    30973273;;;;
    3098 #+(or sbcl clozure abcl)
     3274#+(or abcl clozure cmu ecl sbcl)
    30993275(progn
    31003276  (defun module-provide-asdf (name)
     
    31063282                          name e))))
    31073283      (let* ((*verbose-out* (make-broadcast-stream))
    3108              (system (asdf:find-system name nil)))
     3284             (system (find-system name nil)))
    31093285        (when system
    3110           (asdf:operate 'asdf:load-op name)
     3286          (load-system name)
    31113287          t))))
    31123288  (pushnew 'module-provide-asdf
    3113            #+sbcl sb-ext:*module-provider-functions*
     3289           #+abcl sys::*module-provider-functions*
    31143290           #+clozure ccl::*module-provider-functions*
    3115            #+abcl sys::*module-provider-functions*))
     3291           #+cmu ext:*module-provider-functions*
     3292           #+ecl si:*module-provider-functions*
     3293           #+sbcl sb-ext:*module-provider-functions*))
    31163294
    31173295;;;; -------------------------------------------------------------------------
  • branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp

    r12516 r12679  
    210210             (float (/ (ext:uptime) 1000)))))
    211211
    212 ;;; "system.lisp" contains system installation specific information
    213 ;;; (currently only the logical pathname definition for "SYS;SRC")
    214 ;;; that is not currently required for ABCL to run.  Since
    215 ;;; LOAD-SYSTEM-FILE exits the JVM if its argument cannot be found, we
    216 ;;; use REQUIRE trapping any error.
    217 (handler-case
    218     (require 'system)
    219   (t ()))
    220 
     212
  • branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp

    r12586 r12679  
    5454(export '(class-precedence-list class-slots))
    5555(defconstant +the-standard-class+ (find-class 'standard-class))
     56(defconstant +the-standard-object-class+ (find-class 'standard-object))
     57(defconstant +the-standard-method-class+ (find-class 'standard-method))
     58(defconstant +the-standard-reader-method-class+
     59  (find-class 'standard-reader-method))
     60(defconstant +the-standard-generic-function-class+
     61  (find-class 'standard-generic-function))
     62(defconstant +the-T-class+ (find-class 'T))
    5663
    5764;; Don't use DEFVAR, because that disallows loading clos.lisp
     
    557564                                             &allow-other-keys)
    558565  (let ((supers (or direct-superclasses
    559                     (list (find-class 'standard-object)))))
     566                    (list +the-standard-object-class+))))
    560567    (setf (class-direct-superclasses class) supers)
    561568    (dolist (superclass supers)
     
    580587  (getf canonical-slot :name))
    581588
    582 (defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object)))
     589(defvar *extensible-built-in-classes*
     590  (list (find-class 'sequence)
     591        (find-class 'java:java-object)))
    583592
    584593(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
     
    741750  (set-generic-function-classes-to-emf-table gf new-value))
    742751
    743 (defvar the-class-standard-method (find-class 'standard-method))
    744 
    745752(defun (setf method-lambda-list) (new-value method)
    746753  (set-method-lambda-list method new-value))
     
    851858                                &key
    852859                                lambda-list
    853                                 (generic-function-class (find-class 'standard-generic-function))
    854                                 (method-class the-class-standard-method)
     860                                (generic-function-class +the-standard-generic-function-class+)
     861                                (method-class +the-standard-method-class+)
    855862                                (method-combination 'standard)
    856863                                (argument-precedence-order nil apo-p)
     
    886893                   :format-control "~A already names an ordinary function, macro, or special operator."
    887894                   :format-arguments (list function-name)))
    888           (setf gf (apply (if (eq generic-function-class (find-class 'standard-generic-function))
     895          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
    889896                              #'make-instance-standard-generic-function
    890897                              #'make-instance)
     
    899906  (set-funcallable-instance-function
    900907   gf
    901    (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
     908   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
    902909                #'std-compute-discriminating-function
    903910                #'compute-discriminating-function)
     
    934941                                                documentation)
    935942  (declare (ignore generic-function-class))
    936   (let ((gf (std-allocate-instance (find-class 'standard-generic-function))))
     943  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
    937944    (%set-generic-function-name gf name)
    938945    (setf (generic-function-lambda-list gf) lambda-list)
     
    11631170        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
    11641171    (let ((method
    1165            (if (eq (generic-function-method-class gf) the-class-standard-method)
     1172           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
    11661173               (apply #'make-instance-standard-method gf all-keys)
    11671174               (apply #'make-instance (generic-function-method-class gf) all-keys))))
     
    11781185                                      fast-function)
    11791186  (declare (ignore gf))
    1180   (let ((method (std-allocate-instance the-class-standard-method)))
     1187  (let ((method (std-allocate-instance +the-standard-method-class+)))
    11811188    (setf (method-lambda-list method) lambda-list)
    11821189    (setf (method-qualifiers method) qualifiers)
     
    13671374      methods
    13681375      (sort methods
    1369       (if (eq (class-of gf) (find-class 'standard-generic-function))
     1376      (if (eq (class-of gf) +the-standard-generic-function-class+)
    13701377    #'(lambda (m1 m2)
    13711378        (std-method-more-specific-p m1 m2 required-classes
     
    14201427  (let ((applicable-methods (%compute-applicable-methods gf args)))
    14211428    (if applicable-methods
    1422         (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
     1429        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
    14231430                                  #'std-compute-effective-method-function
    14241431                                  #'compute-effective-method-function)
     
    14311438  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
    14321439    (if applicable-methods
    1433         (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
     1440        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
    14341441                                  #'std-compute-effective-method-function
    14351442                                  #'compute-effective-method-function)
     
    15171524       (let ((next-emfun
    15181525              (funcall
    1519                (if (eq (class-of gf) (find-class 'standard-generic-function))
     1526               (if (eq (class-of gf) +the-standard-generic-function-class+)
    15201527                   #'std-compute-effective-method-function
    15211528                   #'compute-effective-method-function)
     
    17671774                                             slot-name)
    17681775  (declare (ignore gf))
    1769   (let ((method (std-allocate-instance (find-class 'standard-reader-method))))
     1776  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
    17701777    (setf (method-lambda-list method) lambda-list)
    17711778    (setf (method-qualifiers method) qualifiers)
     
    18181825                   :lambda-list '(new-value object)
    18191826                   :qualifiers ()
    1820                    :specializers (list (find-class 't) class)
     1827                   :specializers (list +the-T-class+ class)
    18211828;;                    :function `(function ,method-function)
    18221829                   :function (if (autoloadp 'compile)
  • branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp

    r12672 r12679  
    4141(defvar *output-file-pathname*)
    4242
    43 (defvar *function-packages* nil "An alist containing mappings (function-number . package). Every time an (IN-PACKAGE pkg) form is found at top-level, (*class-number* . pkg) is pushed onto this list.")
    44 
    4543(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
    4644  (sanitize-class-name (pathname-name output-file-pathname)))
     
    134132          ((IN-PACKAGE DEFPACKAGE)
    135133           (note-toplevel-form form)
    136      (if (eq operator 'in-package)
    137          (push (cons (1+ *class-number*) (cadr form)) *function-packages*))
    138134           (setf form (precompiler:precompile-form form nil *compile-file-environment*))
    139135           (eval form)
     
    549545             (*source* *compile-file-truename*)
    550546             (*class-number* 0)
    551        (*function-packages* nil)
    552547             (namestring (namestring *compile-file-truename*))
    553548             (start (get-internal-real-time))
    554              elapsed)
     549             elapsed
     550             *fasl-uninterned-symbols*)
    555551        (when *compile-verbose*
    556552          (format t "; Compiling ~A ...~%" namestring))
     
    565561                  (jvm::*functions-defined-in-current-file* '())
    566562                  (*fbound-names* '())
    567                   (*fasl-anonymous-package* (%make-package))
    568563                  (*fasl-stream* out)
    569564                  *forms-for-output*)
     
    604599            (%stream-terpri out)
    605600            (let ((*package* (find-package '#:cl)))
    606                   ;(count-sym (gensym)))
    607601              (write (list 'init-fasl :version *fasl-version*)
    608602                     :stream out)
     
    611605                     :stream out)
    612606              (%stream-terpri out)
     607        ;; Note: Beyond this point, you can't use DUMP-FORM,
     608        ;; because the list of uninterned symbols has been fixed now.
     609        (when *fasl-uninterned-symbols*
     610    (write (list 'setq '*fasl-uninterned-symbols*
     611           (coerce (mapcar #'car
     612               (nreverse *fasl-uninterned-symbols*))
     613             'vector))
     614           :stream out))
     615        (%stream-terpri out)
    613616
    614617        (when (> *class-number* 0)
     
    617620        (identity fasl-loader) ;;to avoid unused arg
    618621        ;;Ugly: should export & import JVM:: symbols
    619         #|(let ((*package* *package*))
    620         ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined
    621           (when x
    622             `(in-package ,(string x))))|#
    623622        (ecase fn-index
    624623          ,@(loop
     
    626625               :collect
    627626           (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
    628              `(,(1- i) (jvm::with-inline-code ()
    629           ;(jvm::emit 'jvm::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*)))
    630           ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system)))
    631           ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage"
    632           ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+)
    633           ;(jvm::emit-push-current-thread)
    634           ;           (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue"
    635           ;                  (list jvm::+lisp-thread+) jvm::+lisp-object+)
    636               (jvm::emit 'jvm::aload 1)
    637               (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
    638                      nil jvm::+java-object+)
    639               (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
    640               (jvm::emit 'jvm::dup)
    641               (jvm::emit-push-constant-int ,(1- i))
    642               (jvm::emit 'jvm::new ,class)
    643               (jvm::emit 'jvm::dup)
    644               (jvm::emit-invokespecial-init ,class '())
    645               (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
    646                      (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
    647               (jvm::emit 'jvm::pop))
    648             t))))))
     627             `(,(1- i)
     628                (jvm::with-inline-code ()
     629            (jvm::emit 'jvm::aload 1)
     630            (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
     631                   nil jvm::+java-object+)
     632            (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
     633            (jvm::emit 'jvm::dup)
     634            (jvm::emit-push-constant-int ,(1- i))
     635            (jvm::emit 'jvm::new ,class)
     636            (jvm::emit 'jvm::dup)
     637            (jvm::emit-invokespecial-init ,class '())
     638            (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
     639                   (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
     640            (jvm::emit 'jvm::pop))
     641                t))))))
    649642           (classname (fasl-loader-classname))
    650643           (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
     
    658651         :if-exists :supersede)
    659652          (jvm:compile-defun nil expr nil
    660                  classfile f nil)))))
     653                 classfile f nil))))
     654      (format t "~&; Wrote fasl loader ~A~%" classfile))
    661655    (write (list 'setq '*fasl-loader*
    662656           `(sys::make-fasl-class-loader
    663657             ,*class-number*
    664              ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)
    665     (%stream-terpri out))
    666 #|        (dump-form
    667          `(dotimes (,count-sym ,*class-number*)
    668       (java:jcall "loadFunction" *fasl-loader*
    669             (%format nil "~A_~D"
    670                ,(sanitize-class-name
    671            (pathname-name output-file))
    672                (1+ ,count-sym))))
    673          out)|#
    674 
    675         ;;END TODO
    676 
    677 #|              (dump-form `(dotimes (,count-sym ,*class-number*)
    678                             (function-preload
    679                              (%format nil "~A_~D.cls"
    680                                       ,(sanitize-class-name
    681           (pathname-name output-file))
    682                                       (1+ ,count-sym))))
    683        out)|#
     658             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
    684659              (%stream-terpri out))
    685660
     
    700675                           (merge-pathnames (make-pathname :type type)
    701676                                            output-file)))
    702                  (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
    703                      output-file)))))
     677                 (pathnames nil)
     678     (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
     679                 output-file))))
     680      (when (probe-file fasl-loader)
     681        (push fasl-loader pathnames))
    704682            (dotimes (i *class-number*)
    705683              (let* ((pathname (compute-classfile-name (1+ i))))
  • branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12638 r12679  
    23432343  (let ((g (symbol-name (gensym "INSTANCE")))
    23442344        saved-code)
    2345     (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj)
    23462345    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
    23472346           (*code* (if *declare-inline* *code* *static-code*)))
     
    50205019
    50215020(defun p2-progv-node (block target representation)
    5022   (declare (ignore representation))
    50235021  (let* ((form (progv-form block))
    50245022         (symbols-form (cadr form))
     
    50415039      ;; Implicit PROGN.
    50425040    (let ((*blocks* (cons block *blocks*)))
    5043       (compile-progn-body (cdddr form) target))
     5041      (compile-progn-body (cdddr form) target representation))
    50445042    (restore-environment-and-make-handler environment-register label-START)))
    50455043
     
    61256123                (emit-invokevirtual +lisp-stream-class+ "readLine"
    61266124                                    (list "Z" +lisp-object+) +lisp-object+)
    6127                 (when target
    6128                   (emit-move-from-stack target)))
     6125                (emit-move-from-stack target))
    61296126               (t
    61306127                (compile-function-call form target representation)))))
     
    61416138                (emit-invokevirtual +lisp-stream-class+ "readLine"
    61426139                                    (list "Z" +lisp-object+) +lisp-object+)
    6143                 (when target
    6144                   (emit-move-from-stack target))
     6140                (emit-move-from-stack target)
    61456141                )
    61466142               (t
     
    85818577      (setf *code* (nconc code *code*)))
    85828578
     8579    (setf (abcl-class-file-superclass class-file)
     8580          (if (or *hairy-arglist-p*
     8581      (and *child-p* *closure-variables*))
     8582        +lisp-compiled-closure-class+
     8583      +lisp-primitive-class+))
     8584
     8585    (setf (abcl-class-file-lambda-list class-file) args)
     8586    (setf (method-max-locals execute-method) *registers-allocated*)
     8587    (push execute-method (abcl-class-file-methods class-file))
     8588
     8589
     8590    ;;;  Move here
    85838591    (finalize-code)
    85848592    (optimize-code)
     
    85948602                            (symbol-value (handler-to handler))))
    85958603                     *handlers*))
    8596 
    8597     (setf (method-max-locals execute-method) *registers-allocated*)
    8598     (setf (method-handlers execute-method) (nreverse *handlers*))
    8599 
    8600     (setf (abcl-class-file-superclass class-file)
    8601           (if (or *hairy-arglist-p*
    8602       (and *child-p* *closure-variables*))
    8603         +lisp-compiled-closure-class+
    8604       +lisp-primitive-class+))
    8605 
    8606     (setf (abcl-class-file-lambda-list class-file) args)
    8607 
    8608     (push execute-method (abcl-class-file-methods class-file)))
     8604    ;;; to here
     8605    ;;; To a separate function which is part of class file finalization
     8606    ;;;  when we have a section of class-file-generation centered code
     8607
     8608
     8609    (setf (method-handlers execute-method) (nreverse *handlers*)))
    86098610  t)
    86108611
     
    88068807        (*local-functions* nil)
    88078808        (*pathnames-generator* (constantly nil))
    8808         (sys::*fasl-anonymous-package* (sys::%make-package))
    88098809        environment)
    88108810    (unless (and (consp definition) (eq (car definition) 'LAMBDA))
  • branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp

    r11566 r12679  
    104104             (java:java-object-p object))
    105105         (dump-instance object stream))
     106        ((and (symbolp object) ;; uninterned symbol
     107              (null (symbol-package object)))
     108         (let ((index (cdr (assoc object *fasl-uninterned-symbols*))))
     109           (unless index
     110             (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
     111             (setq *fasl-uninterned-symbols*
     112                   (acons object index *fasl-uninterned-symbols*)))
     113           (write-string "#" stream)
     114           (write index :stream stream)
     115           (write-string "?" stream)))
    106116        (t
    107117         (%stream-output-object object stream))))
  • branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp

    r12630 r12679  
    326326
    327327;;; JAVA-CLASS support
     328(defconstant +java-lang-object+ (jclass "java.lang.Object"))
    328329
    329330(defclass java-class (standard-class)
     
    331332     :initform (error "class is required")
    332333     :reader java-class-jclass)))
     334
     335;;init java.lang.Object class
     336(defconstant +java-lang-object-class+
     337  (%register-java-class +java-lang-object+
     338      (mop::ensure-class (make-symbol "java.lang.Object")
     339             :metaclass (find-class 'java-class)
     340             :direct-superclasses (list (find-class 'java-object))
     341             :java-class +java-lang-object+)))
    333342
    334343(defun ensure-java-class (jclass)
     
    341350     :metaclass (find-class 'java-class)
    342351     :direct-superclasses
    343      (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
    344          (list (find-class 'java-object))
    345          (mapcar #'ensure-java-class
    346            (delete nil
    347              (concatenate 'list (list (jclass-superclass jclass))
    348               (jclass-interfaces jclass)))))
     352     (let ((supers
     353      (mapcar #'ensure-java-class
     354        (delete nil
     355          (concatenate 'list
     356                 (list (jclass-superclass jclass))
     357                 (jclass-interfaces jclass))))))
     358       (if (jclass-interface-p jclass)
     359           (append supers (list (find-class 'java-object)))
     360           supers))
    349361     :java-class jclass)))))
    350362
     363(defmethod mop::compute-class-precedence-list ((class java-class))
     364  "Sort classes this way:
     365   1. Java classes (but not java.lang.Object)
     366   2. Java interfaces
     367   3. java.lang.Object
     368   4. other classes
     369   Rationale:
     370   1. Concrete classes are the most specific.
     371   2. Then come interfaces.
     372     So if a generic function is specialized both on an interface and a concrete class,
     373     the concrete class comes first.
     374   3. because everything is an Object.
     375   4. to handle base CLOS classes.
     376   Note: Java interfaces are not sorted among themselves in any way, so if a
     377   gf is specialized on two different interfaces and you apply it to an object that
     378   implements both, it is unspecified which method will be called."
     379  (let ((cpl (nreverse (mop::collect-superclasses* class))))
     380    (flet ((score (class)
     381       (if (not (typep class 'java-class))
     382     4
     383     (cond
     384       ((jcall (jmethod "java.lang.Object" "equals" "java.lang.Object")
     385         (java-class-jclass class) +java-lang-object+) 3)
     386       ((jclass-interface-p (java-class-jclass class)) 2)
     387       (t 1)))))
     388      (stable-sort cpl #'(lambda (x y)
     389         (< (score x) (score y)))))))
     390   
    351391(defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys)
    352392  (declare (ignore initargs))
  • branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java

    r12611 r12679  
    9393            }
    9494
    95             String head = "HEAD " + url + " HTTP/1.1";
     95            String head = "HEAD " + url.getPath() + " HTTP/1.1";
    9696            out.println(head);
     97            out.println("Host: " + url.getAuthority());
    9798            out.println("Connection: close");
    9899            out.println("");
  • branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp

    r12617 r12679  
    125125;;; XXX come up with a better abstraction
    126126
     127(defvar *url-jar-pathname-base*
     128  "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20100505a.jar!/")
     129
     130(defmacro load-url-relative (path)
     131  `(load (format nil "~A~A" *url-jar-pathname-base* ,path)))
     132
    127133(progn
    128134  (deftest jar-pathname.load.11
    129       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo")
     135      (load-url-relative "foo")
    130136    t)
    131137
    132138  (deftest jar-pathname.load.12
    133       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar")
     139      (load-url-relative "bar")
    134140    t)
    135141
    136142  (deftest jar-pathname.load.13
    137       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl")
     143      (load-url-relative "bar.abcl")
    138144    t)
    139145
    140146  (deftest jar-pathname.load.14
    141       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek")
     147      (load-url-relative "eek")
    142148    t)
    143149
    144150  (deftest jar-pathname.load.15
    145       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp")
     151      (load-url-relative "eek.lisp")
    146152    t)
    147153
    148154  (deftest jar-pathname.load.16
    149       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo")
     155      (load-url-relative "a/b/foo")
    150156    t)
    151157
    152158  (deftest jar-pathname.load.17
    153       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar")
     159      (load-url-relative "a/b/bar")
    154160    t)
    155161
    156162  (deftest jar-pathname.load.18
    157       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl")
     163      (load-url-relative "a/b/bar.abcl")
    158164    t)
    159165
    160166  (deftest jar-pathname.load.19
    161       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek")
     167      (load-url-relative "a/b/eek")
    162168    t)
    163169
    164170  (deftest jar-pathname.load.20
    165       (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp")
     171      (load-url-relative "a/b/eek.lisp")
    166172    t))
    167 
    168173
    169174(deftest jar-pathname.probe-file.1
     
    215220     "jar:file:baz.jar!/foo" "/a/b/c")
    216221  #p"jar:file:/a/b/baz.jar!/foo")
     222
     223
     224;;; Under win32, we get the device in the merged path
     225#+windows
     226(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
    217227
    218228(deftest jar-pathname.merge-pathnames.5
     
    333343
    334344(deftest jar-pathname.translate.1
    335     (namestring
    336      (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp"
    337                          "jar:file:/**/*.jar!/**/*.*"
    338                          "/foo/**/*.*"))
    339   "/foo/d/e/f.lisp")
     345    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp"
     346      "jar:file:/**/*.jar!/**/*.*"
     347      "/foo/**/*.*")
     348  #p"/foo/d/e/f.lisp")
    340349
    341350     
Note: See TracChangeset for help on using the changeset viewer.