Changeset 12679
- Timestamp:
- 05/13/10 21:15:07 (13 years ago)
- Location:
- branches/less-reflection/abcl
- Files:
-
- 29 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/less-reflection/abcl/CHANGES
r12536 r12679 1 Version 0.20 2 ============ 3 yet-to-be-tagged 4 (???) 5 6 7 Features 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 29 Fixes 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 57 Other 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 1 66 Version 0.19 2 67 ============ … … 79 144 * [svn r12441] ZipCache now caches all references to ZipFiles based on 80 145 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 83 148 SYS:REMOVE-ZIP-CACHE implements a way to invalidate an entry given a 84 149 pathname. … … 188 253 189 254 * New toplevel 'doc' directory now contains: 190 255 191 256 + [svn r12410] Design for the (in progress) reworking of the Stream 192 257 inheritance. 193 258 194 259 + [svn r12433] Design and current status for the re-implementation 195 260 of jar pathnames. … … 197 262 * [svn r12402] Change ABCL unit tests to use the ABCL-TEST-LISP definition 198 263 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. 200 265 201 266 * [svn r12401] The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now 202 267 tracks whether local functions need the capture of an actual 203 268 function object. 204 269 205 270 206 271 Version 0.18.1 -
branches/less-reflection/abcl/abcl.asd
r12610 r12679 33 33 ((:file "compiler-tests") 34 34 (:file "condition-tests") 35 (:file "metaclass") 35 36 (:file "mop-tests-setup") 36 37 (:file "mop-tests" :depends-on ("mop-tests-setup")) -
branches/less-reflection/abcl/abcl.properties.in
r12543 r12679 12 12 # java.options sets the Java options in the abcl wrapper scripts 13 13 #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 102 102 <echo>Compiled ABCL with Java version: ${java.version}</echo> 103 103 </target> 104 104 105 105 <target name="abcl.clean.maybe" unless="abcl.build.incremental"> 106 106 <echo>Cleaning all intermediate compilation artifacts.</echo> … … 144 144 <or> 145 145 <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]"/> 147 147 </or> 148 148 </condition> … … 177 177 debug="true" 178 178 target="1.5" 179 includeantruntime="false" 179 180 failonerror="true"> 180 181 <src path="${src.dir}"/> … … 224 225 location="${build.classes.dir}/org/armedbear/lisp/"/> 225 226 <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"/> 226 230 227 231 <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" 229 233 unless="abcl.fasls.uptodate.p"> 230 234 <echo> … … 239 243 <jvmarg value="-Dabcl.home=${abcl.home.dir}${file.separator}"/> 240 244 <arg value="--noinit"/> 245 <arg value="--nosystem"/> 241 246 <arg value="--eval"/> 242 247 <arg value="(setf *load-verbose* t)"/> 243 248 </java> 249 <concat destfile="${system.lisp.file}" append="true"> 250 <fileset file="${abcl.startup.file}"/> 251 </concat> 244 252 </target> 245 253 … … 270 278 <exec executable="hostname" outputproperty="abcl.hostname"/> 271 279 <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"/> 272 297 </target> 273 298 … … 672 697 classpathref="abcl.test.run.classpath" 673 698 classname="org.junit.runner.JUnitCore"> 674 <arg value="org.armedbear.lisp.FastStringBufferTest"/>675 699 <arg value="org.armedbear.lisp.PathnameTest"/> 676 700 <arg value="org.armedbear.lisp.StreamTest"/> 701 <arg value="org.armedbear.lisp.UtilitiesTest"/> 677 702 </java> 678 703 </target> … … 706 731 <arg value="--eval"/><arg value="(require (quote asdf))"/> 707 732 <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))"/> 709 734 <arg value="--eval"/><arg value="(ext:exit)"/> 710 735 </java> -
branches/less-reflection/abcl/contrib/asdf-install/installer.lisp
r12487 r12679 542 542 543 543 (defmethod asdf:find-component :around 544 ((module (eql nil)) name &optional version) 545 (declare (ignore version)) 544 ((module (eql nil)) name) 546 545 (when (or (not *propagate-installation*) 547 546 (member name *systems-installed-this-time* -
branches/less-reflection/abcl/doc/asdf/asdf.texinfo
r12618 r12679 32 32 This manual describes ASDF, a system definition facility 33 33 for Common Lisp programs and libraries. 34 35 You can find the latest version of this manual at 36 @url{http://common-lisp.net/project/asdf/asdf.html}. 34 37 35 38 ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. … … 168 171 169 172 @emph{Nota Bene}: 170 We are preparing for a release of ASDF 2, 173 We are preparing for a release of ASDF 2, hopefully for May 2010, 171 174 which will have version 2.000 and later. 172 Current releases, in the 1. 600 series and beyond,175 Current releases, in the 1.700 series and beyond, 173 176 should be considered as release candidates. 174 177 We'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?''}. 176 179 177 180 … … 239 242 If it returns @code{NIL} then ASDF is not installed. 240 243 241 If you are running a version older than 1. 678,244 If you are running a version older than 1.711, 242 245 we recommend that you load a newer ASDF using the method below. 243 246 … … 533 536 ASDF-Binary-Locations, cl-launch, common-lisp-controller. 534 537 ASDF-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 updated538 cl-launch 2.900 and common-lisp-controller 7.1 have been updated 536 539 to just delegate this functionality to ASDF. 537 540 … … 550 553 @end example 551 554 552 On some implementations (namely , SBCL and ClozureCL),555 On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL), 553 556 ASDF hooks into the @code{CL:REQUIRE} facility 554 557 and you can just use: … … 1317 1320 which doesn't provide any obvious way to specify required features. 1318 1321 Furthermore, in 2009, discussions on the 1319 @ur ef{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} 1320 1323 suggested that the specification of required features may be broken, 1321 1324 and that no one may have been using them for a while. 1322 1325 Please contact the 1323 @ur ef{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} 1324 1327 if you are interested in getting this features feature fixed.} 1325 1328 … … 1672 1675 Mentions of XDG variables refer to that document. 1673 1676 1674 @ur ef{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}1677 @url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} 1675 1678 1676 1679 This specification allows the user to specify some environment variables … … 2464 2467 2465 2468 You 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} 2467 2470 2468 2471 You will find the above referenced tags in this repository. … … 2473 2476 mailing list 2474 2477 @kbd{asdf-devel@@common-lisp.net}. 2475 @ur ef{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}2478 @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} 2476 2479 2477 2480 … … 2485 2488 2486 2489 If you're unsure about whether something is a bug, of for general discussion, 2487 use the @ur ef{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}2490 use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} 2488 2491 2489 2492 … … 2497 2500 we are still working on polishing them before release. 2498 2501 2499 Releases in the 1. 600 series and beyond2502 Releases in the 1.700 series and beyond 2500 2503 should be considered as release candidates. 2501 2504 For all practical purposes, … … 2514 2517 2515 2518 2516 @subsection ASDF can portably name files in side systems and components2519 @subsection ASDF can portably name files in subdirectories 2517 2520 2518 2521 Common Lisp namestrings are not portable, 2519 2522 except 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 2523 that themselves have various limitations and require a lot of setup 2524 that is itself ultimately non-portable. 2525 2526 In ASDF 1, the only portable ways to refer to pathnames inside systems and components 2522 2527 were very awkward, using @code{#.(make-pathname ...)} and 2523 2528 @code{#.(merge-pathnames ...)}. … … 2535 2540 @xref{The defsystem grammar,,Pathname specifiers}. 2536 2541 2542 2537 2543 @subsection Output translations 2538 2544 … … 2572 2578 and a coherent set of configuration files and hooks. 2573 2579 2580 We believe it's a vast improvement because it decouples 2581 application distribution from library distribution. 2582 The application writer can avoid thinking where the libraries are, 2583 and the library distributor (dpkg, clbuild, advanced user, etc.) 2584 can configure them once and for every application. 2585 Yet settings can be easily overridden where needed, 2586 so whoever needs control has exactly as much as required. 2587 2574 2588 At the same time, ASDF 2 remains compatible 2575 2589 with the old magic you may have in your build scripts 2590 (using @code{*central-registry*} and 2591 @code{*system-definition-search-functions*}) 2576 2592 to tailor the ASDF configuration to your build automation needs, 2577 2593 and also allows for new magic, simpler and more powerful magic. 2578 2594 2579 2595 @xref{Controlling where ASDF searches for systems}. 2596 2580 2597 2581 2598 @subsection Usual operations are made easier to the user … … 2593 2610 @subsection Many bugs have been fixed 2594 2611 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 2612 The following issues and many others have been fixed: 2613 2614 @itemize 2615 @item 2616 The infamous TRAVERSE function has been revamped significantly, 2617 with many bugs squashed. 2618 In particular, dependencies were not correctly propagated 2619 across submodules within a system but now are. 2620 The :version and :feature features and 2621 the :force (system1 .. systemN) feature have been fixed. 2622 2623 @item 2624 Performance has been notably improved for large systems 2625 (say with thousands of components) by using 2626 hash-tables instead of linear search, 2627 and linear-time list accumulation 2628 instead of quadratic-time recursive appends. 2629 2630 @item 2601 2631 Many features used to not be portable, 2602 2632 especially 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 2633 Windows support was notably quirky because of such non-portability. 2634 2635 @item 2636 The internal test suite used to massively fail on many implementations. 2637 While still incomplete, it now fully passes 2638 on all implementations supported by the test suite. 2639 2640 @item 2641 Support was lacking for some implementations. 2642 ABCL was notably wholly broken. 2643 ECL extensions were not integrated in the ASDF release. 2644 2645 @item 2609 2646 The documentation was grossly out of date. 2610 2647 2611 ECL extensions were not integrated in the ASDF release. 2648 @end itemize 2612 2649 2613 2650 … … 2624 2661 that everyone can rely on from now on. 2625 2662 Use @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")} 2627 2664 to check the availability of a version no earlier than required. 2665 2628 2666 2629 2667 @subsection ASDF can be upgraded … … 2668 2706 towards the latest version for everyone. 2669 2707 2708 2709 @subsection Pitfalls of ASDF 2 2710 2711 The main pitfalls in upgrading to ASDF 2 seem to be related 2712 to the output translation mechanism. 2713 2714 @itemize 2715 2716 @item 2717 Output translations is enabled by default. This may surprise some users, 2718 most of them in pleasant way (we hope), a few of them in an unpleasant way. 2719 It is trivial to disable output translations. 2720 @xref{FAQ,,``How can I wholly disable the compiler output cache?''}. 2721 2722 @item 2723 Some systems in the large have been known not to play well with output translations. 2724 They were relatively easy to fix. 2725 Once again, it is also easy to disable output translations, 2726 or to override its configuration. 2727 2728 @item 2729 The new ASDF output translations are incompatible with ASDF-Binary-Locations. 2730 They replace A-B-L, and there is compatibility mode to emulate 2731 your previous A-B-L configuration. 2732 See @code{asdf:enable-asdf-binary-locations-compatibility} in 2733 @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. 2734 But thou shall not load ABL on top of ASDF 2. 2735 2736 @end itemize 2737 2738 Other issues include the following: 2739 2740 @itemize 2741 2742 @item 2743 There is a slight performance bug, notably on SBCL, 2744 when initially searching for @file{asd} files, 2745 the implicit @code{(directory "/configured/path/**/*.asd")} 2746 for every configured path @code{(:tree "/configured/path/")} 2747 in your @code{source-registry} configuration can cause a slight pause. 2748 Try to @code{(time (asdf:initialize-source-registry))} 2749 to see how bad it is or isn't on your system. 2750 If you insist on not having this pause, 2751 you can avoid the pause by overriding the default source-registry configuration 2752 and not use any deep @code{:tree} entry but only @code{:directory} entries 2753 or shallow @code{:tree} entries. 2754 Or you can fix your implementation to not be quite that slow 2755 when recursing through directories. 2756 2757 @item 2758 On Windows, only LispWorks supports proper default configuration pathnames 2759 based on the Windows registry. 2760 Other implementations make do. 2761 Windows support is largely untested, so please help report and fix bugs. 2762 2763 @end itemize 2764 2765 2670 2766 @section Issues with installing the proper version of ASDF 2671 2767 … … 2691 2787 it's a bug that you should report upstream and that we will fix ASAP. 2692 2788 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 2789 As to how to include ASDF, we recommend the following: 2790 2791 @itemize 2792 @item 2793 If ASDF isn't installed yet, then @code{(require :asdf)} 2794 should load the version of ASDF that is bundled with your system. 2795 You may have it load some other version configured by the user, 2796 if you allow such configuration. 2797 2798 @item 2799 If your system provides a mechanism to hook into @code{CL:REQUIRE}, 2800 then it would be nice to add ASDF to this hook the same way that 2801 ABCL, CCL, CMUCL, ECL and SBCL do it. 2802 2803 @item 2804 You may, like SBCL, have ASDF be implicitly used to require systems 2805 that are bundled with your Lisp distribution. 2806 If you do have a few magic systems that come with your implementation 2807 in a precompiled way such that one should only use the binary version 2808 that goes with your distribution, like SBCL does, 2809 then you should add them in the beginning of @code{wrapping-source-registry}. 2810 2811 @item 2812 If you have magic systems as above, like SBCL does, 2813 then we explicitly ask you to @emph{NOT} distribute 2814 @file{asdf.asd} as part of those magic systems. 2815 You should still include the file @file{asdf.lisp} in your source distribution 2816 and precompile it in your binary distribution, 2817 but @file{asdf.asd} if included at all, 2818 should be secluded from the magic systems, 2819 in a separate file hierarchy, 2820 or 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}. 2823 Indeed, if you made @file{asdf.asd} a magic system, 2824 then users would no longer be able to upgrade ASDF using ASDF itself 2825 to some version of their preference that 2826 they maintain independently from your Lisp distribution. 2827 2828 @item 2703 2829 If you do not have any such magic systems, or have other non-magic systems 2704 2830 that you want to bundle with your implementation, … … 2706 2832 and you are welcome to include @file{asdf.asd} amongst them. 2707 2833 2708 Please send upstream any patches you make to ASDF itself, 2834 @item 2835 Please send us upstream any patches you make to ASDF itself, 2709 2836 so we can merge them back in for the benefit of your users 2710 2837 when they upgrade to the upstream version. 2838 2839 @end itemize 2840 2711 2841 2712 2842 … … 2773 2903 @code{test-op} has been 2774 2904 a topic of considerable discussion on the 2775 @ur ef{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}, 2776 2906 and on the 2777 @ur ef{https://launchpad.net/asdf,launchpad bug-tracker}.2907 @url{https://launchpad.net/asdf,launchpad bug-tracker}. 2778 2908 2779 2909 Here are some guidelines: -
branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java
r12513 r12679 51 51 { 52 52 AUTOLOADING_CACHE, // allow loading local preloaded functions 53 Load._FASL_ ANONYMOUS_PACKAGE_, // package foruninterned symbols53 Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols 54 54 Symbol._PACKAGE_, // current package 55 55 Symbol.LOAD_TRUENAME // LOAD-TIME-VALUE depends on this -
branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java
r12604 r12679 142 142 { 143 143 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()); 150 145 } 151 146 }; … … 278 273 @Override 279 274 public LispObject execute(Stream stream, char c, int n) 280 281 275 { 282 276 return stream.readCharacterLiteral(FaslReadtable.getInstance(), … … 284 278 } 285 279 }; 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 286 312 } -
branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java
r12591 r12679 101 101 dtfunctions[12] = LispReader.SHARP_ILLEGAL; // page 102 102 dtfunctions[13] = LispReader.SHARP_ILLEGAL; // return 103 dtfunctions['?'] = FaslReader.FASL_SHARP_QUESTION_MARK; 103 104 dispatchTables.constants['#'] = dt; 104 105 -
branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java
r12672 r12679 53 53 54 54 private static boolean noinit = false; 55 private static boolean nosystem = false; 55 56 private static boolean noinform = false; 56 57 … … 93 94 initializeLisp(); 94 95 initializeTopLevel(); 96 if (!nosystem) 97 initializeSystem(); 95 98 if (!noinit) 96 99 processInitializationFile(); … … 118 121 initializeJLisp(); 119 122 initializeTopLevel(); 123 initializeSystem(); 120 124 processInitializationFile(); 121 125 return interpreter; … … 212 216 } 213 217 218 private static synchronized void initializeSystem() 219 { 220 Load.loadSystemFile("system"); 221 } 222 214 223 // Check for --noinit; verify that arguments are supplied for --load and 215 224 // --eval options. Copy all unrecognized arguments into … … 225 234 if (arg.equals("--noinit")) { 226 235 noinit = true; 236 } else if (arg.equals("--nosystem")) { 237 nosystem = true; 227 238 } else if (arg.equals("--noinform")) { 228 239 noinform = true; … … 281 292 sb.append(c.getCondition().writeToString()); 282 293 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))"); 286 296 System.exit(2); 287 297 } … … 466 476 throws UnhandledCondition 467 477 { 468 final Condition condition = (Condition)first;478 final LispObject condition = first; 469 479 if (interpreter == null) { 470 480 final LispThread thread = LispThread.currentThread(); -
branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java
r12561 r12679 116 116 } 117 117 118 // ### jclass name-or-class-ref => class-ref118 // ### jclass name-or-class-ref &optional class-loader => class-ref 119 119 private static final Primitive JCLASS = new pf_jclass(); 120 120 private static final class pf_jclass extends Primitive … … 122 122 pf_jclass() 123 123 { 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."); 126 126 } 127 127 … … 130 130 { 131 131 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 } 132 143 } 133 144 }; … … 1150 1161 } 1151 1162 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) { 1154 1168 try { 1155 return Class.forName(className );1169 return Class.forName(className, true, classLoader); 1156 1170 } 1157 1171 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); 1167 1180 } 1168 1181 1169 1182 // Supports Java primitive types too. 1170 static Class javaClass(LispObject obj )1183 static Class javaClass(LispObject obj, ClassLoader classLoader) 1171 1184 { 1172 1185 if (obj instanceof AbstractString || obj instanceof Symbol) { … … 1189 1202 return Double.TYPE; 1190 1203 // 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 } 1192 1210 if (c == null) 1193 1211 error(new LispError(s + " does not designate a Java class.")); -
branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
r12672 r12679 352 352 353 353 public static final LispObject error(LispObject condition) 354 355 354 { 356 355 pushJavaStackFrames(); … … 358 357 } 359 358 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 360 372 public static final LispObject error(LispObject condition, LispObject message) 361 362 373 { 363 374 pushJavaStackFrames(); 364 375 return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); 365 376 } 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 366 391 367 392 public static final LispObject type_error(LispObject datum, -
branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java
r12598 r12679 720 720 } 721 721 722 public String unreadableString(String s) {722 public final String unreadableString(String s) { 723 723 return unreadableString(s, true); 724 724 } 725 public String unreadableString(Symbol sym) {725 public final String unreadableString(Symbol sym) { 726 726 return unreadableString(sym, true); 727 727 } 728 728 729 public String unreadableString(String s, boolean identity)729 public final String unreadableString(String s, boolean identity) 730 730 { 731 731 StringBuilder sb = new StringBuilder("#<"); … … 740 740 } 741 741 742 public String unreadableString(Symbol symbol, boolean identity)742 public final String unreadableString(Symbol symbol, boolean identity) 743 743 744 744 { -
branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java
r12604 r12679 47 47 48 48 { 49 try 49 try 50 50 { 51 51 while (true) { 52 52 int n = stream._readChar(); 53 53 if (n < 0) 54 return null;54 return LispThread.currentThread().setValues(); 55 55 if (n == '\n') 56 return null;56 return LispThread.currentThread().setValues(); 57 57 } 58 58 } 59 59 catch (java.io.IOException e) 60 60 { 61 return null;61 return LispThread.currentThread().setValues(); 62 62 } 63 63 } … … 329 329 { 330 330 stream.skipBalancedComment(); 331 return null;331 return LispThread.currentThread().setValues(); 332 332 } 333 333 }; -
branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java
r12587 r12679 49 49 new ConcurrentHashMap<Thread,LispThread>(); 50 50 51 LispObject threadValue = NIL; 52 51 53 private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){ 52 54 @Override … … 88 90 { 89 91 try { 90 funcall(wrapper,92 threadValue = funcall(wrapper, 91 93 new LispObject[] { fun }, 92 94 LispThread.this); … … 931 933 }; 932 934 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 933 964 public static final long javaSleepInterval(LispObject lispSleep) 934 965 -
branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
r12672 r12679 85 85 LispObject abcl = Pathname.truename(abclPathname, false); 86 86 if (lisp instanceof Pathname && abcl instanceof Pathname) { 87 88 89 90 87 lispPathname = (Pathname)lisp; 88 abclPathname = (Pathname)abcl; 89 long lispLastModified = lispPathname.getLastModified(); 90 long abclLastModified = abclPathname.getLastModified(); 91 91 if (abclLastModified > lispLastModified) { 92 return abclPathname; // fasl file is newer 93 } else { 92 94 return lispPathname; 93 } else {94 return abclPathname;95 95 } 96 96 } else if (abcl instanceof Pathname) { … … 364 364 // internal symbol 365 365 static final Symbol _FASL_VERSION_ = 366 exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(3 5));366 exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36)); 367 367 368 368 // ### *fasl-external-format* … … 372 372 new SimpleString("UTF-8")); 373 373 374 // ### *fasl- anonymous-package*374 // ### *fasl-uninterned-symbols* 375 375 // internal symbol 376 376 /** 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. 379 380 * 380 381 */ 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); 383 384 384 385 // ### init-fasl &key version … … 396 397 // OK 397 398 final LispThread thread = LispThread.currentThread(); 398 thread.bindSpecial(_FASL_ ANONYMOUS_PACKAGE_, NIL);399 thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); 399 400 thread.bindSpecial(_SOURCE_, NIL); 400 401 return faslLoadStream(thread); … … 412 413 boolean auto) 413 414 { 414 return loadFileFromStream(pathname == null ? NIL : pathname, 415 truename == null ? NIL : truename, 415 return loadFileFromStream(pathname == null ? NIL : pathname, 416 truename == null ? NIL : truename, 416 417 in, verbose, print, auto, false); 417 418 } … … 586 587 LispObject result = NIL; 587 588 try { 588 thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package());589 589 thread.bindSpecial(AUTOLOADING_CACHE, 590 590 AutoloadedFunctionProxy.makePreloadingContext()); -
branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java
r12617 r12679 346 346 String scheme = url.getProtocol(); 347 347 if (scheme.equals("file")) { 348 Pathname p = new Pathname( s);348 Pathname p = new Pathname(url.getFile()); 349 349 this.host = p.host; 350 350 this.device = p.device; … … 681 681 if (type instanceof AbstractString) { 682 682 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 } 687 690 sb.append(t); 688 691 } else if (type == Keyword.WILD) { … … 738 741 if (directory != NIL) { 739 742 final char separatorChar; 740 if ( device instanceof Cons) {741 separatorChar = '/'; // Jar file.743 if (isJar() || isURL()) { 744 separatorChar = '/'; 742 745 } else { 743 746 separatorChar = File.separatorChar; … … 1670 1673 return true; 1671 1674 } 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 } 1672 1688 } 1673 1689 if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) { 1674 1690 return true; 1675 1691 } 1692 if (name instanceof AbstractString) { 1693 if (name.writeToString().contains("*")) { 1694 return true; 1695 } 1696 } 1676 1697 if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) { 1677 1698 return true; 1699 } 1700 if (type instanceof AbstractString) { 1701 if (type.writeToString().contains("*")) { 1702 return true; 1703 } 1678 1704 } 1679 1705 if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) { … … 1793 1819 result.device = p.device; 1794 1820 } else { 1795 result.device = d.device; 1821 if (!p.isURL()) { 1822 result.device = d.device; 1823 } 1796 1824 } 1797 1825 -
branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java
r12604 r12679 482 482 if (rt.isWhitespace(c)) 483 483 continue; 484 LispObject result = processChar( c, rt);484 LispObject result = processChar(thread, c, rt); 485 485 if (result != null) 486 486 return result; … … 498 498 } 499 499 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) 502 508 { 503 509 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; 509 530 } 510 531 … … 584 605 while (true) { 585 606 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 591 610 char c = (char) n; // ### BUG: Codepoint conversion 592 611 if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { 593 612 // Single escape. 594 613 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 600 617 sb.append((char)n); // ### BUG: Codepoint conversion 601 618 continue; … … 658 675 _unreadChar(nextChar); 659 676 } 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) 663 680 continue; 664 } 681 682 665 683 if (first == null) { 666 684 first = new Cons(obj); … … 949 967 while (true) { 950 968 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 956 972 char c = (char) n; // ### BUG: Codepoint conversion 957 973 byte syntaxType = rt.getSyntaxType(c); 958 974 if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { 959 975 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 965 979 sb.append((char)n); // ### BUG: Codepoint conversion 966 980 continue; … … 971 985 } 972 986 } catch (IOException e) { 973 error(new StreamError(this, e));987 return serror(new StreamError(this, e)); 974 988 } 975 989 return sb.toString(); … … 1115 1129 if (n < 0) { 1116 1130 error(new EndOfFile(this)); 1117 // Not reached.1118 return flags;1119 } 1131 return null; // Not reached 1132 } 1133 1120 1134 sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion 1121 1135 flags = new BitSet(1); … … 1231 1245 if (readBaseObject instanceof Fixnum) { 1232 1246 readBase = ((Fixnum)readBaseObject).value; 1233 } else {1247 } else 1234 1248 // 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 1244 1256 return readBase; 1245 1257 } 1246 1258 1247 1259 private final LispObject makeNumber(String token, int length, int radix) 1248 1249 1260 { 1250 1261 if (length == 0) … … 1415 1426 while (true) { 1416 1427 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 1422 1431 char c = (char) n; // ### BUG: Codepoint conversion 1423 1432 if (!rt.isWhitespace(c)) … … 1440 1449 if (c == delimiter) 1441 1450 break; 1442 LispObject obj = processChar(c, rt); 1451 1452 LispObject obj = processChar(thread, c, rt); 1443 1453 if (obj != null) 1444 1454 result = new Cons(obj, result); … … 1840 1850 return n; // Reads an 8-bit byte. 1841 1851 } catch (IOException e) { 1842 error(new StreamError(this, e)); 1843 // Not reached. 1844 return -1; 1852 return ierror(new StreamError(this, e)); 1845 1853 } 1846 1854 } -
branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java
r12522 r12679 42 42 public static String getVersion() 43 43 { 44 return "0.2 0.0-dev";44 return "0.21.0-dev"; 45 45 } 46 46 -
branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java
r12612 r12679 183 183 if (url.getProtocol().equals("file")) { 184 184 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); 186 194 entry.lastModified = f.lastModified(); 187 195 try { -
branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp
r12618 r12679 50 50 (cl:in-package :cl-user) 51 51 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) 55 56 56 57 ;;;; Create packages in a way that is compatible with hot-upgrade. … … 58 59 ;;;; See more at the end of the file. 59 60 61 #+gcl 62 (eval-when (:compile-toplevel :load-toplevel) 63 (defpackage :asdf-utilities (:use :cl)) 64 (defpackage :asdf (:use :cl :asdf-utilities))) 65 60 66 (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)) 61 71 (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")))) 65 74 (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 70 199 #: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)))))) 271 332 272 333 ;;;; ------------------------------------------------------------------------- … … 276 337 "Exported interface to the version of ASDF currently installed. A string. 277 338 You 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\")." 279 340 *asdf-version*) 280 341 … … 289 350 290 351 (defvar *verbose-out* nil) 352 353 (defvar *asdf-verbose* t) 291 354 292 355 (defparameter +asdf-methods+ … … 302 365 303 366 ;;;; ------------------------------------------------------------------------- 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/485687307 ;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS308 ;;;; for each of the classes we define that has changed incompatibly.309 (eval-when (:compile-toplevel :load-toplevel :execute)310 #+ecl311 (when (find-class 'compile-op nil)312 (defmethod update-instance-for-redefined-class :after313 ((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 ;;;; -------------------------------------------------------------------------319 367 ;;;; ASDF Interface, in terms of generic functions. 320 368 … … 325 373 (defgeneric output-files (operation component)) 326 374 (defgeneric input-files (operation component)) 375 (defgeneric component-operation-time (operation component)) 327 376 328 377 (defgeneric system-source-file (system) … … 348 397 (defgeneric version-satisfies (component version)) 349 398 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; 401 if BASE is nil, then the component is assumed to be a system.")) 354 402 355 403 (defgeneric source-file-type (component system)) … … 366 414 of which is a computed key, so not interesting. The 367 415 CDR wil be the DATA value stored by VISIT-COMPONENT; recover 368 it as \(cdr \(component-visited-p op c\)\).416 it as (cdr (component-visited-p op c)). 369 417 In the current form of ASDF, the DATA value retrieved is 370 418 effectively a boolean, indicating whether some operations are … … 422 470 (initial-values (mapcar (constantly nil) collectors))) 423 471 `(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) 425 473 ,@body 426 (values ,@(mapcar #'(lambda (v) `( nreverse ,v)) vars))))))474 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) 427 475 428 476 (defmacro aif (test then &optional else) 429 477 `(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))438 478 439 479 (defun pathname-directory-pathname (pathname) … … 463 503 (if (typep p 'logical-pathname) #'ununspecific #'identity))) 464 504 (multiple-value-bind (host device directory unspecific-handler) 465 ( ecase (first directory)505 (#-gcl ecase #+gcl case (first directory) 466 506 ((nil) 467 507 (values (pathname-host defaults) … … 477 517 (values (pathname-host defaults) 478 518 (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) 480 529 (unspecific-handler defaults)))) 481 530 (make-pathname :host host :device device :directory directory … … 485 534 486 535 (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") 488 540 489 541 (defun asdf-message (format-string &rest format-args) … … 516 568 ;; See CLHS make-pathname and 19.2.2.2.3. 517 569 ;; 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))) 519 571 (destructuring-bind (name &optional (type unspecific)) 520 572 (split-string filename :max 2 :separator ".") … … 650 702 :collect form))) 651 703 652 #- windows704 #-(and (or win32 windows mswindows mingw32) (not cygwin)) 653 705 (progn 654 706 #+clisp (defun get-uid () (posix:uid)) … … 661 713 (defun get-uid () 662 714 (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")))) 665 717 (with-input-from-string (stream uid-string) 666 718 (read-line stream) … … 688 740 (let ((sofar (ignore-errors (truename (pathname-root p))))) 689 741 (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)))))))) 712 762 713 763 (defun lispize-pathname (input-file) … … 779 829 (in-order-to :initform nil :initarg :in-order-to 780 830 :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! 782 834 (do-first :initform nil :initarg :do-first 783 835 :accessor component-do-first) … … 798 850 :initform nil))) 799 851 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 800 862 ;;;; methods: conditions 801 863 … … 830 892 component)) 831 893 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)) 836 907 837 908 (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))) 846 926 847 927 (defun component-parent-pathname (component) … … 985 1065 (when defaults 986 1066 (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)))) 1002 1070 (t 1003 1071 (restart-case … … 1032 1100 (flet ((try (counter) 1033 1101 (ignore-errors 1034 (make-package (format nil "~ a~D" 'asdf counter)1102 (make-package (format nil "~A~D" :asdf counter) 1035 1103 :use '(:cl :asdf))))) 1036 1104 (do* ((counter 0 (+ counter 1)) … … 1039 1107 1040 1108 (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)) 1047 1118 (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)) 1050 1122 0))) 1051 1123 … … 1067 1139 (asdf-message 1068 1140 "~&~@<; ~@;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*) 1073 1142 (load on-disk))) 1074 1143 (delete-package package)))) … … 1089 1158 ;;;; Finding components 1090 1159 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 1103 1185 1104 1186 ;;; component subclasses … … 1118 1200 ((type :initform "html"))) 1119 1201 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) 1121 1205 (defmethod source-file-type ((component source-file) (s module)) 1206 (declare (ignorable s)) 1122 1207 (source-file-explicit-type component)) 1123 1208 … … 1167 1252 (defclass operation () 1168 1253 ( 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.) 1172 1262 (forced :initform nil :initarg :force :accessor operation-forced) 1173 1263 (original-initargs :initform nil :initarg :original-initargs 1174 1264 :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) 1177 1267 (parent :initform nil :initarg :parent :accessor operation-parent))) 1178 1268 … … 1223 1313 (defmethod visit-component ((o operation) (c component) data) 1224 1314 (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)))) 1227 1318 1228 1319 (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)))) 1232 1322 1233 1323 (defmethod (setf visiting-component) (new-value operation component) … … 1240 1330 (a (operation-ancestor o))) 1241 1331 (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)) 1246 1335 1247 1336 (defmethod component-visiting-p ((o operation) (c component)) 1248 1337 (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))))) 1251 1339 1252 1340 (defmethod component-depends-on ((op-spec symbol) (c component)) … … 1276 1364 (list (component-pathname c))))) 1277 1365 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))) 1279 1372 1280 1373 (defmethod operation-done-p ((o operation) (c component)) 1281 1374 (let ((out-files (output-files o c)) 1282 1375 (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))) 1284 1377 (flet ((earliest-out () 1285 1378 (reduce #'min (mapcar #'safe-file-write-date out-files))) … … 1324 1417 1325 1418 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. 1330 1430 1331 1431 (defvar *forcing* nil … … 1333 1433 recursive calls to traverse.") 1334 1434 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. 1421 1529 (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))) 1424 1533 ;; dependencies 1425 ( if(component-visiting-p operation c)1426 1534 (when (component-visiting-p operation c) 1535 (error 'circular-dependency :components (list c))) 1427 1536 (setf (visiting-component operation c) t) 1428 1537 (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)))) 1503 1633 1504 1634 (defmethod perform ((operation operation) (c source-file)) … … 1509 1639 1510 1640 (defmethod perform ((operation operation) (c module)) 1641 (declare (ignorable operation c)) 1511 1642 nil) 1512 1643 … … 1533 1664 ;; Note how we use OUTPUT-FILES to find the binary locations 1534 1665 ;; 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)))) 1538 1670 1539 1671 (defmethod perform :after ((operation operation) (c component)) … … 1568 1700 1569 1701 (defmethod output-files ((operation compile-op) (c cl-source-file)) 1702 (declare (ignorable operation)) 1570 1703 (let ((p (lispize-pathname (component-pathname c)))) 1571 1704 #-: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) 1574 1706 #+ecl (compile-file-pathname p :type :fasl)) 1575 1707 #+:broken-fasl-loader (list p))) 1576 1708 1577 1709 (defmethod perform ((operation compile-op) (c static-file)) 1710 (declare (ignorable operation c)) 1578 1711 nil) 1579 1712 1580 1713 (defmethod output-files ((operation compile-op) (c static-file)) 1714 (declare (ignorable operation c)) 1581 1715 nil) 1582 1716 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)) 1584 1719 nil) 1585 1720 … … 1603 1738 1604 1739 (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)))))) 1623 1779 1624 1780 (defmethod perform ((operation load-op) (c static-file)) 1781 (declare (ignorable operation c)) 1625 1782 nil) 1626 1783 1627 1784 (defmethod operation-done-p ((operation load-op) (c static-file)) 1785 (declare (ignorable operation c)) 1628 1786 t) 1629 1787 1630 (defmethod output-files ((o operation) (c component)) 1788 (defmethod output-files ((operation operation) (c component)) 1789 (declare (ignorable operation c)) 1631 1790 nil) 1632 1791 1633 1792 (defmethod component-depends-on ((operation load-op) (c component)) 1793 (declare (ignorable operation)) 1634 1794 (cons (list 'compile-op (component-name c)) 1635 1795 (call-next-method))) … … 1641 1801 1642 1802 (defmethod perform ((o load-source-op) (c cl-source-file)) 1803 (declare (ignorable o)) 1643 1804 (let ((source (component-pathname c))) 1644 1805 (setf (component-property c 'last-loaded-as-source) … … 1647 1808 1648 1809 (defmethod perform ((operation load-source-op) (c static-file)) 1810 (declare (ignorable operation c)) 1649 1811 nil) 1650 1812 1651 1813 (defmethod output-files ((operation load-source-op) (c component)) 1814 (declare (ignorable operation c)) 1652 1815 nil) 1653 1816 1654 1817 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. 1655 1818 (defmethod component-depends-on ((o load-source-op) (c component)) 1819 (declare (ignorable o)) 1656 1820 (let ((what-would-load-op-do (cdr (assoc 'load-op 1657 1821 (component-in-order-to c))))) … … 1663 1827 1664 1828 (defmethod operation-done-p ((o load-source-op) (c source-file)) 1829 (declare (ignorable o)) 1665 1830 (if (or (not (component-property c 'last-loaded-as-source)) 1666 1831 (> (safe-file-write-date (component-pathname c)) … … 1675 1840 1676 1841 (defmethod perform ((operation test-op) (c component)) 1842 (declare (ignorable operation c)) 1677 1843 nil) 1678 1844 1679 1845 (defmethod operation-done-p ((operation test-op) (c system)) 1680 1846 "Testing a system is _never_ done." 1847 (declare (ignorable operation c)) 1681 1848 nil) 1682 1849 1683 1850 (defmethod component-depends-on :around ((o test-op) (c system)) 1851 (declare (ignorable o)) 1684 1852 (cons `(load-op ,(component-name c)) (call-next-method))) 1685 1853 … … 1688 1856 ;;;; Invoking Operations 1689 1857 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) 1692 1863 (declare (ignore force)) 1693 1864 (let* ((*package* *package*) … … 1696 1867 :original-initargs args 1697 1868 args)) 1698 (*verbose-out* (if verbose*standard-output* (make-broadcast-stream)))1869 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) 1699 1870 (system (if (typep system 'component) system (find-system system)))) 1700 1871 (unless (version-satisfies system version) … … 1705 1876 (loop 1706 1877 (restart-case 1707 (progn (perform-with-restarts op component) 1708 (return)) 1878 (progn 1879 (perform-with-restarts op component) 1880 (return)) 1709 1881 (retry () 1710 1882 :report … … 1724 1896 op)) 1725 1897 1726 (defun oos (operation-class system &rest args &key force (verbose t)version1898 (defun oos (operation-class system &rest args &key force verbose version 1727 1899 &allow-other-keys) 1728 1900 (declare (ignore force verbose version)) … … 1754 1926 operate-docstring)) 1755 1927 1756 (defun load-system (system &rest args &key force (verbose t)version1928 (defun load-system (system &rest args &key force verbose version 1757 1929 &allow-other-keys) 1758 1930 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for … … 1761 1933 (apply #'operate 'load-op system args)) 1762 1934 1763 (defun compile-system (system &rest args &key force (verbose t)version1935 (defun compile-system (system &rest args &key force verbose version 1764 1936 &allow-other-keys) 1765 1937 "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE … … 1768 1940 (apply #'operate 'compile-op system args)) 1769 1941 1770 (defun test-system (system &rest args &key force (verbose t)version1942 (defun test-system (system &rest args &key force verbose version 1771 1943 &allow-other-keys) 1772 1944 "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for … … 1801 1973 (defmacro defsystem (name &body options) 1802 1974 (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) 1803 &allow-other-keys)1975 defsystem-depends-on &allow-other-keys) 1804 1976 options 1805 (let ((component-options (remove-key word :classoptions)))1977 (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) 1806 1978 `(progn 1807 1979 ;; system must be registered before we parse the body, otherwise 1808 1980 ;; we recur when trying to find an existing system of the same name 1809 1981 ;; to reuse options (e.g. pathname) from 1982 ,@(loop :for system :in defsystem-depends-on 1983 :collect `(load-system ,system)) 1810 1984 (let ((s (system-registered-p ',name))) 1811 1985 (cond ((and s (eq (type-of (cdr s)) ',class)) … … 1819 1993 (cdr (system-registered-p ',name)))) 1820 1994 (parse-component-form 1821 nil (apply 1822 #'list 1995 nil (list* 1823 1996 :module (coerce-name ',name) 1824 1997 :pathname … … 1871 2044 1872 2045 1873 (defvar *serial-depends-on* )2046 (defvar *serial-depends-on* nil) 1874 2047 1875 2048 (defun sysdef-error-component (msg type name value) 1876 2049 (sysdef-error (concatenate 'string msg 1877 "~&The value specified for ~(~A~) ~A is ~ W")2050 "~&The value specified for ~(~A~) ~A is ~S") 1878 2051 type name value)) 1879 2052 … … 1925 2098 1926 2099 (defun parse-component-form (parent options) 1927 1928 2100 (destructuring-bind 1929 2101 (type name &rest rest &key … … 1957 2129 (make-instance (class-for-type parent type))))) 1958 2130 (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)) 1963 2134 (apply #'reinitialize-instance ret 1964 2135 :name (coerce-name name) … … 1974 2145 (let ((*serial-depends-on* nil)) 1975 2146 (setf (module-components ret) 1976 (loop :for c-form :in components 2147 (loop 2148 :for c-form :in components 1977 2149 :for c = (parse-component-form ret c-form) 2150 :for name = (component-name c) 1978 2151 :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 1991 2156 1992 2157 (setf (component-in-order-to ret) … … 1994 2159 in-order-to 1995 2160 `((compile-op (compile-op ,@depends-on)) 1996 (load-op (load-op ,@depends-on)))) 1997 2161 (load-op (load-op ,@depends-on))))) 2162 (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) 1998 2163 1999 2164 (%refresh-component-inline-methods ret rest) … … 2019 2184 (let ((command (apply #'format nil control-string args))) 2020 2185 (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*) 2035 2189 2036 2190 #+allegro … … 2046 2200 exit-code) 2047 2201 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 2048 2218 #+lispworks 2049 2219 (system:call-system-showing-output … … 2054 2224 :output-stream *verbose-out*) 2055 2225 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"))) 2075 2243 2076 2244 ;;;; --------------------------------------------------------------------------- … … 2091 2259 2092 2260 (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))) 2096 2268 2097 2269 (defun relativize-pathname-directory (pathspec) … … 2120 2292 '((:windows :mswindows :win32 :mingw32) 2121 2293 (:solaris :sunos) 2294 :linux ;; for GCL at least, must appear before :bsd. 2122 2295 :macosx :darwin :apple 2123 2296 :freebsd :netbsd :openbsd :bsd 2124 : linux :unix))2297 :unix)) 2125 2298 2126 2299 (defparameter *architecture-features* 2127 2300 '((:x86-64 :amd64 :x86_64 :x8664-target) 2128 2301 (: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)) 2130 2304 2131 2305 (defun lisp-version-string () 2132 2306 (let ((s (lisp-implementation-version))) 2133 2307 (declare (ignorable s)) 2134 #+(or scl sbcl ecl armedbear cormanlisp mcl) s2135 #+cmu (substitute #\- #\/ s)2136 #+clozure (format nil "~d.~d~@[-~d~]"2137 ccl::*openmcl-major-version*2138 ccl::*openmcl-minor-version*2139 #+ppc64-target 642140 #-ppc64-target nil)2141 #+lispworks (format nil "~A~@[~A~]" s2142 (when (member :lispworks-64bit *features*) "-64bit"))2143 2308 #+allegro (format nil 2144 2309 "~A~A~A~A" … … 2153 2318 (:+ics "")) 2154 2319 (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)) 2157 2339 2158 2340 (defun first-feature (features) … … 2222 2404 :for dir :in (split-string dirs :separator ":") 2223 2405 :collect (try dir "common-lisp/")) 2224 #+ windows2406 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2225 2407 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") 2226 2408 ;;; 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/")) 2230 2410 ,(try (user-homedir) ".config/common-lisp/"))))) 2231 2411 (defun system-configuration-directories () … … 2233 2413 #'null 2234 2414 (append 2235 #+ windows2415 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2236 2416 (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/") 2239 2418 ;;; 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/")))) 2242 2420 (list #p"/etc/")))) 2243 2421 (defun in-first-directory (dirs x) 2244 2422 (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))))))) 2246 2425 (defun in-user-configuration-directory (x) 2247 2426 (in-first-directory (user-configuration-directories) x)) … … 2300 2479 2301 2480 (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)))) 2313 2487 (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*) 2323 2491 2324 2492 (defun output-translations () … … 2516 2684 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. 2517 2685 #+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"**/*.*"))2520 2686 ;; All-import, here is where we want user stuff to be: 2521 2687 :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)) 2522 2691 ;; If we want to enable the user cache by default, here would be the place: 2523 2692 :enable-user-cache)) … … 2707 2876 (defun translate-jar-pathname (source wildcard) 2708 2877 (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))))) 2718 2888 2719 2889 ;;;; ----------------------------------------------------------------- … … 2855 3025 (values)) 2856 3026 3027 (defun probe-asd (name defaults) 3028 (block nil 3029 (when (directory-pathname-p defaults) 3030 (let ((file 3031 (make-pathname 3032 :defaults defaults :version :newest :case :local 3033 :name name 3034 :type "asd"))) 3035 (when (probe-file file) 3036 (return file))) 3037 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) 3038 (let ((shortcut 3039 (make-pathname 3040 :defaults defaults :version :newest :case :local 3041 :name (concatenate 'string name ".asd") 3042 :type "lnk"))) 3043 (when (probe-file shortcut) 3044 (let ((target (parse-windows-shortcut shortcut))) 3045 (when target 3046 (return (pathname target))))))))) 3047 2857 3048 (defun sysdef-source-registry-search (system) 2858 3049 (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)) 2880 3054 2881 3055 (defun validate-source-registry-directive (directive) … … 2942 3116 (if (not recurse) 2943 3117 (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))) 2948 3127 (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) 2949 3128 :test #'equal :from-end t))) … … 2982 3161 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) 2983 3162 (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")) 2989 3165 (datadir 2990 3166 #+lispworks (sys:get-folder-path :local-appdata) … … 2992 3168 "Application Data")) 2993 3169 (dirs (list datahome datadir))) 2994 # +(and (not unix) (not windows) (not cygwin))3170 #-(or unix win32 windows mswindows mingw32 cygwin) 2995 3171 ((dirs ())) 2996 3172 (loop :for dir :in dirs … … 3094 3270 3095 3271 ;;;; ----------------------------------------------------------------- 3096 ;;;; SBCL and ClozureCL hook into REQUIRE3272 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL 3097 3273 ;;;; 3098 #+(or sbcl clozure abcl)3274 #+(or abcl clozure cmu ecl sbcl) 3099 3275 (progn 3100 3276 (defun module-provide-asdf (name) … … 3106 3282 name e)))) 3107 3283 (let* ((*verbose-out* (make-broadcast-stream)) 3108 (system ( asdf:find-system name nil)))3284 (system (find-system name nil))) 3109 3285 (when system 3110 ( asdf:operate 'asdf:load-opname)3286 (load-system name) 3111 3287 t)))) 3112 3288 (pushnew 'module-provide-asdf 3113 #+ sbcl sb-ext:*module-provider-functions*3289 #+abcl sys::*module-provider-functions* 3114 3290 #+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*)) 3116 3294 3117 3295 ;;;; ------------------------------------------------------------------------- -
branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp
r12516 r12679 210 210 (float (/ (ext:uptime) 1000))))) 211 211 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 54 54 (export '(class-precedence-list class-slots)) 55 55 (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)) 56 63 57 64 ;; Don't use DEFVAR, because that disallows loading clos.lisp … … 557 564 &allow-other-keys) 558 565 (let ((supers (or direct-superclasses 559 (list (find-class 'standard-object)))))566 (list +the-standard-object-class+)))) 560 567 (setf (class-direct-superclasses class) supers) 561 568 (dolist (superclass supers) … … 580 587 (getf canonical-slot :name)) 581 588 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))) 583 592 584 593 (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) … … 741 750 (set-generic-function-classes-to-emf-table gf new-value)) 742 751 743 (defvar the-class-standard-method (find-class 'standard-method))744 745 752 (defun (setf method-lambda-list) (new-value method) 746 753 (set-method-lambda-list method new-value)) … … 851 858 &key 852 859 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+) 855 862 (method-combination 'standard) 856 863 (argument-precedence-order nil apo-p) … … 886 893 :format-control "~A already names an ordinary function, macro, or special operator." 887 894 :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+) 889 896 #'make-instance-standard-generic-function 890 897 #'make-instance) … … 899 906 (set-funcallable-instance-function 900 907 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+) 902 909 #'std-compute-discriminating-function 903 910 #'compute-discriminating-function) … … 934 941 documentation) 935 942 (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+))) 937 944 (%set-generic-function-name gf name) 938 945 (setf (generic-function-lambda-list gf) lambda-list) … … 1163 1170 (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) 1164 1171 (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+) 1166 1173 (apply #'make-instance-standard-method gf all-keys) 1167 1174 (apply #'make-instance (generic-function-method-class gf) all-keys)))) … … 1178 1185 fast-function) 1179 1186 (declare (ignore gf)) 1180 (let ((method (std-allocate-instance the-class-standard-method)))1187 (let ((method (std-allocate-instance +the-standard-method-class+))) 1181 1188 (setf (method-lambda-list method) lambda-list) 1182 1189 (setf (method-qualifiers method) qualifiers) … … 1367 1374 methods 1368 1375 (sort methods 1369 (if (eq (class-of gf) (find-class 'standard-generic-function))1376 (if (eq (class-of gf) +the-standard-generic-function-class+) 1370 1377 #'(lambda (m1 m2) 1371 1378 (std-method-more-specific-p m1 m2 required-classes … … 1420 1427 (let ((applicable-methods (%compute-applicable-methods gf args))) 1421 1428 (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+) 1423 1430 #'std-compute-effective-method-function 1424 1431 #'compute-effective-method-function) … … 1431 1438 (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) 1432 1439 (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+) 1434 1441 #'std-compute-effective-method-function 1435 1442 #'compute-effective-method-function) … … 1517 1524 (let ((next-emfun 1518 1525 (funcall 1519 (if (eq (class-of gf) (find-class 'standard-generic-function))1526 (if (eq (class-of gf) +the-standard-generic-function-class+) 1520 1527 #'std-compute-effective-method-function 1521 1528 #'compute-effective-method-function) … … 1767 1774 slot-name) 1768 1775 (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+))) 1770 1777 (setf (method-lambda-list method) lambda-list) 1771 1778 (setf (method-qualifiers method) qualifiers) … … 1818 1825 :lambda-list '(new-value object) 1819 1826 :qualifiers () 1820 :specializers (list (find-class 't)class)1827 :specializers (list +the-T-class+ class) 1821 1828 ;; :function `(function ,method-function) 1822 1829 :function (if (autoloadp 'compile) -
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
r12672 r12679 41 41 (defvar *output-file-pathname*) 42 42 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 45 43 (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) 46 44 (sanitize-class-name (pathname-name output-file-pathname))) … … 134 132 ((IN-PACKAGE DEFPACKAGE) 135 133 (note-toplevel-form form) 136 (if (eq operator 'in-package)137 (push (cons (1+ *class-number*) (cadr form)) *function-packages*))138 134 (setf form (precompiler:precompile-form form nil *compile-file-environment*)) 139 135 (eval form) … … 549 545 (*source* *compile-file-truename*) 550 546 (*class-number* 0) 551 (*function-packages* nil)552 547 (namestring (namestring *compile-file-truename*)) 553 548 (start (get-internal-real-time)) 554 elapsed) 549 elapsed 550 *fasl-uninterned-symbols*) 555 551 (when *compile-verbose* 556 552 (format t "; Compiling ~A ...~%" namestring)) … … 565 561 (jvm::*functions-defined-in-current-file* '()) 566 562 (*fbound-names* '()) 567 (*fasl-anonymous-package* (%make-package))568 563 (*fasl-stream* out) 569 564 *forms-for-output*) … … 604 599 (%stream-terpri out) 605 600 (let ((*package* (find-package '#:cl))) 606 ;(count-sym (gensym)))607 601 (write (list 'init-fasl :version *fasl-version*) 608 602 :stream out) … … 611 605 :stream out) 612 606 (%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) 613 616 614 617 (when (> *class-number* 0) … … 617 620 (identity fasl-loader) ;;to avoid unused arg 618 621 ;;Ugly: should export & import JVM:: symbols 619 #|(let ((*package* *package*))620 ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined621 (when x622 `(in-package ,(string x))))|#623 622 (ecase fn-index 624 623 ,@(loop … … 626 625 :collect 627 626 (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)))))) 649 642 (classname (fasl-loader-classname)) 650 643 (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") … … 658 651 :if-exists :supersede) 659 652 (jvm:compile-defun nil expr nil 660 classfile f nil))))) 653 classfile f nil)))) 654 (format t "~&; Wrote fasl loader ~A~%" classfile)) 661 655 (write (list 'setq '*fasl-loader* 662 656 `(sys::make-fasl-class-loader 663 657 ,*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)) 684 659 (%stream-terpri out)) 685 660 … … 700 675 (merge-pathnames (make-pathname :type type) 701 676 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)) 704 682 (dotimes (i *class-number*) 705 683 (let* ((pathname (compute-classfile-name (1+ i)))) -
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12638 r12679 2343 2343 (let ((g (symbol-name (gensym "INSTANCE"))) 2344 2344 saved-code) 2345 (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj)2346 2345 (let* ((s (with-output-to-string (stream) (dump-form obj stream))) 2347 2346 (*code* (if *declare-inline* *code* *static-code*))) … … 5020 5019 5021 5020 (defun p2-progv-node (block target representation) 5022 (declare (ignore representation))5023 5021 (let* ((form (progv-form block)) 5024 5022 (symbols-form (cadr form)) … … 5041 5039 ;; Implicit PROGN. 5042 5040 (let ((*blocks* (cons block *blocks*))) 5043 (compile-progn-body (cdddr form) target ))5041 (compile-progn-body (cdddr form) target representation)) 5044 5042 (restore-environment-and-make-handler environment-register label-START))) 5045 5043 … … 6125 6123 (emit-invokevirtual +lisp-stream-class+ "readLine" 6126 6124 (list "Z" +lisp-object+) +lisp-object+) 6127 (when target 6128 (emit-move-from-stack target))) 6125 (emit-move-from-stack target)) 6129 6126 (t 6130 6127 (compile-function-call form target representation))))) … … 6141 6138 (emit-invokevirtual +lisp-stream-class+ "readLine" 6142 6139 (list "Z" +lisp-object+) +lisp-object+) 6143 (when target 6144 (emit-move-from-stack target)) 6140 (emit-move-from-stack target) 6145 6141 ) 6146 6142 (t … … 8581 8577 (setf *code* (nconc code *code*))) 8582 8578 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 8583 8591 (finalize-code) 8584 8592 (optimize-code) … … 8594 8602 (symbol-value (handler-to handler)))) 8595 8603 *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*))) 8609 8610 t) 8610 8611 … … 8806 8807 (*local-functions* nil) 8807 8808 (*pathnames-generator* (constantly nil)) 8808 (sys::*fasl-anonymous-package* (sys::%make-package))8809 8809 environment) 8810 8810 (unless (and (consp definition) (eq (car definition) 'LAMBDA)) -
branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp
r11566 r12679 104 104 (java:java-object-p object)) 105 105 (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))) 106 116 (t 107 117 (%stream-output-object object stream)))) -
branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
r12630 r12679 326 326 327 327 ;;; JAVA-CLASS support 328 (defconstant +java-lang-object+ (jclass "java.lang.Object")) 328 329 329 330 (defclass java-class (standard-class) … … 331 332 :initform (error "class is required") 332 333 :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+))) 333 342 334 343 (defun ensure-java-class (jclass) … … 341 350 :metaclass (find-class 'java-class) 342 351 :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)) 349 361 :java-class jclass))))) 350 362 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 351 391 (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys) 352 392 (declare (ignore initargs)) -
branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java
r12611 r12679 93 93 } 94 94 95 String head = "HEAD " + url + " HTTP/1.1";95 String head = "HEAD " + url.getPath() + " HTTP/1.1"; 96 96 out.println(head); 97 out.println("Host: " + url.getAuthority()); 97 98 out.println("Connection: close"); 98 99 out.println(""); -
branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp
r12617 r12679 125 125 ;;; XXX come up with a better abstraction 126 126 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 127 133 (progn 128 134 (deftest jar-pathname.load.11 129 (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo")135 (load-url-relative "foo") 130 136 t) 131 137 132 138 (deftest jar-pathname.load.12 133 (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar")139 (load-url-relative "bar") 134 140 t) 135 141 136 142 (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") 138 144 t) 139 145 140 146 (deftest jar-pathname.load.14 141 (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek")147 (load-url-relative "eek") 142 148 t) 143 149 144 150 (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") 146 152 t) 147 153 148 154 (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") 150 156 t) 151 157 152 158 (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") 154 160 t) 155 161 156 162 (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") 158 164 t) 159 165 160 166 (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") 162 168 t) 163 169 164 170 (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") 166 172 t)) 167 168 173 169 174 (deftest jar-pathname.probe-file.1 … … 215 220 "jar:file:baz.jar!/foo" "/a/b/c") 216 221 #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*) 217 227 218 228 (deftest jar-pathname.merge-pathnames.5 … … 333 343 334 344 (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") 340 349 341 350
Note: See TracChangeset
for help on using the changeset viewer.