Changeset 12679

Timestamp:

05/13/10 21:15:07 (14 years ago)

Author:

astalla

Message:

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

Location:

branches/less-reflection/abcl

Files:

• CHANGES (modified) (4 diffs)
• abcl.asd (modified) (1 diff)
• abcl.properties.in (modified) (1 diff)
• build.xml (modified) (8 diffs)
• contrib/asdf-install/installer.lisp (modified) (1 diff)
• doc/asdf/asdf.texinfo (modified) (20 diffs)
• src/org/armedbear/lisp/AutoloadedFunctionProxy.java (modified) (1 diff)
• src/org/armedbear/lisp/FaslReader.java (modified) (3 diffs)
• src/org/armedbear/lisp/FaslReadtable.java (modified) (1 diff)
• src/org/armedbear/lisp/Interpreter.java (modified) (7 diffs)
• src/org/armedbear/lisp/Java.java (modified) (5 diffs)
• src/org/armedbear/lisp/Lisp.java (modified) (2 diffs)
• src/org/armedbear/lisp/LispObject.java (modified) (2 diffs)
• src/org/armedbear/lisp/LispReader.java (modified) (2 diffs)
• src/org/armedbear/lisp/LispThread.java (modified) (3 diffs)
• src/org/armedbear/lisp/Load.java (modified) (6 diffs)
• src/org/armedbear/lisp/Pathname.java (modified) (5 diffs)
• src/org/armedbear/lisp/Stream.java (modified) (11 diffs)
• src/org/armedbear/lisp/Version.java (modified) (1 diff)
• src/org/armedbear/lisp/ZipCache.java (modified) (1 diff)
• src/org/armedbear/lisp/asdf.lisp (modified) (70 diffs)
• src/org/armedbear/lisp/boot.lisp (modified) (1 diff)
• src/org/armedbear/lisp/clos.lisp (modified) (16 diffs)
• src/org/armedbear/lisp/compile-file.lisp (modified) (10 diffs)
• src/org/armedbear/lisp/compiler-pass2.lisp (modified) (8 diffs)
• src/org/armedbear/lisp/dump-form.lisp (modified) (1 diff)
• src/org/armedbear/lisp/java.lisp (modified) (3 diffs)
• src/org/armedbear/lisp/util/HttpHead.java (modified) (1 diff)
• test/lisp/abcl/jar-pathname.lisp (modified) (3 diffs)

branches/less-reflection/abcl/CHANGES

@@ +1 @@
+Version 0.20
+============
+yet-to-be-tagged
+(???)
+
+
+Features
+--------
+
+* [svn r12576] Support for CLOS METACLASS feature
+
+* [svn r12591-602] Consolidation of copy/paste code in the readers
+
+* [svn r12619] Update included ASDF (to ASDF2)
+
+* [svn r12620] Use interpreted function in FASL when compilation fails
+
+* [ticket 95] Pathname functions work with URLs and JARs
+
+* Many small speed improvements (by marking functions 'final')
+
+* [ticket #91] Threads started through MAKE-THREAD now have a
+    thread-termination restart available in their debugger
+
+* [svn r12663] JCLASS supports an optional class-loader argument
+
+* [svn r12634] THREADS:THREAD-JOIN implemented
+
+Fixes
+-----
+
+* [ticket 89] Inlining of READ-LINE broken when the return value
+    is unused
+
+* [svn r12636] Java class verification error when compiling PROGV
+    in a context wanting an unboxed return value (typically a
+    logical expression)
+
+* [svn r12635] ABCL loads stale fasls instead of updated source
+    even when LOAD is called with a file name without extension
+
+* [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly
+    returned as characters from CODE-CHAR
+
+* [ticket #93] Reader doesn't handle zero returned values from
+    macro functions correctly
+
+* [ticket #79] Different, yet similarly named, uninterned symbols
+    are incorrectly coalesced into the same object in a fasl.
+
+* [ticket #86] No restarts available to kill a thread, if none
+    bound by user code
+
+* [svn r12586] Increased function dispatch speed by eliminating
+    FIND-CLASS calls (replacing them by constant references)
+
+Other
+-----
+
+* [svn r12581] LispCharacter() constructors made private, in favor
+    of getInstance() for better re-use of pre-constructed characters
+
+* [svn r12583] JAVA-CLASS reimplemented in Lisp
+
+
 Version 0.19
 ============
@@ -79 +144 @@
 * [svn r12441] ZipCache now caches all references to ZipFiles based on
   the last-modified time for local files.  Remote files are always
-  retrieved due to problems in the underlying JVM code.  
-  
+  retrieved due to problems in the underlying JVM code.
+
   SYS:REMOVE-ZIP-CACHE implements a way to invalidate an entry given a
   pathname.
@@ -188 +253 @@
 
 *  New toplevel 'doc' directory now contains:
-   
+
    + [svn r12410] Design for the (in progress) reworking of the Stream
      inheritance.
-   
+
    + [svn r12433] Design and current status for the re-implementation
      of jar pathnames.
@@ -197 +262 @@
 * [svn r12402] Change ABCL unit tests to use the ABCL-TEST-LISP definition
   contained in 'abcl.asd'.  Fixed and renabled math-tests.  Added new
-  tests for work related to handling jar pathnames. 
+  tests for work related to handling jar pathnames.
 
 * [svn r12401] The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now
   tracks whether local functions need the capture of an actual
   function object.
-   
+
 
 Version 0.18.1

branches/less-reflection/abcl/abcl.asd

@@ -33 +33 @@
                      ((:file "compiler-tests")
                       (:file "condition-tests")
+                      (:file "metaclass")
                       (:file "mop-tests-setup")
                       (:file "mop-tests" :depends-on ("mop-tests-setup"))

branches/less-reflection/abcl/abcl.properties.in

@@ -12 +12 @@
 # java.options sets the Java options in the abcl wrapper scripts
 #java.options=-Xmx1g
+
+# Additional site specific startup code to be merged in 'system.lisp'
+#abcl.startup.file=${basedir}/startup.lisp

branches/less-reflection/abcl/build.xml

@@ -102 +102 @@
       <echo>Compiled ABCL with Java version: ${java.version}</echo>
     </target>
-    
+
     <target name="abcl.clean.maybe" unless="abcl.build.incremental">
       <echo>Cleaning all intermediate compilation artifacts.</echo>
@@ -144 +144 @@
   <or>
     <matches string="${java.version}" pattern="1\.5"/>
-    <matches string="${java.version}" pattern="1\.6\.0_1[0-9]"/>
+    <matches string="${java.version}" pattern="1\.6\.0_[12][0-9]"/>
   </or>  
       </condition>
@@ -177 +177 @@
        debug="true"
        target="1.5"
+             includeantruntime="false"
        failonerror="true">
   <src path="${src.dir}"/>
@@ -224 +225 @@
           location="${build.classes.dir}/org/armedbear/lisp/"/>
     <pathconvert dirsep="/" property="abcl.lisp.output" refid="abcl.lisp.output.path"/>
+
+    <property name="system.lisp.file" 
+              value="${build.classes.dir}/org/armedbear/lisp/system.lisp"/>
     
     <target name="abcl.compile.lisp" 
-      depends="abcl.copy.lisp,abcl.compile.java,abcl.fasls.uptodate"
+      depends="abcl.copy.lisp,abcl.compile.java,abcl.system.update.maybe,abcl.fasls.uptodate"
       unless="abcl.fasls.uptodate.p">
       <echo>
@@ -239 +243 @@
         <jvmarg value="-Dabcl.home=${abcl.home.dir}${file.separator}"/>
   <arg value="--noinit"/>
+        <arg value="--nosystem"/>
         <arg value="--eval"/>
         <arg value="(setf *load-verbose* t)"/>
       </java>
+      <concat destfile="${system.lisp.file}" append="true">
+        <fileset file="${abcl.startup.file}"/>
+      </concat>
     </target>
 
@@ -270 +278 @@
       <exec executable="hostname" outputproperty="abcl.hostname"/>
       <echo>abcl.hostname: ${abcl.hostname}</echo>
+    </target>
+
+    <target name="abcl.system.uptodate">
+      <condition property="abcl.system.needs-update.p">
+        <and>
+          <available file="${system.lisp.file}"/>
+          <available file="${abcl.startup.file}"/>
+          <uptodate
+                srcfile="${system.lisp.file}"
+                targetfile="${abcl.startup.file}"/>
+        </and>
+      </condition>
+    </target>
+    
+    <target name="abcl.system.update.maybe" depends="abcl.system.uptodate" 
+            if="abcl.system.needs-update.p">
+      <touch file="${src.dir}/org/armedbear/lisp/compile-system.lisp"/>
     </target>
 
@@ -672 +697 @@
       classpathref="abcl.test.run.classpath"
       classname="org.junit.runner.JUnitCore">
-  <arg value="org.armedbear.lisp.FastStringBufferTest"/>
         <arg value="org.armedbear.lisp.PathnameTest"/>
         <arg value="org.armedbear.lisp.StreamTest"/>
+        <arg value="org.armedbear.lisp.UtilitiesTest"/>
       </java>
     </target>
@@ -706 +731 @@
   <arg value="--eval"/><arg value="(require (quote asdf))"/>
   <arg value="--eval"/><arg value="(asdf:operate (quote asdf:load-op) :abcl)"/>
-  <arg value="--eval"/><arg value="(asdf:operate (quote asdf:test-op) :ansi-compiled)"/>
+  <arg value="--eval"/><arg value="(let ((*compile-verbose* t)) (asdf:operate (quote asdf:test-op) :ansi-compiled))"/>
         <arg value="--eval"/><arg value="(ext:exit)"/>
       </java>

branches/less-reflection/abcl/contrib/asdf-install/installer.lisp

@@ -542 +542 @@
 
 (defmethod asdf:find-component :around 
-    ((module (eql nil)) name &optional version)
-  (declare (ignore version))
+    ((module (eql nil)) name)
   (when (or (not *propagate-installation*) 
             (member name *systems-installed-this-time* 

branches/less-reflection/abcl/doc/asdf/asdf.texinfo

@@ -32 +32 @@
 This manual describes ASDF, a system definition facility
 for Common Lisp programs and libraries.
+
+You can find the latest version of this manual at
+@url{http://common-lisp.net/project/asdf/asdf.html}.
 
 ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
@@ -168 +171 @@
 
 @emph{Nota Bene}:
-We are preparing for a release of ASDF 2,
+We are preparing for a release of ASDF 2, hopefully for May 2010,
 which will have version 2.000 and later.
-Current releases, in the 1.600 series and beyond,
+Current releases, in the 1.700 series and beyond,
 should be considered as release candidates.
 We're still working on polishing the code and documentation.
-@ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
+@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
 
 
@@ -239 +242 @@
 If it returns @code{NIL} then ASDF is not installed.
 
-If you are running a version older than 1.678,
+If you are running a version older than 1.711,
 we recommend that you load a newer ASDF using the method below.
 
@@ -533 +536 @@
 ASDF-Binary-Locations, cl-launch, common-lisp-controller.
 ASDF-Binary-Locations is now not needed anymore and should not be used.
-cl-launch 3.0 and common-lisp-controller 7.1 have been updated
+cl-launch 2.900 and common-lisp-controller 7.1 have been updated
 to just delegate this functionality to ASDF.
 
@@ -550 +553 @@
 @end example
 
-On some implementations (namely, SBCL and Clozure CL),
+On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
 ASDF hooks into the @code{CL:REQUIRE} facility
 and you can just use:
@@ -1317 +1320 @@
 which doesn't provide any obvious way to specify required features.
 Furthermore, in 2009, discussions on the
-@uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
 suggested that the specification of required features may be broken,
 and that no one may have been using them for a while.
 Please contact the
-@uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
 if you are interested in getting this features feature fixed.}
 
@@ -1672 +1675 @@
 Mentions of XDG variables refer to that document.
 
-@uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
+@url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
 
 This specification allows the user to specify some environment variables
@@ -2464 +2467 @@
 
 You may get the ASDF source repository using git:
-@kbd{git clone http://common-lisp.net/project/asdf/asdf.git}
+@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
 
 You will find the above referenced tags in this repository.
@@ -2473 +2476 @@
 mailing list
 @kbd{asdf-devel@@common-lisp.net}.
-@uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
 
 
@@ -2485 +2488 @@
 
 If you're unsure about whether something is a bug, of for general discussion,
-use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
 
 
@@ -2497 +2500 @@
 we are still working on polishing them before release.
 
-Releases in the 1.600 series and beyond
+Releases in the 1.700 series and beyond
 should be considered as release candidates.
 For all practical purposes,
@@ -2514 +2517 @@
 
 
-@subsection ASDF can portably name files inside systems and components
+@subsection ASDF can portably name files in subdirectories
 
 Common Lisp namestrings are not portable,
 except maybe for logical pathnamestrings,
-that themselves require a lot of setup that is itself ultimately non-portable.
-The only portable ways to refer to pathnames inside systems and components
+that themselves have various limitations and require a lot of setup
+that is itself ultimately non-portable.
+
+In ASDF 1, the only portable ways to refer to pathnames inside systems and components
 were very awkward, using @code{#.(make-pathname ...)} and
 @code{#.(merge-pathnames ...)}.
@@ -2535 +2540 @@
 @xref{The defsystem grammar,,Pathname specifiers}.
 
+
 @subsection Output translations
 
@@ -2572 +2578 @@
 and a coherent set of configuration files and hooks.
 
+We believe it's a vast improvement because it decouples
+application distribution from library distribution.
+The application writer can avoid thinking where the libraries are,
+and the library distributor (dpkg, clbuild, advanced user, etc.)
+can configure them once and for every application.
+Yet settings can be easily overridden where needed,
+so whoever needs control has exactly as much as required.
+
 At the same time, ASDF 2 remains compatible
 with the old magic you may have in your build scripts
+(using @code{*central-registry*} and
+@code{*system-definition-search-functions*})
 to tailor the ASDF configuration to your build automation needs,
 and also allows for new magic, simpler and more powerful magic.
 
 @xref{Controlling where ASDF searches for systems}.
+
 
 @subsection Usual operations are made easier to the user
@@ -2593 +2610 @@
 @subsection Many bugs have been fixed
 
-These issues and many others have been fixed,
-including the following:
-
-Dependencies were not correctly propagated
-across submodules within a system.
-
+The following issues and many others have been fixed:
+
+@itemize
+@item
+The infamous TRAVERSE function has been revamped significantly,
+with many bugs squashed.
+In particular, dependencies were not correctly propagated
+across submodules within a system but now are.
+The :version and :feature features and
+the :force (system1 .. systemN) feature have been fixed.
+
+@item
+Performance has been notably improved for large systems
+(say with thousands of components) by using
+hash-tables instead of linear search,
+and linear-time list accumulation
+instead of quadratic-time recursive appends.
+
+@item
 Many features used to not be portable,
 especially where pathnames were involved.
-
-The internal test suite used to massively fail
-in many implementations.
-
-Support was broken for some implementations (notably ABCL).
-
+Windows support was notably quirky because of such non-portability.
+
+@item
+The internal test suite used to massively fail on many implementations.
+While still incomplete, it now fully passes
+on all implementations supported by the test suite.
+
+@item
+Support was lacking for some implementations.
+ABCL was notably wholly broken.
+ECL extensions were not integrated in the ASDF release.
+
+@item
 The documentation was grossly out of date.
 
-ECL extensions were not integrated in the ASDF release.
+@end itemize
 
 
@@ -2624 +2661 @@
 that everyone can rely on from now on.
 Use @code{#+asdf2} to detect presence of ASDF 2,
-@code{(asdf:version-satisfies (asdf:asdf-version) "1.678")}
+@code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
 to check the availability of a version no earlier than required.
+
 
 @subsection ASDF can be upgraded
@@ -2668 +2706 @@
 towards the latest version for everyone.
 
+
+@subsection Pitfalls of ASDF 2
+
+The main pitfalls in upgrading to ASDF 2 seem to be related
+to the output translation mechanism.
+
+@itemize
+
+@item
+Output translations is enabled by default. This may surprise some users,
+most of them in pleasant way (we hope), a few of them in an unpleasant way.
+It is trivial to disable output translations.
+@xref{FAQ,,``How can I wholly disable the compiler output cache?''}.
+
+@item
+Some systems in the large have been known not to play well with output translations.
+They were relatively easy to fix.
+Once again, it is also easy to disable output translations,
+or to override its configuration.
+
+@item
+The new ASDF output translations are incompatible with ASDF-Binary-Locations.
+They replace A-B-L, and there is compatibility mode to emulate
+your previous A-B-L configuration.
+See @code{asdf:enable-asdf-binary-locations-compatibility} in
+@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
+But thou shall not load ABL on top of ASDF 2.
+
+@end itemize
+
+Other issues include the following:
+
+@itemize
+
+@item
+There is a slight performance bug, notably on SBCL,
+when initially searching for @file{asd} files,
+the implicit @code{(directory "/configured/path/**/*.asd")}
+for every configured path @code{(:tree "/configured/path/")}
+in your @code{source-registry} configuration can cause a slight pause.
+Try to @code{(time (asdf:initialize-source-registry))}
+to see how bad it is or isn't on your system.
+If you insist on not having this pause,
+you can avoid the pause by overriding the default source-registry configuration
+and not use any deep @code{:tree} entry but only @code{:directory} entries
+or shallow @code{:tree} entries.
+Or you can fix your implementation to not be quite that slow
+when recursing through directories.
+
+@item
+On Windows, only LispWorks supports proper default configuration pathnames
+based on the Windows registry.
+Other implementations make do.
+Windows support is largely untested, so please help report and fix bugs.
+
+@end itemize
+
+
 @section Issues with installing the proper version of ASDF
 
@@ -2691 +2787 @@
 it's a bug that you should report upstream and that we will fix ASAP.
 
-As to how to include ASDF, we recommend that
-if you do have a few magic systems in your implementation path,
-that are specially treated in @code{wrapping-source-registry},
-like SBCL does.
-In this case, we explicitly ask you to @emph{NOT} distribute
-@file{asdf.asd} together with your implementation's ASDF,
-least you separate it from the other systems in this path,
-or otherwise rename the system and its @file{asd} file
-to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}.
-
+As to how to include ASDF, we recommend the following:
+
+@itemize
+@item
+If ASDF isn't installed yet, then @code{(require :asdf)}
+should load the version of ASDF that is bundled with your system.
+You may have it load some other version configured by the user,
+if you allow such configuration.
+
+@item
+If your system provides a mechanism to hook into @code{CL:REQUIRE},
+then it would be nice to add ASDF to this hook the same way that
+ABCL, CCL, CMUCL, ECL and SBCL do it.
+
+@item
+You may, like SBCL, have ASDF be implicitly used to require systems
+that are bundled with your Lisp distribution.
+If you do have a few magic systems that come with your implementation
+in a precompiled way such that one should only use the binary version
+that goes with your distribution, like SBCL does,
+then you should add them in the beginning of @code{wrapping-source-registry}.
+
+@item
+If you have magic systems as above, like SBCL does,
+then we explicitly ask you to @emph{NOT} distribute
+@file{asdf.asd} as part of those magic systems.
+You should still include the file @file{asdf.lisp} in your source distribution
+and precompile it in your binary distribution,
+but @file{asdf.asd} if included at all,
+should be secluded from the magic systems,
+in a separate file hierarchy,
+or you may otherwise rename the system and its file to e.g.
+@code{asdf-ecl} and @file{asdf-ecl.asd}, or
+@code{sb-asdf} and @file{sb-asdf.asd}.
+Indeed, if you made @file{asdf.asd} a magic system,
+then users would no longer be able to upgrade ASDF using ASDF itself
+to some version of their preference that
+they maintain independently from your Lisp distribution.
+
+@item
 If you do not have any such magic systems, or have other non-magic systems
 that you want to bundle with your implementation,
@@ -2706 +2832 @@
 and you are welcome to include @file{asdf.asd} amongst them.
 
-Please send upstream any patches you make to ASDF itself,
+@item
+Please send us upstream any patches you make to ASDF itself,
 so we can merge them back in for the benefit of your users
 when they upgrade to the upstream version.
+
+@end itemize
+
 
 
@@ -2773 +2903 @@
 @code{test-op} has been
 a topic of considerable discussion on the
-@uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
 and on the
-@uref{https://launchpad.net/asdf,launchpad bug-tracker}.
+@url{https://launchpad.net/asdf,launchpad bug-tracker}.
 
 Here are some guidelines:

branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java

@@ -51 +51 @@
         {
             AUTOLOADING_CACHE, // allow loading local preloaded functions
-            Load._FASL_ANONYMOUS_PACKAGE_, // package for uninterned symbols
+            Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols
             Symbol._PACKAGE_,              // current package
             Symbol.LOAD_TRUENAME           // LOAD-TIME-VALUE depends on this

branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java

@@ -142 +142 @@
         {
             LispThread thread = LispThread.currentThread();
-            Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance());
-            LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread);
-            Debug.assertTrue(pkg != NIL);
-            symbol = ((Package)pkg).intern(symbol.getName());
-            symbol.setPackage(NIL);
-            return symbol;
+            return stream.readSymbol(FaslReadtable.getInstance());
         }
     };
@@ -278 +273 @@
         @Override
         public LispObject execute(Stream stream, char c, int n)
-
         {
             return stream.readCharacterLiteral(FaslReadtable.getInstance(),
@@ -284 +278 @@
         }
     };
+
+    // ### fasl-sharp-question-mark
+    public static final DispatchMacroFunction FASL_SHARP_QUESTION_MARK =
+        new DispatchMacroFunction("fasl-sharp-question-mark", PACKAGE_SYS,
+                                  false, "stream sub-char numarg")
+    {
+        @Override
+        public LispObject execute(Stream stream, char c, int n)
+        {
+            LispThread thread = LispThread.currentThread();
+            LispObject uninternedSymbols =
+                Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread);
+
+            if (! (uninternedSymbols instanceof Cons)) // it must be a vector
+                return uninternedSymbols.AREF(n);
+
+            // During normal loading, we won't get to this bit, however,
+            // with eval-when processing, we may need to fall back to
+            // *FASL-UNINTERNED-SYMBOLS* being an alist structure
+            LispObject label = LispInteger.getInstance(n);
+            while (uninternedSymbols != NIL)
+              {
+                LispObject item = uninternedSymbols.car();
+                if (label.eql(item.cdr()))
+                  return item.car();
+
+                uninternedSymbols = uninternedSymbols.cdr();
+              }
+            return error(new LispError("No entry for uninterned symbol."));
+        }
+    };
+
 }

branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java

@@ -101 +101 @@
         dtfunctions[12]   = LispReader.SHARP_ILLEGAL; // page
         dtfunctions[13]   = LispReader.SHARP_ILLEGAL; // return
+        dtfunctions['?']  = FaslReader.FASL_SHARP_QUESTION_MARK;
         dispatchTables.constants['#'] = dt;
 

branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java

@@ -53 +53 @@
 
     private static boolean noinit = false;
+    private static boolean nosystem = false;
     private static boolean noinform = false;
 
@@ -93 +94 @@
         initializeLisp();
         initializeTopLevel();
+        if (!nosystem) 
+            initializeSystem();
         if (!noinit)
             processInitializationFile();
@@ -118 +121 @@
         initializeJLisp();
         initializeTopLevel();
+        initializeSystem();
         processInitializationFile();
         return interpreter;
@@ -212 +216 @@
     }
 
+    private static synchronized void initializeSystem() 
+    {
+        Load.loadSystemFile("system");
+    }
+
     // Check for --noinit; verify that arguments are supplied for --load and
     // --eval options.  Copy all unrecognized arguments into
@@ -225 +234 @@
                 if (arg.equals("--noinit")) {
                     noinit = true;
+                } else if (arg.equals("--nosystem")) {
+                    nosystem = true;
                 } else if (arg.equals("--noinform")) {
                     noinform = true;
@@ -281 +292 @@
                             sb.append(c.getCondition().writeToString());
                             sb.append(separator);
-                            System.err.print(sb.toString());
-          System.err.println("backtrace: ");
-          evaluate("(princ (sys::backtrace))");
+                            System.err.println(sb);
+          //evaluate("(pprint (sys::backtrace))");
                             System.exit(2);
                         }
@@ -466 +476 @@
             throws UnhandledCondition
         {
-            final Condition condition = (Condition) first;
+            final LispObject condition = first;
             if (interpreter == null) {
                 final LispThread thread = LispThread.currentThread();

branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java

@@ -116 +116 @@
     }
 
-    // ### jclass name-or-class-ref => class-ref
+    // ### jclass name-or-class-ref &optional class-loader => class-ref
     private static final Primitive JCLASS = new pf_jclass();
     private static final class pf_jclass extends Primitive 
@@ -122 +122 @@
         pf_jclass() 
         {
-            super(Symbol.JCLASS, "name-or-class-ref",
-                  "Returns a reference to the Java class designated by NAME-OR-CLASS-REF.");
+            super(Symbol.JCLASS, "name-or-class-ref &optional class-loader",
+                  "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.");
         }
 
@@ -130 +130 @@
         {
             return JavaObject.getInstance(javaClass(arg));
+        }
+
+        @Override
+        public LispObject execute(LispObject className, LispObject classLoader)
+        {
+      ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class);
+      if(loader != null) {
+    return JavaObject.getInstance(javaClass(className, loader));
+      } else {
+    return JavaObject.getInstance(javaClass(className));
+      }
         }
     };
@@ -1150 +1161 @@
     }
     
-    static Class classForName(String className)
-    {
+    private static Class classForName(String className) {
+  return classForName(className, JavaClassLoader.getPersistentInstance());
+    }
+
+    private static Class classForName(String className, ClassLoader classLoader) {
         try {
-            return Class.forName(className);
+            return Class.forName(className, true, classLoader);
         }
         catch (ClassNotFoundException e) {
-            try {
-                return Class.forName(className, true, JavaClassLoader.getPersistentInstance());
-            }
-            catch (ClassNotFoundException ex) {
-                error(new LispError("Class not found: " + className));
-                // Not reached.
-                return null;
-            }
-        }
+      error(new LispError("Class not found: " + className));
+      // Not reached.
+      return null;
+        }
+    }
+
+    private static Class javaClass(LispObject obj) {
+  return javaClass(obj, null);
     }
 
     // Supports Java primitive types too.
-    static Class javaClass(LispObject obj)
+    static Class javaClass(LispObject obj, ClassLoader classLoader)
     {
         if (obj instanceof AbstractString || obj instanceof Symbol) {
@@ -1189 +1202 @@
                 return Double.TYPE;
             // Not a primitive Java type.
-            Class c = classForName(s);
+            Class c;
+      if(classLoader != null) {
+    c = classForName(s, classLoader);
+      } else {
+    c = classForName(s);
+      }
             if (c == null)
                 error(new LispError(s + " does not designate a Java class."));

branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java

@@ -352 +352 @@
 
   public static final LispObject error(LispObject condition)
-
   {
     pushJavaStackFrames();
@@ -358 +357 @@
   }
 
+  public static final int ierror(LispObject condition)
+  {
+    error(condition);
+    return 0; // Not reached
+  }
+
+  public static final String serror(LispObject condition)
+  {
+    error(condition);
+    return ""; // Not reached
+  }
+
+
   public static final LispObject error(LispObject condition, LispObject message)
-
   {
     pushJavaStackFrames();
     return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message);
   }
+
+  public static final int ierror(LispObject condition, LispObject message)
+  {
+    error(condition, message);
+    return 0; // Not reached
+  }
+
+  public static final String serror(LispObject condition, LispObject message)
+  {
+    error(condition, message);
+    return ""; // Not reached
+  }
+
+
 
   public static final LispObject type_error(LispObject datum,

branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java

@@ -720 +720 @@
   }
 
-  public String unreadableString(String s) {
+  public final String unreadableString(String s) {
      return unreadableString(s, true);
   }
-  public String unreadableString(Symbol sym) {
+  public final String unreadableString(Symbol sym) {
      return unreadableString(sym, true);
   }
 
-  public String unreadableString(String s, boolean identity)
+  public final String unreadableString(String s, boolean identity)
   {
     StringBuilder sb = new StringBuilder("#<");
@@ -740 +740 @@
   }
 
-  public String unreadableString(Symbol symbol, boolean identity) 
+  public final String unreadableString(Symbol symbol, boolean identity) 
 
   {

branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java

@@ -47 +47 @@
 
         {
-          try 
+          try
             {
               while (true) {
                 int n = stream._readChar();
                 if (n < 0)
-                  return null;
+                  return LispThread.currentThread().setValues();
                 if (n == '\n')
-                  return null;
+                  return LispThread.currentThread().setValues();
               }
             }
           catch (java.io.IOException e)
             {
-              return null;
+                return LispThread.currentThread().setValues();
             }
         }
@@ -329 +329 @@
         {
             stream.skipBalancedComment();
-            return null;
+            return LispThread.currentThread().setValues();
         }
     };

branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java

@@ -49 +49 @@
        new ConcurrentHashMap<Thread,LispThread>();
 
+    LispObject threadValue = NIL;
+
     private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){
         @Override
@@ -88 +90 @@
             {
                 try {
-                    funcall(wrapper,
+                    threadValue = funcall(wrapper,
                             new LispObject[] { fun },
                             LispThread.this);
@@ -931 +933 @@
     };
 
+    private static final Primitive THREAD_JOIN =
+        new Primitive("thread-join", PACKAGE_THREADS, true, "thread",
+                      "Waits for thread to finish.")
+    {
+        @Override
+        public LispObject execute(LispObject arg)
+        {
+            // join the thread, and returns it's value.  The second return
+            // value is T if the thread finishes normally, NIL if its 
+            // interrupted. 
+            if (arg instanceof LispThread) {                
+                final LispThread joinedThread = (LispThread) arg;
+                final LispThread waitingThread = currentThread();
+                try {
+                    joinedThread.javaThread.join();
+                    return 
+                        waitingThread.setValues(joinedThread.threadValue, T);
+                } catch (InterruptedException e) {
+                    waitingThread.processThreadInterrupts();
+                    return 
+                        waitingThread.setValues(joinedThread.threadValue, NIL);
+                }
+            } else {
+                return type_error(arg, Symbol.THREAD);
+            } 
+        }
+    };
+
+
     public static final long javaSleepInterval(LispObject lispSleep)
 

branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java

@@ -85 +85 @@
             LispObject abcl = Pathname.truename(abclPathname, false);
             if (lisp instanceof Pathname && abcl instanceof Pathname) {
-                lispPathname = (Pathname)lisp;
-                abclPathname = (Pathname)abcl;
-                long lispLastModified = lispPathname.getLastModified();
-                long abclLastModified = abclPathname.getLastModified();
+              lispPathname = (Pathname)lisp;
+              abclPathname = (Pathname)abcl;
+              long lispLastModified = lispPathname.getLastModified();
+              long abclLastModified = abclPathname.getLastModified();
               if (abclLastModified > lispLastModified) {
+                  return abclPathname;  // fasl file is newer
+              } else {
                   return lispPathname;
-              } else {
-                  return abclPathname;
               }
             } else if (abcl instanceof Pathname) {
@@ -364 +364 @@
     // internal symbol
     static final Symbol _FASL_VERSION_ =
-        exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(35));
+        exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36));
 
     // ### *fasl-external-format*
@@ -372 +372 @@
                        new SimpleString("UTF-8"));
 
-    // ### *fasl-anonymous-package*
+    // ### *fasl-uninterned-symbols*
     // internal symbol
     /**
-     * This variable gets bound to a package with no name in which the
-     * reader can intern its uninterned symbols.
+     * This variable gets bound to NIL upon loading a FASL, but
+     * gets set to a vector of symbols as one of the first actions
+     * by the FASL itself.
      *
      */
-    public static final Symbol _FASL_ANONYMOUS_PACKAGE_ =
-        internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL);
+    public static final Symbol _FASL_UNINTERNED_SYMBOLS_ =
+        internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL);
 
     // ### init-fasl &key version
@@ -396 +397 @@
                     // OK
                     final LispThread thread = LispThread.currentThread();
-                    thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL);
+                    thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL);
                     thread.bindSpecial(_SOURCE_, NIL);
                     return faslLoadStream(thread);
@@ -412 +413 @@
                                                        boolean auto)
         {
-            return loadFileFromStream(pathname == null ? NIL : pathname, 
-                                      truename == null ? NIL : truename, 
+            return loadFileFromStream(pathname == null ? NIL : pathname,
+                                      truename == null ? NIL : truename,
                                       in, verbose, print, auto, false);
     }
@@ -586 +587 @@
         LispObject result = NIL;
         try {
-            thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package());
             thread.bindSpecial(AUTOLOADING_CACHE,
                                AutoloadedFunctionProxy.makePreloadingContext());

branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java

@@ -346 +346 @@
             String scheme = url.getProtocol();
             if (scheme.equals("file")) {
-                Pathname p = new Pathname(s);
+                Pathname p = new Pathname(url.getFile());
                 this.host = p.host;
                 this.device = p.device;
@@ -681 +681 @@
             if (type instanceof AbstractString) {
                 String t = type.getStringValue();
-                if (t.indexOf('.') >= 0) {
-                    Debug.assertTrue(namestring == null);
-                    return null;
-                }
+    // Allow Windows shortcuts to include TYPE
+    if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) {
+        if (t.indexOf('.') >= 0) {
+      Debug.assertTrue(namestring == null);
+      return null;
+        }
+    }
                 sb.append(t);
             } else if (type == Keyword.WILD) {
@@ -738 +741 @@
         if (directory != NIL) {
             final char separatorChar;
-            if (device instanceof Cons) {
-                separatorChar = '/'; // Jar file.
+            if (isJar() || isURL()) {
+                separatorChar = '/'; 
             } else {
                 separatorChar = File.separatorChar;
@@ -1670 +1673 @@
                 return true;
             }
+            Cons d = (Cons) directory;
+            while (true) {
+                if (d.car() instanceof AbstractString) {
+                    String s = d.car().writeToString();
+                    if (s.contains("*")) {
+                        return true;
+                    }
+                }
+                if (d.cdr() == NIL || ! (d.cdr() instanceof Cons)) {
+                    break;
+                }
+                d = (Cons)d.cdr();
+            }
         }
         if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) {
             return true;
         }
+        if (name instanceof AbstractString) {
+            if (name.writeToString().contains("*")) {
+                return true;
+            }
+        }
         if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) {
             return true;
+        }
+        if (type instanceof AbstractString) {
+            if (type.writeToString().contains("*")) {
+                return true;
+            }
         }
         if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) {
@@ -1793 +1819 @@
             result.device = p.device;
         } else {
-            result.device = d.device;
+            if (!p.isURL()) {
+                result.device = d.device;
+            }
         }
 

branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java

@@ -482 +482 @@
                 if (rt.isWhitespace(c))
                     continue;
-                LispObject result = processChar(c, rt);
+                LispObject result = processChar(thread, c, rt);
                 if (result != null)
                     return result;
@@ -498 +498 @@
     }
 
-    private final LispObject processChar(char c, Readtable rt)
-
+    /** Dispatch macro function if 'c' has one associated,
+     * read a token otherwise.
+     *
+     * When the macro function returns zero values, this function
+     * returns null or the token or returned value otherwise.
+     */
+    private final LispObject processChar(LispThread thread,
+                                         char c, Readtable rt)
     {
         final LispObject handler = rt.getReaderMacroFunction(c);
-        if (handler instanceof ReaderMacroFunction)
-            return ((ReaderMacroFunction)handler).execute(this, c);
-        if (handler != null && handler != NIL)
-            return handler.execute(this, LispCharacter.getInstance(c));
-        return readToken(c, rt);
+        LispObject value;
+
+        if (handler instanceof ReaderMacroFunction) {
+            thread._values = null;
+            value = ((ReaderMacroFunction)handler).execute(this, c);
+        }
+        else if (handler != null && handler != NIL) {
+            thread._values = null;
+            value = handler.execute(this, LispCharacter.getInstance(c));
+        }
+        else
+            return readToken(c, rt);
+
+        // If we're looking at zero return values, set 'value' to null
+        if (value == NIL) {
+            LispObject[] values = thread._values;
+            if (values != null && values.length == 0)
+                value = null;
+        }
+        return value;
     }
 
@@ -584 +605 @@
         while (true) {
           int n = _readChar();
-          if (n < 0) {
-            error(new EndOfFile(this));
-            // Not reached.
-            return null;
-          }
+          if (n < 0)
+            return error(new EndOfFile(this));
+
           char c = (char) n; // ### BUG: Codepoint conversion
           if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) {
             // Single escape.
             n = _readChar();
-            if (n < 0) {
-              error(new EndOfFile(this));
-              // Not reached.
-              return null;
-            }
+            if (n < 0)
+              return error(new EndOfFile(this));
+
             sb.append((char)n); // ### BUG: Codepoint conversion
             continue;
@@ -658 +675 @@
                     _unreadChar(nextChar);
                 }
-                LispObject obj = processChar(c, rt);
-                if (obj == null) {
-                    // A comment.
+
+                LispObject obj = processChar(thread, c, rt);
+                if (obj == null)
                     continue;
-                }
+
+
                 if (first == null) {
                     first = new Cons(obj);
@@ -949 +967 @@
             while (true) {
                 int n = _readChar();
-                if (n < 0) {
-                    error(new EndOfFile(this));
-                    // Not reached.
-                    return null;
-                }
+                if (n < 0)
+                    return serror(new EndOfFile(this));
+
                 char c = (char) n; // ### BUG: Codepoint conversion
                 byte syntaxType = rt.getSyntaxType(c);
                 if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) {
                     n = _readChar();
-                    if (n < 0) {
-                        error(new EndOfFile(this));
-                        // Not reached.
-                        return null;
-                    }
+                    if (n < 0)
+                        return serror(new EndOfFile(this));
+
                     sb.append((char)n); // ### BUG: Codepoint conversion
                     continue;
@@ -971 +985 @@
             }
         } catch (IOException e) {
-            error(new StreamError(this, e));
+            return serror(new StreamError(this, e));
         }
         return sb.toString();
@@ -1115 +1129 @@
                 if (n < 0) {
                     error(new EndOfFile(this));
-                    // Not reached.
-                    return flags;
-                }
+                    return null; // Not reached
+                }
+
                 sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion
                 flags = new BitSet(1);
@@ -1231 +1245 @@
         if (readBaseObject instanceof Fixnum) {
             readBase = ((Fixnum)readBaseObject).value;
-        } else {
+        } else
             // The value of *READ-BASE* is not a Fixnum.
-            error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36)."));
-            // Not reached.
-            return 10;
-        }
-        if (readBase < 2 || readBase > 36) {
-            error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36)."));
-            // Not reached.
-            return 10;
-        }
+            return ierror(new LispError("The value of *READ-BASE* is not " +
+                                        "of type '(INTEGER 2 36)."));
+
+        if (readBase < 2 || readBase > 36)
+            return ierror(new LispError("The value of *READ-BASE* is not " +
+                                        "of type '(INTEGER 2 36)."));
+
         return readBase;
     }
 
     private final LispObject makeNumber(String token, int length, int radix)
-
     {
         if (length == 0)
@@ -1415 +1426 @@
             while (true) {
                 int n = _readChar();
-                if (n < 0) {
-                    error(new EndOfFile(this));
-                    // Not reached.
-                    return 0;
-                }
+                if (n < 0)
+                    return (char)ierror(new EndOfFile(this));
+
                 char c = (char) n; // ### BUG: Codepoint conversion
                 if (!rt.isWhitespace(c))
@@ -1440 +1449 @@
             if (c == delimiter)
                 break;
-            LispObject obj = processChar(c, rt);
+
+            LispObject obj = processChar(thread, c, rt);
             if (obj != null)
                 result = new Cons(obj, result);
@@ -1840 +1850 @@
             return n; // Reads an 8-bit byte.
         } catch (IOException e) {
-            error(new StreamError(this, e));
-            // Not reached.
-            return -1;
+            return ierror(new StreamError(this, e));
         }
     }

branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java

@@ -42 +42 @@
   public static String getVersion()
   {
-    return "0.20.0-dev";
+    return "0.21.0-dev";
   }
   

branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java

@@ -183 +183 @@
             if (url.getProtocol().equals("file")) {
                 entry = new Entry();
-                File f = new File(url.getPath());
+                String path = url.getPath();
+
+                if (Utilities.isPlatformWindows) {
+                    String authority = url.getAuthority();
+                    if (authority != null) {
+                        path = authority + path;
+                    }
+                }
+                File f = new File(path);
                 entry.lastModified = f.lastModified();
                 try {

branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -50 +50 @@
 (cl:in-package :cl-user)
 
-(declaim (optimize (speed 2) (debug 2) (safety 3)))
-
-#+ecl (require 'cmp)
+(declaim (optimize (speed 2) (debug 2) (safety 3))
+         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+
+#+ecl (require :cmp)
 
 ;;;; Create packages in a way that is compatible with hot-upgrade.
@@ -58 +59 @@
 ;;;; See more at the end of the file.
 
+#+gcl
+(eval-when (:compile-toplevel :load-toplevel)
+  (defpackage :asdf-utilities (:use :cl))
+  (defpackage :asdf (:use :cl :asdf-utilities)))
+
 (eval-when (:load-toplevel :compile-toplevel :execute)
+  #+allegro
+  (setf excl::*autoload-package-name-alist*
+        (remove "asdf" excl::*autoload-package-name-alist*
+                :test 'equalp :key 'car))
   (let* ((asdf-version
-          ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
-          (subseq "VERSION:1.679" (1+ (length "VERSION"))))
-         #+allegro (excl::*autoload-package-name-alist* nil)
+          ;; the 1+ helps the version bumping script discriminate
+          (subseq "VERSION:1.719" (1+ (length "VERSION"))))
          (existing-asdf (find-package :asdf))
-         (versym '#:*asdf-version*)
-         (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
-         (redefined-functions
-          '(#:perform #:explain #:output-files #:operation-done-p
+         (vername '#:*asdf-version*)
+         (versym (and existing-asdf
+                      (find-symbol (string vername) existing-asdf)))
+         (existing-version (and versym (boundp versym) (symbol-value versym)))
+         (already-there (equal asdf-version existing-version)))
+    (unless (and existing-asdf already-there)
+      #-gcl
+      (when existing-asdf
+        (format *error-output*
+                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
+                existing-version asdf-version))
+      (labels
+          ((rename-away (package)
+             (loop :with name = (package-name package)
+               :for i :from 1 :for new = (format nil "~A.~D" name i)
+               :unless (find-package new) :do
+               (rename-package-name package name new)))
+           (rename-package-name (package old new)
+             (let* ((old-names (cons (package-name package)
+                                     (package-nicknames package)))
+                    (new-names (subst new old old-names :test 'equal))
+                    (new-name (car new-names))
+                    (new-nicknames (cdr new-names)))
+               (rename-package package new-name new-nicknames)))
+           (ensure-exists (name nicknames use)
+             (let* ((previous
+                     (remove-duplicates
+                      (remove-if
+                       #'null
+                       (mapcar #'find-package (cons name nicknames)))
+                      :from-end t)))
+               (cond
+                 (previous
+                  ;; do away with packages with conflicting (nick)names
+                  (map () #'rename-away (cdr previous))
+                  ;; reuse previous package with same name
+                  (let ((p (car previous)))
+                    (rename-package p name nicknames)
+                    (ensure-use p use)
+                    p))
+                 (t
+                  (make-package name :nicknames nicknames :use use)))))
+           (find-sym (symbol package)
+             (find-symbol (string symbol) package))
+           (intern* (symbol package)
+             (intern (string symbol) package))
+           (remove-symbol (symbol package)
+             (let ((sym (find-sym symbol package)))
+               (when sym
+                 (unexport sym package)
+                 (unintern sym package))))
+           (ensure-unintern (package symbols)
+             (dolist (sym symbols) (remove-symbol sym package)))
+           (ensure-shadow (package symbols)
+             (shadow symbols package))
+           (ensure-use (package use)
+             (dolist (used (reverse use))
+               (do-external-symbols (sym used)
+                 (unless (eq sym (find-sym sym package))
+                   (remove-symbol sym package)))
+               (use-package used package)))
+           (ensure-fmakunbound (package symbols)
+             (loop :for name :in symbols
+               :for sym = (find-sym name package)
+               :when sym :do (fmakunbound sym)))
+           (ensure-export (package export)
+             (let ((syms (loop :for x :in export :collect
+                           (intern* x package))))
+               (do-external-symbols (sym package)
+                 (unless (member sym syms)
+                   (remove-symbol sym package)))
+               (dolist (sym syms)
+                 (export sym package))))
+           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
+             (let ((p (ensure-exists name nicknames use)))
+               (ensure-unintern p unintern)
+               (ensure-shadow p shadow)
+               (ensure-export p export)
+               (ensure-fmakunbound p fmakunbound)
+               p)))
+        (macrolet
+            ((pkgdcl (name &key nicknames use export
+                           redefined-functions unintern fmakunbound shadow)
+               `(ensure-package
+                 ',name :nicknames ',nicknames :use ',use :export ',export
+                 :shadow ',shadow
+                 :unintern ',(append #-(or gcl ecl) redefined-functions
+                                     unintern)
+                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
+                                        fmakunbound))))
+          (pkgdcl
+           :asdf-utilities
+           :nicknames (#:asdf-extensions)
+           :use (#:common-lisp)
+           :unintern (#:split #:make-collector)
+           :export
+           (#:absolute-pathname-p
+            #:aif
+            #:appendf
+            #:asdf-message
+            #:coerce-name
+            #:directory-pathname-p
+            #:ends-with
+            #:ensure-directory-pathname
+            #:getenv
+            #:get-uid
+            #:length=n-p
+            #:merge-pathnames*
+            #:pathname-directory-pathname
+            #:read-file-forms
+            #:remove-keys
+            #:remove-keyword
+            #:resolve-symlinks
+            #:split-string
+            #:component-name-to-pathname-components
+            #:split-name-type
+            #:system-registered-p
+            #:truenamize
+            #:while-collecting))
+          (pkgdcl
+           :asdf
+           :use (:common-lisp :asdf-utilities)
+           :redefined-functions
+           (#:perform #:explain #:output-files #:operation-done-p
             #:perform-with-restarts #:component-relative-pathname
-            #:system-source-file)))
-    (unless (equal asdf-version existing-version)
-      (labels ((rename-away (package)
-                 (loop :with name = (package-name package)
-                   :for i :from 1 :for new = (format nil "~A.~D" name i)
-                   :unless (find-package new) :do
-                   (rename-package-name package name new)))
-               (rename-package-name (package old new)
-                 (let* ((old-names (cons (package-name package) (package-nicknames package)))
-                        (new-names (subst new old old-names :test 'equal))
-                        (new-name (car new-names))
-                        (new-nicknames (cdr new-names)))
-                   (rename-package package new-name new-nicknames)))
-               (ensure-exists (name nicknames use)
-                 (let* ((previous
-                         (remove-duplicates
-                          (remove-if
-                           #'null
-                           (mapcar #'find-package (cons name nicknames)))
-                          :from-end t)))
-                   (cond
-                     (previous
-                      (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
-                      (let ((p (car previous))) ;; previous package with same name
-                        (rename-package p name nicknames)
-                        (ensure-use p use)
-                        p))
-                     (t
-                      (make-package name :nicknames nicknames :use use)))))
-               (find-sym (symbol package)
-                 (find-symbol (string symbol) package))
-               (remove-symbol (symbol package)
-                 (let ((sym (find-sym symbol package)))
-                   (when sym
-                     (unexport sym package)
-                     (unintern sym package))))
-               (ensure-unintern (package symbols)
-                 (dolist (sym symbols) (remove-symbol sym package)))
-               (ensure-shadow (package symbols)
-                 (shadow symbols package))
-               (ensure-use (package use)
-                 (dolist (used (reverse use))
-                   (do-external-symbols (sym used)
-                     (unless (eq sym (find-sym sym package))
-                       (remove-symbol sym package)))
-                   (use-package used package)))
-               (ensure-fmakunbound (package symbols)
-                 (loop :for name :in symbols
-                   :for sym = (find-sym name package)
-                   :when sym :do (fmakunbound sym)))
-               (ensure-export (package export)
-                 (let ((syms (loop :for x :in export :collect
-                               (intern (string x) package))))
-                   (do-external-symbols (sym package)
-                     (unless (member sym syms)
-                       (remove-symbol sym package)))
-                   (dolist (sym syms)
-                     (export sym package))))
-               (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
-                 (let ((p (ensure-exists name nicknames use)))
-                   (ensure-unintern p unintern)
-                   (ensure-shadow p shadow)
-                   (ensure-export p export)
-                   (ensure-fmakunbound p fmakunbound)
-                   p)))
-        (ensure-package
-         ':asdf-utilities
-         :nicknames '(#:asdf-extensions)
-         :use '(#:common-lisp)
-         :unintern '(#:split #:make-collector)
-         :export
-         '(#:absolute-pathname-p
-           #:aif
-           #:appendf
-           #:asdf-message
-           #:coerce-name
-           #:directory-pathname-p
-           #:ends-with
-           #:ensure-directory-pathname
-           #:getenv
-           #:get-uid
-           #:length=n-p
-           #:merge-pathnames*
-           #:pathname-directory-pathname
-           #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
-           #:read-file-forms
-           #:remove-keys
-           #:remove-keyword
-           #:resolve-symlinks
-           #:split-string
-           #:component-name-to-pathname-components
-           #:split-name-type
-           #:system-registered-p
-           #:truenamize
-           #:while-collecting))
-        (ensure-package
-         ':asdf
-         :use '(:common-lisp :asdf-utilities)
-         :unintern `(#-ecl ,@redefined-functions
-                           #:*asdf-revision* #:around #:asdf-method-combination
-                           #:split #:make-collector)
-         :fmakunbound `(#+ecl ,@redefined-functions
-                              #:system-source-file
-                              #:component-relative-pathname #:system-relative-pathname
-                              #:process-source-registry
-                              #:inherit-source-registry #:process-source-registry-directive)
-         :export
-         '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
-           #:system-definition-pathname #:find-component ; miscellaneous
-           #:compile-system #:load-system #:test-system
-           #:compile-op #:load-op #:load-source-op
-           #:test-op
-           #:operation               ; operations
-           #:feature                 ; sort-of operation
-           #:version                 ; metaphorically sort-of an operation
-           #:version-satisfies
-
-           #:input-files #:output-files #:perform ; operation methods
-           #:operation-done-p #:explain
-
-           #:component #:source-file
-           #:c-source-file #:cl-source-file #:java-source-file
-           #:static-file
-           #:doc-file
-           #:html-file
-           #:text-file
-           #:source-file-type
-           #:module                     ; components
-           #:system
-           #:unix-dso
-
-           #:module-components          ; component accessors
-           #:component-pathname
-           #:component-relative-pathname
-           #:component-name
-           #:component-version
-           #:component-parent
-           #:component-property
-           #:component-system
-
-           #:component-depends-on
-
-           #:system-description
-           #:system-long-description
-           #:system-author
-           #:system-maintainer
-           #:system-license
-           #:system-licence
-           #:system-source-file
-           #:system-source-directory
-           #:system-relative-pathname
-           #:map-systems
-
-           #:operation-on-warnings
-           #:operation-on-failure
-                                        ;#:*component-parent-pathname*
-           #:*system-definition-search-functions*
-           #:*central-registry*         ; variables
-           #:*compile-file-warnings-behaviour*
-           #:*compile-file-failure-behaviour*
-           #:*resolve-symlinks*
-
-           #:asdf-version
-
-           #:operation-error #:compile-failed #:compile-warned #:compile-error
-           #:error-name
-           #:error-pathname
-           #:load-system-definition-error
-           #:error-component #:error-operation
-           #:system-definition-error
-           #:missing-component
-           #:missing-component-of-version
-           #:missing-dependency
-           #:missing-dependency-of-version
-           #:circular-dependency        ; errors
-           #:duplicate-names
-
-           #:try-recompiling
-           #:retry
-           #:accept                     ; restarts
-           #:coerce-entry-to-directory
-           #:remove-entry-from-registry
-
-           #:initialize-output-translations
-           #:disable-output-translations
-           #:clear-output-translations
-           #:ensure-output-translations
-           #:apply-output-translations
-           #:compile-file-pathname*
-           #:enable-asdf-binary-locations-compatibility
-
-           #:*default-source-registries*
-           #:initialize-source-registry
-           #:compute-source-registry
-           #:clear-source-registry
-           #:ensure-source-registry
-           #:process-source-registry))
-        (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
-
-(in-package #:asdf)
+            #:system-source-file #:operate #:find-component)
+           :unintern
+           (#:*asdf-revision* #:around #:asdf-method-combination
+            #:split #:make-collector)
+           :fmakunbound
+           (#:system-source-file
+            #:component-relative-pathname #:system-relative-pathname
+            #:process-source-registry
+            #:inherit-source-registry #:process-source-registry-directive)
+           :export
+           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
+            #:system-definition-pathname #:find-component ; miscellaneous
+            #:compile-system #:load-system #:test-system
+            #:compile-op #:load-op #:load-source-op
+            #:test-op
+            #:operation               ; operations
+            #:feature                 ; sort-of operation
+            #:version                 ; metaphorically sort-of an operation
+            #:version-satisfies
+
+            #:input-files #:output-files #:perform ; operation methods
+            #:operation-done-p #:explain
+
+            #:component #:source-file
+            #:c-source-file #:cl-source-file #:java-source-file
+            #:static-file
+            #:doc-file
+            #:html-file
+            #:text-file
+            #:source-file-type
+            #:module                     ; components
+            #:system
+            #:unix-dso
+
+            #:module-components          ; component accessors
+            #:module-components-by-name  ; component accessors
+            #:component-pathname
+            #:component-relative-pathname
+            #:component-name
+            #:component-version
+            #:component-parent
+            #:component-property
+            #:component-system
+
+            #:component-depends-on
+
+            #:system-description
+            #:system-long-description
+            #:system-author
+            #:system-maintainer
+            #:system-license
+            #:system-licence
+            #:system-source-file
+            #:system-source-directory
+            #:system-relative-pathname
+            #:map-systems
+
+            #:operation-on-warnings
+            #:operation-on-failure
+            ;;#:*component-parent-pathname*
+            #:*system-definition-search-functions*
+            #:*central-registry*         ; variables
+            #:*compile-file-warnings-behaviour*
+            #:*compile-file-failure-behaviour*
+            #:*resolve-symlinks*
+            #:*asdf-verbose*
+
+            #:asdf-version
+
+            #:operation-error #:compile-failed #:compile-warned #:compile-error
+            #:error-name
+            #:error-pathname
+            #:load-system-definition-error
+            #:error-component #:error-operation
+            #:system-definition-error
+            #:missing-component
+            #:missing-component-of-version
+            #:missing-dependency
+            #:missing-dependency-of-version
+            #:circular-dependency        ; errors
+            #:duplicate-names
+
+            #:try-recompiling
+            #:retry
+            #:accept                     ; restarts
+            #:coerce-entry-to-directory
+            #:remove-entry-from-registry
+
+            #:initialize-output-translations
+            #:disable-output-translations
+            #:clear-output-translations
+            #:ensure-output-translations
+            #:apply-output-translations
+            #:compile-file-pathname*
+            #:enable-asdf-binary-locations-compatibility
+
+            #:*default-source-registries*
+            #:initialize-source-registry
+            #:compute-source-registry
+            #:clear-source-registry
+            #:ensure-source-registry
+            #:process-source-registry)))
+        (let* ((version (intern* vername :asdf))
+               (upvar (intern* '#:*upgraded-p* :asdf))
+               (upval0 (and (boundp upvar) (symbol-value upvar)))
+               (upval1 (if existing-version (cons existing-version upval0) upval0)))
+          (eval `(progn
+                   (defparameter ,version ,asdf-version)
+                   (defparameter ,upvar ',upval1))))))))
+
+(in-package :asdf)
+
+;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
+#+gcl
+(eval-when (:compile-toplevel :load-toplevel)
+  (defvar *asdf-version* nil)
+  (defvar *upgraded-p* nil))
+(when *upgraded-p*
+   #+ecl
+   (when (find-class 'compile-op nil)
+     (defmethod update-instance-for-redefined-class :after
+         ((c compile-op) added deleted plist &key)
+       (declare (ignore added deleted))
+       (let ((system-p (getf plist 'system-p)))
+         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
+   (when (find-class 'module nil)
+     (eval
+      '(defmethod update-instance-for-redefined-class :after
+           ((m module) added deleted plist &key)
+         (declare (ignorable deleted plist))
+         (when (member 'components-by-name added)
+           (compute-module-components-by-name m))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -276 +337 @@
   "Exported interface to the version of ASDF currently installed. A string.
 You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
   *asdf-version*)
 
@@ -289 +350 @@
 
 (defvar *verbose-out* nil)
+
+(defvar *asdf-verbose* t)
 
 (defparameter +asdf-methods+
@@ -302 +365 @@
 
 ;;;; -------------------------------------------------------------------------
-;;;; Cleanups before hot-upgrade.
-;;;; Things to do in case we're upgrading from a previous version of ASDF.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-;;;;   for each of the classes we define that has changed incompatibly.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  #+ecl
-  (when (find-class 'compile-op nil)
-    (defmethod update-instance-for-redefined-class :after
-        ((c compile-op) added deleted plist &key)
-      (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
-      (let ((system-p (getf plist 'system-p)))
-        (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
-
-;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
 
@@ -325 +373 @@
 (defgeneric output-files (operation component))
 (defgeneric input-files (operation component))
+(defgeneric component-operation-time (operation component))
 
 (defgeneric system-source-file (system)
@@ -348 +397 @@
 (defgeneric version-satisfies (component version))
 
-(defgeneric find-component (module name &optional version)
-  (:documentation "Finds the component with name NAME present in the
-MODULE module; if MODULE is nil, then the component is assumed to be a
-system."))
+(defgeneric find-component (base path)
+  (:documentation "Finds the component with PATH starting from BASE module;
+if BASE is nil, then the component is assumed to be a system."))
 
 (defgeneric source-file-type (component system))
@@ -366 +414 @@
 of which is a computed key, so not interesting.  The
 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as \(cdr \(component-visited-p op c\)\).
+it as (cdr (component-visited-p op c)).
   In the current form of ASDF, the DATA value retrieved is
 effectively a boolean, indicating whether some operations are
@@ -422 +470 @@
         (initial-values (mapcar (constantly nil) collectors)))
     `(let ,(mapcar #'list vars initial-values)
-       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
+       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
          ,@body
-         (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))
+         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
 
 (defmacro aif (test then &optional else)
   `(let ((it ,test)) (if it ,then ,else)))
-
-(defun pathname-sans-name+type (pathname)
-  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME and TYPE components.
-Issue: doesn't override the VERSION component.
-
-Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
-  (make-pathname :name nil :type nil :defaults pathname))
 
 (defun pathname-directory-pathname (pathname)
@@ -463 +503 @@
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
-          (ecase (first directory)
+          (#-gcl ecase #+gcl case (first directory)
             ((nil)
              (values (pathname-host defaults)
@@ -477 +517 @@
              (values (pathname-host defaults)
                      (pathname-device defaults)
-                     (append (pathname-directory defaults) (cdr directory))
+                     (if (null (pathname-directory defaults))
+                         directory
+                         (append (pathname-directory defaults) (cdr directory)))
+                     (unspecific-handler defaults)))
+            #+gcl
+            (t
+             (assert (stringp (first directory)))
+             (values (pathname-host defaults)
+                     (pathname-device defaults)
+                     (append (pathname-directory defaults) directory)
                      (unspecific-handler defaults))))
         (make-pathname :host host :device device :directory directory
@@ -485 +534 @@
 
 (define-modify-macro appendf (&rest args)
-  append "Append onto list")
+  append "Append onto list") ;; only to be used on short lists.
+
+(define-modify-macro orf (&rest args)
+  or "or a flag")
 
 (defun asdf-message (format-string &rest format-args)
@@ -516 +568 @@
          ;; See CLHS make-pathname and 19.2.2.2.3.
          ;; We only use it on implementations that support it.
-         (or #+(or sbcl ccl ecl lispworks) :unspecific)))
+         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
@@ -650 +702 @@
      :collect form)))
 
-#-windows
+#-(and (or win32 windows mswindows mingw32) (not cygwin))
 (progn
 #+clisp (defun get-uid () (posix:uid))
@@ -661 +713 @@
 (defun get-uid ()
   (let ((uid-string
-         (with-output-to-string (asdf::*VERBOSE-OUT*)
-           (asdf:run-shell-command "id -ur"))))
+         (with-output-to-string (*verbose-out*)
+           (run-shell-command "id -ur"))))
     (with-input-from-string (stream uid-string)
       (read-line stream)
@@ -688 +740 @@
       (let ((sofar (ignore-errors (truename (pathname-root p)))))
         (unless sofar (return p))
-        (loop :for component :in (cdr directory)
-          :for rest :on (cdr directory)
-          :for more = (ignore-errors
-                        (truename
-                         (merge-pathnames*
-                          (make-pathname :directory `(:relative ,component))
-                          sofar))) :do
-          (if more
-              (setf sofar more)
-              (return
-                (merge-pathnames*
-                 (make-pathname :host nil :device nil
-                                :directory `(:relative ,@rest)
-                                :defaults p)
-                 sofar)))
-          :finally
-          (return
-            (merge-pathnames*
-             (make-pathname :host nil :device nil
-                            :directory nil
-                            :defaults p)
-             sofar)))))))
+        (flet ((solution (directories)
+                 (merge-pathnames*
+                  (make-pathname :host nil :device nil
+                                 :directory `(:relative ,@directories)
+                                 :name (pathname-name p)
+                                 :type (pathname-type p)
+                                 :version (pathname-version p))
+                  sofar)))
+          (loop :for component :in (cdr directory)
+            :for rest :on (cdr directory)
+            :for more = (ignore-errors
+                          (truename
+                           (merge-pathnames*
+                            (make-pathname :directory `(:relative ,component))
+                            sofar))) :do
+            (if more
+                (setf sofar more)
+                (return (solution rest)))
+            :finally
+            (return (solution nil))))))))
 
 (defun lispize-pathname (input-file)
@@ -779 +829 @@
    (in-order-to :initform nil :initarg :in-order-to
                 :accessor component-in-order-to)
-   ;; XXX crap name
+   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
+   (load-dependencies :accessor component-load-dependencies :initform nil)
+   ;; XXX crap name, but it's an official API name!
    (do-first :initform nil :initarg :do-first
              :accessor component-do-first)
@@ -798 +850 @@
                :initform nil)))
 
+(defun component-find-path (component)
+  (reverse
+   (loop :for c = component :then (component-parent c)
+     :while c :collect (component-name c))))
+
+(defmethod print-object ((c component) stream)
+  (print-unreadable-object (c stream :type t :identity nil)
+    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+
+
 ;;;; methods: conditions
 
@@ -830 +892 @@
        component))
 
-(defmethod print-object ((c component) stream)
-  (print-unreadable-object (c stream :type t :identity t)
-    (ignore-errors
-      (prin1 (component-name c) stream))))
+(defvar *default-component-class* 'cl-source-file)
+
+(defun compute-module-components-by-name (module)
+  (let ((hash (module-components-by-name module)))
+    (clrhash hash)
+    (loop :for c :in (module-components module)
+      :for name = (component-name c)
+      :for previous = (gethash name (module-components-by-name module))
+      :do
+      (when previous
+        (error 'duplicate-names :name name))
+      :do (setf (gethash name (module-components-by-name module)) c))
+    hash))
 
 (defclass module (component)
-  ((components :initform nil :accessor module-components :initarg :components)
-   ;; what to do if we can't satisfy a dependency of one of this module's
-   ;; components.  This allows a limited form of conditional processing
-   (if-component-dep-fails :initform :fail
-                           :accessor module-if-component-dep-fails
-                           :initarg :if-component-dep-fails)
-   (default-component-class :accessor module-default-component-class
-     :initform 'cl-source-file :initarg :default-component-class)))
+  ((components
+    :initform nil
+    :initarg :components
+    :accessor module-components)
+   (components-by-name
+    :initform (make-hash-table :test 'equal)
+    :accessor module-components-by-name)
+   ;; What to do if we can't satisfy a dependency of one of this module's
+   ;; components.  This allows a limited form of conditional processing.
+   (if-component-dep-fails
+    :initform :fail
+    :initarg :if-component-dep-fails
+    :accessor module-if-component-dep-fails)
+   (default-component-class
+    :initform *default-component-class*
+    :initarg :default-component-class
+    :accessor module-default-component-class)))
 
 (defun component-parent-pathname (component)
@@ -985 +1065 @@
                (when defaults
                  (cond ((directory-pathname-p defaults)
-                        (let ((file (and defaults
-                                         (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd" :case :local)))
-                               #+(and (or win32 windows) (not :clisp))
-                               (shortcut (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd.lnk" :case :local)))
-                          (if (and file (probe-file file))
-                              (return file))
-                          #+(and (or win32 windows) (not :clisp))
-                          (when (probe-file shortcut)
-                            (let ((target (parse-windows-shortcut shortcut)))
-                              (when target
-                                (return (pathname target)))))))
+                        (let ((file (probe-asd name defaults)))
+                          (when file
+                            (return file))))
                        (t
                         (restart-case
@@ -1032 +1100 @@
   (flet ((try (counter)
            (ignore-errors
-             (make-package (format nil "~a~D" 'asdf counter)
+             (make-package (format nil "~A~D" :asdf counter)
                            :use '(:cl :asdf)))))
     (do* ((counter 0 (+ counter 1))
@@ -1039 +1107 @@
 
 (defun safe-file-write-date (pathname)
-           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
-           ;; user or some other agent has deleted an input file.  If
-           ;; that's the case, well, that's not good, but as long as
-           ;; the operation is otherwise considered to be done we
-           ;; could continue and survive.
-  (or (and pathname (file-write-date pathname))
+  ;; If FILE-WRITE-DATE returns NIL, it's possible that
+  ;; the user or some other agent has deleted an input file.
+  ;; Also, generated files will not exist at the time planning is done
+  ;; and calls operation-done-p which calls safe-file-write-date.
+  ;; So it is very possible that we can't get a valid file-write-date,
+  ;; and we can survive and we will continue the planning
+  ;; as if the file were very old.
+  ;; (or should we treat the case in a different, special way?)
+  (or (and pathname (probe-file pathname) (file-write-date pathname))
       (progn
-        (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
-              pathname)
+        (when pathname
+          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+                pathname))
         0)))
 
@@ -1067 +1139 @@
                  (asdf-message
                   "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
-                  ;; FIXME: This wants to be (ENOUGH-NAMESTRING
-                  ;; ON-DISK), but CMUCL barfs on that.
-                  on-disk
-                  *package*)
+                  on-disk *package*)
                  (load on-disk)))
           (delete-package package))))
@@ -1089 +1158 @@
 ;;;; Finding components
 
-(defmethod find-component ((module module) name &optional version)
-  (if (slot-boundp module 'components)
-      (let ((m (find name (module-components module)
-                     :test #'equal :key #'component-name)))
-        (if (and m (version-satisfies m version)) m))))
-
-
-;;; a component with no parent is a system
-(defmethod find-component ((module (eql nil)) name &optional version)
-  (declare (ignorable module))
-  (let ((m (find-system name nil)))
-    (if (and m (version-satisfies m version)) m)))
+(defmethod find-component ((base string) path)
+  (let ((s (find-system base nil)))
+    (and s (find-component s path))))
+
+(defmethod find-component ((base symbol) path)
+  (cond
+    (base (find-component (coerce-name base) path))
+    (path (find-component path nil))
+    (t    nil)))
+
+(defmethod find-component ((base cons) path)
+  (find-component (car base) (cons (cdr base) path)))
+
+(defmethod find-component ((module module) (name string))
+  (when (slot-boundp module 'components-by-name)
+    (values (gethash name (module-components-by-name module)))))
+
+(defmethod find-component ((component component) (name symbol))
+  (if name
+      (find-component component (coerce-name name))
+      component))
+
+(defmethod find-component ((module module) (name cons))
+  (find-component (find-component module (car name)) (cdr name)))
+
 
 ;;; component subclasses
@@ -1118 +1200 @@
   ((type :initform "html")))
 
-(defmethod source-file-type ((component module) (s module)) :directory)
+(defmethod source-file-type ((component module) (s module))
+  (declare (ignorable component s))
+  :directory)
 (defmethod source-file-type ((component source-file) (s module))
+  (declare (ignorable s))
   (source-file-explicit-type component))
 
@@ -1167 +1252 @@
 (defclass operation ()
   (
-   ;; what is the TYPE of this slot?  seems like it should be boolean,
-   ;; but TRAVERSE checks to see if it's a list of component names...
-   ;; [2010/02/07:rpg]
+   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
+   ;; T to force the inside of existing system,
+   ;;   but not recurse to other systems we depend on.
+   ;; :ALL (or any other atom) to force all systems
+   ;;   including other systems we depend on.
+   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
+   ;;   to force systems named in a given list
+   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
    (forced :initform nil :initarg :force :accessor operation-forced)
    (original-initargs :initform nil :initarg :original-initargs
                       :accessor operation-original-initargs)
-   (visited-nodes :initform nil :accessor operation-visited-nodes)
-   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
+   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
+   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    (parent :initform nil :initarg :parent :accessor operation-parent)))
 
@@ -1223 +1313 @@
 (defmethod visit-component ((o operation) (c component) data)
   (unless (component-visited-p o c)
-    (push (cons (node-for o c) data)
-          (operation-visited-nodes (operation-ancestor o)))))
+    (setf (gethash (node-for o c)
+                   (operation-visited-nodes (operation-ancestor o)))
+          (cons t data))))
 
 (defmethod component-visited-p ((o operation) (c component))
-  (assoc (node-for o c)
-         (operation-visited-nodes (operation-ancestor o))
-         :test 'equal))
+  (gethash (node-for o c)
+           (operation-visited-nodes (operation-ancestor o))))
 
 (defmethod (setf visiting-component) (new-value operation component)
@@ -1240 +1330 @@
         (a (operation-ancestor o)))
     (if new-value
-        (pushnew node (operation-visiting-nodes a) :test 'equal)
-        (setf (operation-visiting-nodes a)
-              (remove node  (operation-visiting-nodes a) :test 'equal))))
-  new-value)
+        (setf (gethash node (operation-visiting-nodes a)) t)
+        (remhash node (operation-visiting-nodes a)))
+    new-value))
 
 (defmethod component-visiting-p ((o operation) (c component))
   (let ((node (node-for o c)))
-    (member node (operation-visiting-nodes (operation-ancestor o))
-            :test 'equal)))
+    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
 
 (defmethod component-depends-on ((op-spec symbol) (c component))
@@ -1276 +1364 @@
         (list (component-pathname c)))))
 
-(defmethod input-files ((operation operation) (c module)) nil)
+(defmethod input-files ((operation operation) (c module))
+  (declare (ignorable operation c))
+  nil)
+
+(defmethod component-operation-time (o c)
+  (gethash (type-of o) (component-operation-times c)))
 
 (defmethod operation-done-p ((o operation) (c component))
   (let ((out-files (output-files o c))
         (in-files (input-files o c))
-        (op-time (gethash (type-of o) (component-operation-times c))))
+        (op-time (component-operation-time o c)))
     (flet ((earliest-out ()
              (reduce #'min (mapcar #'safe-file-write-date out-files)))
@@ -1324 +1417 @@
 
 
-;;; So you look at this code and think "why isn't it a bunch of
-;;; methods".  And the answer is, because standard method combination
-;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes.
+
+;;; For 1.700 I've done my best to refactor TRAVERSE
+;;; by splitting it up in a bunch of functions,
+;;; so as to improve the collection and use-detection algorithm. --fare
+;;; The protocol is as follows: we pass around operation, dependency,
+;;; bunch of other stuff, and a force argument. Return a force flag.
+;;; The returned flag is T if anything has changed that requires a rebuild.
+;;; The force argument is a list of components that will require a rebuild
+;;; if the flag is T, at which point whoever returns the flag has to
+;;; mark them all as forced, and whoever recurses again can use a NIL list
+;;; as a further argument.
 
 (defvar *forcing* nil
@@ -1333 +1433 @@
 recursive calls to traverse.")
 
-(defmethod traverse ((operation operation) (c component))
-  (let ((forced nil))                   ;return value -- everyone side-effects onto this
-    (labels ((%do-one-dep (required-op required-c required-v)
-               ;; returns a partial plan that results from performing required-op
-               ;; on required-c, possibly with a required-vERSION
-               (let* ((dep-c (or (find-component
-                                  (component-parent c)
-                                  ;; XXX tacky.  really we should build the
-                                  ;; in-order-to slot with canonicalized
-                                  ;; names instead of coercing this late
-                                  (coerce-name required-c) required-v)
-                                 (if required-v
-                                     (error 'missing-dependency-of-version
-                                            :required-by c
-                                            :version required-v
-                                            :requires required-c)
-                                     (error 'missing-dependency
-                                            :required-by c
-                                            :requires required-c))))
-                      (op (make-sub-operation c operation dep-c required-op)))
-                 (traverse op dep-c)))
-             (do-one-dep (required-op required-c required-v)
-               ;; this function is a thin, error-handling wrapper around
-               ;; %do-one-dep.  Returns a partial plan per that function.
-               (loop
-                 (restart-case
-                     (return (%do-one-dep required-op required-c required-v))
-                   (retry ()
-                     :report (lambda (s)
-                               (format s "~@<Retry loading component ~S.~@:>"
-                                       required-c))
-                     :test
-                     (lambda (c)
-#|
-                        (print (list :c1 c (typep c 'missing-dependency)))
-                        (when (typep c 'missing-dependency)
-                          (print (list :c2 (missing-requires c) required-c
-                                       (equalp (missing-requires c)
-                                               required-c))))
-|#
-                       (or (null c)
-                           (and (typep c 'missing-dependency)
-                                (equalp (missing-requires c)
-                                        required-c))))))))
-             (do-dep (op dep)
-               ;; type of arguments uncertain:  op seems to at least potentially be a
-               ;; symbol, rather than an operation
-               ;; dep is either a list of component names (?) or (we hope) a single
-               ;; component name.
-               ;; handle a single dependency, returns nothing of interest --- side-
-               ;; effects onto the FORCED variable, which is scoped over TRAVERSE
-               (cond ((eq op 'feature)
-                      (or (member (car dep) *features*)
-                          (error 'missing-dependency
-                                 :required-by c
-                                 :requires (car dep))))
-                     (t
-                      (dolist (d dep)
-                        ;; structured dependencies --- this parses keywords
-                        ;; the keywords could be broken out and cleanly (extensibly)
-                        ;; processed by EQL methods, but for the pervasive side-effecting
-                        ;; onto FORCED
-                        (cond ((consp d)
-                               (cond ((string-equal
-                                       (symbol-name (first d))
-                                       "VERSION")
-                                      ;; https://bugs.launchpad.net/asdf/+bug/527788
-                                      (appendf
-                                       forced
-                                       (do-one-dep op (second d) (third d))))
-                                     ;; this particular subform is not documented, indeed
-                                     ;; clashes with the documentation, since it assumes a
-                                     ;; third component.
-                                     ;; See https://bugs.launchpad.net/asdf/+bug/518467
-                                     ((and (string-equal
-                                            (symbol-name (first d))
-                                            "FEATURE")
-                                           (find (second d) *features*
-                                                 :test 'string-equal))
-                                      (appendf
-                                       forced
-                                       (do-one-dep op (third d) nil)))
-                                     (t
-                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
-                              (t
-                               (appendf forced (do-one-dep op d nil)))))))))
+(defgeneric do-traverse (operation component collect))
+
+(defun %do-one-dep (operation c collect required-op required-c required-v)
+  ;; collects a partial plan that results from performing required-op
+  ;; on required-c, possibly with a required-vERSION
+  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
+                      (and d (version-satisfies d required-v) d))
+                    (if required-v
+                        (error 'missing-dependency-of-version
+                               :required-by c
+                               :version required-v
+                               :requires required-c)
+                        (error 'missing-dependency
+                               :required-by c
+                               :requires required-c))))
+         (op (make-sub-operation c operation dep-c required-op)))
+    (do-traverse op dep-c collect)))
+
+(defun do-one-dep (operation c collect required-op required-c required-v)
+  ;; this function is a thin, error-handling wrapper around
+  ;; %do-one-dep.  Returns a partial plan per that function.
+  (loop
+    (restart-case
+        (return (%do-one-dep operation c collect
+                             required-op required-c required-v))
+      (retry ()
+        :report (lambda (s)
+                  (format s "~@<Retry loading component ~S.~@:>"
+                          required-c))
+        :test
+        (lambda (c)
+          #|
+          (print (list :c1 c (typep c 'missing-dependency)))
+          (when (typep c 'missing-dependency)
+          (print (list :c2 (missing-requires c) required-c
+          (equalp (missing-requires c)
+          required-c))))
+          |#
+          (or (null c)
+              (and (typep c 'missing-dependency)
+                   (equalp (missing-requires c)
+                           required-c))))))))
+
+(defun do-dep (operation c collect op dep)
+  ;; type of arguments uncertain:
+  ;; op seems to at least potentially be a symbol, rather than an operation
+  ;; dep is a list of component names
+  (cond ((eq op 'feature)
+         (if (member (car dep) *features*)
+             nil
+             (error 'missing-dependency
+                    :required-by c
+                    :requires (car dep))))
+        (t
+         (let ((flag nil))
+           (flet ((dep (op comp ver)
+                    (when (do-one-dep operation c collect
+                                      op comp ver)
+                      (setf flag t))))
+             (dolist (d dep)
+               (if (atom d)
+                   (dep op d nil)
+                   ;; structured dependencies --- this parses keywords
+                   ;; the keywords could be broken out and cleanly (extensibly)
+                   ;; processed by EQL methods
+                   (cond ((eq :version (first d))
+                          ;; https://bugs.launchpad.net/asdf/+bug/527788
+                          (dep op (second d) (third d)))
+                         ;; This particular subform is not documented and
+                         ;; has always been broken in the past.
+                         ;; Therefore no one uses it, and I'm cerroring it out,
+                         ;; after fixing it
+                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
+                         ((eq :feature (first d))
+                          (cerror "Continue nonetheless."
+                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
+                          (when (find (second d) *features* :test 'string-equal)
+                            (dep op (third d) nil)))
+                         (t
+                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
+           flag))))
+
+(defun do-collect (collect x)
+  (funcall collect x))
+
+(defmethod do-traverse ((operation operation) (c component) collect)
+  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
+    (labels
+        ((update-flag (x)
+           (when x
+             (setf flag t)))
+         (dep (op comp)
+           (update-flag (do-dep operation c collect op comp))))
+      ;; Have we been visited yet? If so, just process the result.
       (aif (component-visited-p operation c)
-           (return-from traverse
-             (if (cdr it) (list (cons 'pruned-op c)) nil)))
+           (progn
+             (update-flag (cdr it))
+             (return-from do-traverse flag)))
       ;; dependencies
-      (if (component-visiting-p operation c)
-          (error 'circular-dependency :components (list c)))
+      (when (component-visiting-p operation c)
+        (error 'circular-dependency :components (list c)))
       (setf (visiting-component operation c) t)
       (unwind-protect
-          (progn
-            ;; first we check and do all the dependencies for the
-            ;; module.  Operations planned in this loop will show up
-            ;; in the contents of the FORCED variable, and are consumed
-            ;; downstream (watch out for the shadowing FORCED variable
-            ;; around the DOLIST below!)
-            (let ((*forcing* nil))
-              ;; upstream dependencies are never forced to happen just because
-              ;; the things that depend on them are....
-              (loop :for (required-op . deps) :in
-                                              (component-depends-on operation c)
-                    :do (do-dep required-op deps)))
-            ;; constituent bits
-            (let ((module-ops
-                   (when (typep c 'module)
-                     (let ((at-least-one nil)
-                           (forced nil)
-                           ;; this is set based on the results of the
-                           ;; dependencies and whether we are in the
-                           ;; context of a *forcing* call...
-                           (must-operate (or *forcing*
-                                             ;; inter-system dependencies do NOT trigger
-                                             ;; building components
-                                             (and
-                                              (not (typep c 'system))
-                                              forced)))
-                           (error nil))
-                       (dolist (kid (module-components c))
-                           (handler-case
-                               (let ((*forcing* must-operate))
-                                 (appendf forced (traverse operation kid)))
-                             (missing-dependency (condition)
-                               (when (eq (module-if-component-dep-fails c)
-                                       :fail)
-                                   (error condition))
-                               (setf error condition))
-                             (:no-error (c)
-                               (declare (ignore c))
-                               (setf at-least-one t))))
-                       (when (and (eq (module-if-component-dep-fails c)
-                                      :try-next)
-                                  (not at-least-one))
-                         (error error))
-                       forced))))
-              ;; now the thing itself
-              ;; the test here is a bit oddly written.  FORCED here doesn't
-              ;; mean that this operation is forced on this component, but that
-              ;; something upstream of this component has been forced.
-              (when (or forced module-ops
-                        *forcing*
-                        (not (operation-done-p operation c))
-                        (let ((f (operation-forced
-                                  (operation-ancestor operation))))
-                          ;; does anyone fully understand the following condition?
-                          ;; if so, please add a comment to explain it...
-                          (and f (or (not (consp f))
-                                     (member (component-name
-                                              (operation-ancestor operation))
-                                             (mapcar #'coerce-name f)
-                                             ;; this was string=, but for the benefit
-                                             ;; of mlisp, we use string-equal for this
-                                             ;; purpose.
-                                             :test #'string-equal)))))
-                (let ((do-first (cdr (assoc (class-name (class-of operation))
-                                            (component-do-first c)))))
-                  (loop :for (required-op . deps) :in do-first
-                        :do (do-dep required-op deps)))
-                (setf forced (append (delete 'pruned-op forced :key #'car)
-                                     (delete 'pruned-op module-ops :key #'car)
-                                     (list (cons operation c)))))))
-        (setf (visiting-component operation c) nil))
-      (visit-component operation c (and forced t))
-      forced)))
-
+           (progn
+             ;; first we check and do all the dependencies for the module.
+             ;; Operations planned in this loop will show up
+             ;; in the results, and are consumed below.
+             (let ((*forcing* nil))
+               ;; upstream dependencies are never forced to happen just because
+               ;; the things that depend on them are....
+               (loop
+                 :for (required-op . deps) :in (component-depends-on operation c)
+                 :do (dep required-op deps)))
+             ;; constituent bits
+             (let ((module-ops
+                    (when (typep c 'module)
+                      (let ((at-least-one nil)
+                            ;; This is set based on the results of the
+                            ;; dependencies and whether we are in the
+                            ;; context of a *forcing* call...
+                            ;; inter-system dependencies do NOT trigger
+                            ;; building components
+                            (*forcing*
+                             (or *forcing*
+                                 (and flag (not (typep c 'system)))))
+                            (error nil))
+                        (while-collecting (internal-collect)
+                          (dolist (kid (module-components c))
+                            (handler-case
+                                (update-flag
+                                 (do-traverse operation kid #'internal-collect))
+                              (missing-dependency (condition)
+                                (when (eq (module-if-component-dep-fails c)
+                                          :fail)
+                                  (error condition))
+                                (setf error condition))
+                              (:no-error (c)
+                                (declare (ignore c))
+                                (setf at-least-one t))))
+                          (when (and (eq (module-if-component-dep-fails c)
+                                         :try-next)
+                                     (not at-least-one))
+                            (error error)))))))
+               (update-flag
+                (or
+                 *forcing*
+                 (not (operation-done-p operation c))
+                 ;; For sub-operations, check whether
+                 ;; the original ancestor operation was forced,
+                 ;; or names us amongst an explicit list of things to force...
+                 ;; except that this check doesn't distinguish
+                 ;; between all the things with a given name. Sigh.
+                 ;; BROKEN!
+                 (let ((f (operation-forced
+                           (operation-ancestor operation))))
+                   (and f (or (not (consp f)) ;; T or :ALL
+                              (and (typep c 'system) ;; list of names of systems to force
+                                   (member (component-name c) f
+                                           :test #'string=)))))))
+               (when flag
+                 (let ((do-first (cdr (assoc (class-name (class-of operation))
+                                             (component-do-first c)))))
+                   (loop :for (required-op . deps) :in do-first
+                     :do (do-dep operation c collect required-op deps)))
+                 (do-collect collect (vector module-ops))
+                 (do-collect collect (cons operation c)))))
+             (setf (visiting-component operation c) nil)))
+      (visit-component operation c flag)
+      flag))
+
+(defmethod traverse ((operation operation) (c component))
+  ;; cerror'ing a feature that seems to have NEVER EVER worked
+  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
+  ;; It was both fixed and disabled in the 1.700 rewrite.
+  (when (consp (operation-forced operation))
+    (cerror "Continue nonetheless."
+            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
+    (setf (operation-forced operation)
+          (mapcar #'coerce-name (operation-forced operation))))
+  (flatten-tree
+   (while-collecting (collect)
+     (do-traverse operation c #'collect))))
+
+(defun flatten-tree (l)
+  ;; You collected things into a list.
+  ;; Most elements are just things to collect again.
+  ;; A (simple-vector 1) indicate that you should recurse into its contents.
+  ;; This way, in two passes (rather than N being the depth of the tree),
+  ;; you can collect things with marginally constant-time append,
+  ;; achieving linear time collection instead of quadratic time.
+  (while-collecting (c)
+    (labels ((r (x)
+               (if (typep x '(simple-vector 1))
+                   (r* (svref x 0))
+                   (c x)))
+             (r* (l)
+               (dolist (x l) (r x))))
+      (r* l))))
 
 (defmethod perform ((operation operation) (c source-file))
@@ -1509 +1639 @@
 
 (defmethod perform ((operation operation) (c module))
+  (declare (ignorable operation c))
   nil)
 
@@ -1533 +1664 @@
   ;; Note how we use OUTPUT-FILES to find the binary locations
   ;; This allows the user to override the names.
-  (let* ((input (output-files o c))
-         (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
-    (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
+  (let* ((files (output-files o c))
+         (object (first files))
+         (fasl (second files)))
+    (c:build-fasl fasl :lisp-files (list object))))
 
 (defmethod perform :after ((operation operation) (c component))
@@ -1568 +1700 @@
 
 (defmethod output-files ((operation compile-op) (c cl-source-file))
+  (declare (ignorable operation))
   (let ((p (lispize-pathname (component-pathname c))))
     #-:broken-fasl-loader
-    (list #-ecl (compile-file-pathname p)
-          #+ecl (compile-file-pathname p :type :object)
+    (list (compile-file-pathname p #+ecl :type #+ecl :object)
           #+ecl (compile-file-pathname p :type :fasl))
     #+:broken-fasl-loader (list p)))
 
 (defmethod perform ((operation compile-op) (c static-file))
+  (declare (ignorable operation c))
   nil)
 
 (defmethod output-files ((operation compile-op) (c static-file))
+  (declare (ignorable operation c))
   nil)
 
-(defmethod input-files ((op compile-op) (c static-file))
+(defmethod input-files ((operation compile-op) (c static-file))
+  (declare (ignorable operation c))
   nil)
 
@@ -1603 +1738 @@
 
 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
-  (let ((state :initial))
-    (loop :until (or (eq state :success)
-                     (eq state :failure)) :do
-         (case state
-           (:recompiled
-            (setf state :failure)
-            (call-next-method)
-            (setf state :success))
-           (:failed-load
-            (setf state :recompiled)
-            (perform (make-instance 'compile-op) c))
-           (t
-            (with-simple-restart
-                (try-recompiling "Recompile ~a and try loading it again"
-                                  (component-name c))
-              (setf state :failed-load)
-              (call-next-method)
-              (setf state :success)))))))
+  (declare (ignorable o))
+  (loop :with state = :initial
+    :until (or (eq state :success)
+               (eq state :failure)) :do
+    (case state
+      (:recompiled
+       (setf state :failure)
+       (call-next-method)
+       (setf state :success))
+      (:failed-load
+       (setf state :recompiled)
+       (perform (make-instance 'compile-op) c))
+      (t
+       (with-simple-restart
+           (try-recompiling "Recompile ~a and try loading it again"
+                            (component-name c))
+         (setf state :failed-load)
+         (call-next-method)
+         (setf state :success))))))
+
+(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
+  (loop :with state = :initial
+    :until (or (eq state :success)
+               (eq state :failure)) :do
+    (case state
+      (:recompiled
+       (setf state :failure)
+       (call-next-method)
+       (setf state :success))
+      (:failed-compile
+       (setf state :recompiled)
+       (perform-with-restarts o c))
+      (t
+       (with-simple-restart
+           (try-recompiling "Try recompiling ~a"
+                            (component-name c))
+         (setf state :failed-compile)
+         (call-next-method)
+         (setf state :success))))))
 
 (defmethod perform ((operation load-op) (c static-file))
+  (declare (ignorable operation c))
   nil)
 
 (defmethod operation-done-p ((operation load-op) (c static-file))
+  (declare (ignorable operation c))
   t)
 
-(defmethod output-files ((o operation) (c component))
+(defmethod output-files ((operation operation) (c component))
+  (declare (ignorable operation c))
   nil)
 
 (defmethod component-depends-on ((operation load-op) (c component))
+  (declare (ignorable operation))
   (cons (list 'compile-op (component-name c))
         (call-next-method)))
@@ -1641 +1801 @@
 
 (defmethod perform ((o load-source-op) (c cl-source-file))
+  (declare (ignorable o))
   (let ((source (component-pathname c)))
     (setf (component-property c 'last-loaded-as-source)
@@ -1647 +1808 @@
 
 (defmethod perform ((operation load-source-op) (c static-file))
+  (declare (ignorable operation c))
   nil)
 
 (defmethod output-files ((operation load-source-op) (c component))
+  (declare (ignorable operation c))
   nil)
 
 ;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
 (defmethod component-depends-on ((o load-source-op) (c component))
+  (declare (ignorable o))
   (let ((what-would-load-op-do (cdr (assoc 'load-op
                                            (component-in-order-to c)))))
@@ -1663 +1827 @@
 
 (defmethod operation-done-p ((o load-source-op) (c source-file))
+  (declare (ignorable o))
   (if (or (not (component-property c 'last-loaded-as-source))
           (> (safe-file-write-date (component-pathname c))
@@ -1675 +1840 @@
 
 (defmethod perform ((operation test-op) (c component))
+  (declare (ignorable operation c))
   nil)
 
 (defmethod operation-done-p ((operation test-op) (c system))
   "Testing a system is _never_ done."
+  (declare (ignorable operation c))
   nil)
 
 (defmethod component-depends-on :around ((o test-op) (c system))
+  (declare (ignorable o))
   (cons `(load-op ,(component-name c)) (call-next-method)))
 
@@ -1688 +1856 @@
 ;;;; Invoking Operations
 
-(defun operate (operation-class system &rest args &key (verbose t) version force
-                &allow-other-keys)
+(defgeneric operate (operation-class system &key &allow-other-keys))
+
+(defmethod operate (operation-class system &rest args
+                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
+                    &allow-other-keys)
   (declare (ignore force))
   (let* ((*package* *package*)
@@ -1696 +1867 @@
                     :original-initargs args
                     args))
-         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
+         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
          (system (if (typep system 'component) system (find-system system))))
     (unless (version-satisfies system version)
@@ -1705 +1876 @@
           (loop
             (restart-case
-                (progn (perform-with-restarts op component)
-                       (return))
+                (progn
+                  (perform-with-restarts op component)
+                  (return))
               (retry ()
                 :report
@@ -1724 +1896 @@
     op))
 
-(defun oos (operation-class system &rest args &key force (verbose t) version
+(defun oos (operation-class system &rest args &key force verbose version
             &allow-other-keys)
   (declare (ignore force verbose version))
@@ -1754 +1926 @@
         operate-docstring))
 
-(defun load-system (system &rest args &key force (verbose t) version
+(defun load-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
@@ -1761 +1933 @@
   (apply #'operate 'load-op system args))
 
-(defun compile-system (system &rest args &key force (verbose t) version
+(defun compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
@@ -1768 +1940 @@
   (apply #'operate 'compile-op system args))
 
-(defun test-system (system &rest args &key force (verbose t) version
+(defun test-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
@@ -1801 +1973 @@
 (defmacro defsystem (name &body options)
   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
-                            &allow-other-keys)
+                            defsystem-depends-on &allow-other-keys)
       options
-    (let ((component-options (remove-keyword :class options)))
+    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
       `(progn
          ;; system must be registered before we parse the body, otherwise
          ;; we recur when trying to find an existing system of the same name
          ;; to reuse options (e.g. pathname) from
+         ,@(loop :for system :in defsystem-depends-on
+             :collect `(load-system ,system))
          (let ((s (system-registered-p ',name)))
            (cond ((and s (eq (type-of (cdr s)) ',class))
@@ -1819 +1993 @@
                                     (cdr (system-registered-p ',name))))
          (parse-component-form
-          nil (apply
-               #'list
+          nil (list*
                :module (coerce-name ',name)
                :pathname
@@ -1871 +2044 @@
 
 
-(defvar *serial-depends-on*)
+(defvar *serial-depends-on* nil)
 
 (defun sysdef-error-component (msg type name value)
   (sysdef-error (concatenate 'string msg
-                             "~&The value specified for ~(~A~) ~A is ~W")
+                             "~&The value specified for ~(~A~) ~A is ~S")
                 type name value))
 
@@ -1925 +2098 @@
 
 (defun parse-component-form (parent options)
-
   (destructuring-bind
         (type name &rest rest &key
@@ -1957 +2129 @@
                 (make-instance (class-for-type parent type)))))
       (when weakly-depends-on
-        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
-      (when (boundp '*serial-depends-on*)
-        (setf depends-on
-              (concatenate 'list *serial-depends-on* depends-on)))
+        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
+      (when *serial-depends-on*
+        (push *serial-depends-on* depends-on))
       (apply #'reinitialize-instance ret
              :name (coerce-name name)
@@ -1974 +2145 @@
         (let ((*serial-depends-on* nil))
           (setf (module-components ret)
-                (loop :for c-form :in components
+                (loop
+                  :for c-form :in components
                   :for c = (parse-component-form ret c-form)
+                  :for name = (component-name c)
                   :collect c
-                  :if serial
-                  :do (push (component-name c) *serial-depends-on*))))
-
-        ;; check for duplicate names
-        (let ((name-hash (make-hash-table :test #'equal)))
-          (loop :for c in (module-components ret) :do
-            (if (gethash (component-name c)
-                         name-hash)
-                (error 'duplicate-names :name (component-name c))
-                (setf (gethash (component-name c)
-                               name-hash)
-                      t)))))
+                  :when serial :do (setf *serial-depends-on* name))))
+        (compute-module-components-by-name ret))
+
+      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
 
       (setf (component-in-order-to ret)
@@ -1994 +2159 @@
              in-order-to
              `((compile-op (compile-op ,@depends-on))
-               (load-op (load-op ,@depends-on))))
-            (component-do-first ret) `((compile-op (load-op ,@depends-on))))
+               (load-op (load-op ,@depends-on)))))
+      (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
 
       (%refresh-component-inline-methods ret rest)
@@ -2019 +2184 @@
   (let ((command (apply #'format nil control-string args)))
     (asdf-message "; $ ~A~%" command)
-    #+sbcl
-    (sb-ext:process-exit-code
-     (apply #'sb-ext:run-program
-            #+win32 "sh" #-win32 "/bin/sh"
-            (list  "-c" command)
-            :input nil :output *verbose-out*
-            #+win32 '(:search t) #-win32 nil))
-
-    #+(or cmu scl)
-    (ext:process-exit-code
-     (ext:run-program
-      "/bin/sh"
-      (list  "-c" command)
-      :input nil :output *verbose-out*))
+
+    #+abcl
+    (ext:run-shell-command command :output *verbose-out*)
 
     #+allegro
@@ -2046 +2200 @@
       exit-code)
 
+    #+clisp                     ;XXX not exactly *verbose-out*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+
+    #+clozure
+    (nth-value 1
+               (ccl:external-process-status
+                (ccl:run-program "/bin/sh" (list "-c" command)
+                                 :input nil :output *verbose-out*
+                                 :wait t)))
+
+    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
+    (si:system command)
+
+    #+gcl
+    (lisp:system command)
+
     #+lispworks
     (system:call-system-showing-output
@@ -2054 +2224 @@
      :output-stream *verbose-out*)
 
-    #+clisp                     ;XXX not exactly *verbose-out*, I know
-    (ext:run-shell-command  command :output :terminal :wait t)
-
-    #+openmcl
-    (nth-value 1
-               (ccl:external-process-status
-                (ccl:run-program "/bin/sh" (list "-c" command)
-                                 :input nil :output *verbose-out*
-                                 :wait t)))
-
-    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (si:system command)
-
-    #+abcl
-    (ext:run-shell-command command :output *verbose-out*)
-
-    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
-    (error "RUN-SHELL-COMMAND not implemented for this Lisp")
-    ))
+    #+sbcl
+    (sb-ext:process-exit-code
+     (apply #'sb-ext:run-program
+            #+win32 "sh" #-win32 "/bin/sh"
+            (list  "-c" command)
+            :input nil :output *verbose-out*
+            #+win32 '(:search t) #-win32 nil))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output *verbose-out*))
+
+    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2091 +2259 @@
 
 (defun relativize-directory (directory)
-  (if (eq (car directory) :absolute)
-      (cons :relative (cdr directory))
-      directory))
+  (cond
+    ((stringp directory)
+     (list :relative directory))
+    ((eq (car directory) :absolute)
+     (cons :relative (cdr directory)))
+    (t
+     directory)))
 
 (defun relativize-pathname-directory (pathspec)
@@ -2120 +2292 @@
   '((:windows :mswindows :win32 :mingw32)
     (:solaris :sunos)
+    :linux ;; for GCL at least, must appear before :bsd.
     :macosx :darwin :apple
     :freebsd :netbsd :openbsd :bsd
-    :linux :unix))
+    :unix))
 
 (defparameter *architecture-features*
   '((:x86-64 :amd64 :x86_64 :x8664-target)
     (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
-    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
+    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
+    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
 
 (defun lisp-version-string ()
   (let ((s (lisp-implementation-version)))
     (declare (ignorable s))
-    #+(or scl sbcl ecl armedbear cormanlisp mcl) s
-    #+cmu (substitute #\- #\/ s)
-    #+clozure (format nil "~d.~d~@[-~d~]"
-                      ccl::*openmcl-major-version*
-                      ccl::*openmcl-minor-version*
-                      #+ppc64-target 64
-                      #-ppc64-target nil)
-    #+lispworks (format nil "~A~@[~A~]" s
-                        (when (member :lispworks-64bit *features*) "-64bit"))
     #+allegro (format nil
                       "~A~A~A~A"
@@ -2153 +2318 @@
                        (:+ics ""))
                       (if (member :64bit *features*) "-64bit" ""))
-    #+(or clisp gcl) (subseq s 0 (position #\space s))
-    #+digitool (subseq s 8)))
+    #+clisp (subseq s 0 (position #\space s))
+    #+clozure (format nil "~d.~d-fasl~d"
+                      ccl::*openmcl-major-version*
+                      ccl::*openmcl-minor-version*
+                      (logand ccl::fasl-version #xFF))
+    #+cmu (substitute #\- #\/ s)
+    #+digitool (subseq s 8)
+    #+ecl (format nil "~A~@[-~A~]" s
+                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+                    (when (>= (length vcs-id) 8)
+                      (subseq vcs-id 0 8))))
+    #+gcl (subseq s (1+ (position #\space s)))
+    #+lispworks (format nil "~A~@[~A~]" s
+                        (when (member :lispworks-64bit *features*) "-64bit"))
+    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
+    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+    #+(or  mcl sbcl scl) s
+    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
+          ecl gcl lispworks mcl sbcl scl) s))
 
 (defun first-feature (features)
@@ -2222 +2404 @@
            :for dir :in (split-string dirs :separator ":")
            :collect (try dir "common-lisp/"))
-       #+windows
+       #+(and (or win32 windows mswindows mingw32) (not cygwin))
         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-           #+(not cygwin)
-           ,(try (or (getenv "USERPROFILE") (user-homedir))
-                 "Application Data/common-lisp/config/"))
+           ,(try (getenv "APPDATA") "common-lisp/config/"))
        ,(try (user-homedir) ".config/common-lisp/")))))
 (defun system-configuration-directories ()
@@ -2233 +2413 @@
    #'null
    (append
-    #+windows
+    #+(and (or win32 windows mswindows mingw32) (not cygwin))
     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-      `(
-       ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
+      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-           #+(not cygwin)
-           ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     (list #p"/etc/"))))
 (defun in-first-directory (dirs x)
   (loop :for dir :in dirs
-    :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
+    :thereis (and dir (ignore-errors
+                        (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
 (defun in-user-configuration-directory (x)
   (in-first-directory (user-configuration-directories) x))
@@ -2300 +2479 @@
 
 (defvar *user-cache*
-  (or
-   (let ((h (getenv "XDG_CACHE_HOME")))
-     (and h `(,h "common-lisp" :implementation)))
-   #+(and windows lispworks)
-   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
-     (and h `(,h "common-lisp" "cache")))
-   #+(and windows (not cygwin))
-   ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
-   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
-     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
-   '(:home ".cache" "common-lisp" :implementation)))
+  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
+    (or
+     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
+     #+(and (or win32 windows mswindows mingw32) (not cygwin))
+     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+     '(:home ".cache" "common-lisp" :implementation))))
 (defvar *system-cache*
-  (or
-   #+(and windows lispworks)
-   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
-     (and h `(,h "common-lisp" "cache")))
-   #+windows
-   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
-     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
-   #+(or unix cygwin)
-   '("/var/cache/common-lisp" :uid :implementation)))
+  ;; No good default, plus there's a security problem
+  ;; with other users messing with such directories.
+  *user-cache*)
 
 (defun output-translations ()
@@ -2516 +2684 @@
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
-    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-    #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
+    ;; These are for convenience, and can be overridden by the user:
+    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
+    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     ;; If we want to enable the user cache by default, here would be the place:
     :enable-user-cache))
@@ -2707 +2876 @@
 (defun translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let ((root (apply-output-translations
-               (concatenate 'string
-                            "/:jar:file/"
-                            (namestring (first (pathname-device
-                                                source))))))
-        (entry (make-pathname :directory (pathname-directory source)
-                              :name (pathname-name source)
-                              :type (pathname-type source))))
-    (concatenate 'string (namestring root) (namestring entry))))
+  (let* ((p (pathname (first (pathname-device source))))
+         (root (format nil "/___jar___file___root___/~@[~A/~]"
+                       (and (find :windows *features*)
+                            (pathname-device p)))))
+    (apply-output-translations
+     (merge-pathnames*
+      (relativize-pathname-directory source)
+      (merge-pathnames*
+       (relativize-pathname-directory (ensure-directory-pathname p))
+       root)))))
 
 ;;;; -----------------------------------------------------------------
@@ -2855 +3025 @@
   (values))
 
+(defun probe-asd (name defaults)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (let ((file
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name name
+              :type "asd")))
+        (when (probe-file file)
+          (return file)))
+      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+      (let ((shortcut
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name (concatenate 'string name ".asd")
+              :type "lnk")))
+        (when (probe-file shortcut)
+          (let ((target (parse-windows-shortcut shortcut)))
+            (when target
+              (return (pathname target)))))))))
+
 (defun sysdef-source-registry-search (system)
   (ensure-source-registry)
-  (let ((name (coerce-name system)))
-    (block nil
-      (dolist (dir (source-registry))
-        (let ((defaults (eval dir)))
-          (when defaults
-            (cond ((directory-pathname-p defaults)
-                   (let ((file (and defaults
-                                    (make-pathname
-                                     :defaults defaults :version :newest
-                                     :name name :type "asd" :case :local)))
-                         #+(and (or win32 windows) (not :clisp))
-                         (shortcut (make-pathname
-                                    :defaults defaults :version :newest
-                                    :name name :type "asd.lnk" :case :local)))
-                     (when (and file (probe-file file))
-                       (return file))
-                     #+(and (or win32 windows) (not :clisp))
-                     (when (probe-file shortcut)
-                       (let ((target (parse-windows-shortcut shortcut)))
-                         (when target
-                           (return (pathname target))))))))))))))
+  (loop :with name = (coerce-name system)
+    :for defaults :in (source-registry)
+    :for file = (probe-asd name defaults)
+    :when file :return file))
 
 (defun validate-source-registry-directive (directive)
@@ -2942 +3116 @@
   (if (not recurse)
       (funcall collect directory)
-      (let* ((files (ignore-errors
-                      (directory (merge-pathnames* *wild-asd* directory)
-                                 #+sbcl #+sbcl :resolve-symlinks nil
-                                 #+clisp #+clisp :circle t)))
+      (let* ((files
+              (handler-case
+                  (directory (merge-pathnames* *wild-asd* directory)
+                             #+sbcl #+sbcl :resolve-symlinks nil
+                             #+clisp #+clisp :circle t)
+                (error (c)
+                  (warn "Error while scanning system definitions under directory ~S:~%~A"
+                        directory c)
+                  nil)))
              (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
                                       :test #'equal :from-end t)))
@@ -2982 +3161 @@
            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
           (dirs (cons datahome (split-string datadirs :separator ":"))))
-         #+(and windows (not cygwin))
-         ((datahome
-           #+lispworks (sys:get-folder-path :common-appdata)
-           #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
-                            "Application Data"))
+         #+(and (or win32 windows mswindows mingw32) (not cygwin))
+         ((datahome (getenv "APPDATA"))
           (datadir
            #+lispworks (sys:get-folder-path :local-appdata)
@@ -2992 +3168 @@
                             "Application Data"))
           (dirs (list datahome datadir)))
-         #+(and (not unix) (not windows) (not cygwin))
+         #-(or unix win32 windows mswindows mingw32 cygwin)
          ((dirs ()))
          (loop :for dir :in dirs
@@ -3094 +3270 @@
 
 ;;;; -----------------------------------------------------------------
-;;;; SBCL and ClozureCL hook into REQUIRE
+;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
 ;;;;
-#+(or sbcl clozure abcl)
+#+(or abcl clozure cmu ecl sbcl)
 (progn
   (defun module-provide-asdf (name)
@@ -3106 +3282 @@
                           name e))))
       (let* ((*verbose-out* (make-broadcast-stream))
-             (system (asdf:find-system name nil)))
+             (system (find-system name nil)))
         (when system
-          (asdf:operate 'asdf:load-op name)
+          (load-system name)
           t))))
   (pushnew 'module-provide-asdf
-           #+sbcl sb-ext:*module-provider-functions*
+           #+abcl sys::*module-provider-functions*
            #+clozure ccl::*module-provider-functions*
-           #+abcl sys::*module-provider-functions*))
+           #+cmu ext:*module-provider-functions*
+           #+ecl si:*module-provider-functions*
+           #+sbcl sb-ext:*module-provider-functions*))
 
 ;;;; -------------------------------------------------------------------------

branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp

@@ -210 +210 @@
              (float (/ (ext:uptime) 1000)))))
 
-;;; "system.lisp" contains system installation specific information
-;;; (currently only the logical pathname definition for "SYS;SRC")
-;;; that is not currently required for ABCL to run.  Since
-;;; LOAD-SYSTEM-FILE exits the JVM if its argument cannot be found, we
-;;; use REQUIRE trapping any error.
-(handler-case 
-    (require 'system)
-  (t ()))
-
+

branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp

@@ -54 +54 @@
 (export '(class-precedence-list class-slots))
 (defconstant +the-standard-class+ (find-class 'standard-class))
+(defconstant +the-standard-object-class+ (find-class 'standard-object))
+(defconstant +the-standard-method-class+ (find-class 'standard-method))
+(defconstant +the-standard-reader-method-class+
+  (find-class 'standard-reader-method))
+(defconstant +the-standard-generic-function-class+
+  (find-class 'standard-generic-function))
+(defconstant +the-T-class+ (find-class 'T))
 
 ;; Don't use DEFVAR, because that disallows loading clos.lisp
@@ -557 +564 @@
                                              &allow-other-keys)
   (let ((supers (or direct-superclasses
-                    (list (find-class 'standard-object)))))
+                    (list +the-standard-object-class+))))
     (setf (class-direct-superclasses class) supers)
     (dolist (superclass supers)
@@ -580 +587 @@
   (getf canonical-slot :name))
 
-(defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object)))
+(defvar *extensible-built-in-classes*
+  (list (find-class 'sequence)
+        (find-class 'java:java-object)))
 
 (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
@@ -741 +750 @@
   (set-generic-function-classes-to-emf-table gf new-value))
 
-(defvar the-class-standard-method (find-class 'standard-method))
-
 (defun (setf method-lambda-list) (new-value method)
   (set-method-lambda-list method new-value))
@@ -851 +858 @@
                                 &key
                                 lambda-list
-                                (generic-function-class (find-class 'standard-generic-function))
-                                (method-class the-class-standard-method)
+                                (generic-function-class +the-standard-generic-function-class+)
+                                (method-class +the-standard-method-class+)
                                 (method-combination 'standard)
                                 (argument-precedence-order nil apo-p)
@@ -886 +893 @@
                    :format-control "~A already names an ordinary function, macro, or special operator."
                    :format-arguments (list function-name)))
-          (setf gf (apply (if (eq generic-function-class (find-class 'standard-generic-function))
+          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
                               #'make-instance-standard-generic-function
                               #'make-instance)
@@ -899 +906 @@
   (set-funcallable-instance-function
    gf
-   (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
+   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
                 #'std-compute-discriminating-function
                 #'compute-discriminating-function)
@@ -934 +941 @@
                                                 documentation)
   (declare (ignore generic-function-class))
-  (let ((gf (std-allocate-instance (find-class 'standard-generic-function))))
+  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
     (%set-generic-function-name gf name)
     (setf (generic-function-lambda-list gf) lambda-list)
@@ -1163 +1170 @@
         (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
     (let ((method
-           (if (eq (generic-function-method-class gf) the-class-standard-method)
+           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
                (apply #'make-instance-standard-method gf all-keys)
                (apply #'make-instance (generic-function-method-class gf) all-keys))))
@@ -1178 +1185 @@
                                       fast-function)
   (declare (ignore gf))
-  (let ((method (std-allocate-instance the-class-standard-method)))
+  (let ((method (std-allocate-instance +the-standard-method-class+)))
     (setf (method-lambda-list method) lambda-list)
     (setf (method-qualifiers method) qualifiers)
@@ -1367 +1374 @@
       methods
       (sort methods
-      (if (eq (class-of gf) (find-class 'standard-generic-function))
+      (if (eq (class-of gf) +the-standard-generic-function-class+)
     #'(lambda (m1 m2)
         (std-method-more-specific-p m1 m2 required-classes
@@ -1420 +1427 @@
   (let ((applicable-methods (%compute-applicable-methods gf args)))
     (if applicable-methods
-        (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
+        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
                                   #'std-compute-effective-method-function
                                   #'compute-effective-method-function)
@@ -1431 +1438 @@
   (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
     (if applicable-methods
-        (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
+        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
                                   #'std-compute-effective-method-function
                                   #'compute-effective-method-function)
@@ -1517 +1524 @@
        (let ((next-emfun
               (funcall
-               (if (eq (class-of gf) (find-class 'standard-generic-function))
+               (if (eq (class-of gf) +the-standard-generic-function-class+)
                    #'std-compute-effective-method-function
                    #'compute-effective-method-function)
@@ -1767 +1774 @@
                                              slot-name)
   (declare (ignore gf))
-  (let ((method (std-allocate-instance (find-class 'standard-reader-method))))
+  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
     (setf (method-lambda-list method) lambda-list)
     (setf (method-qualifiers method) qualifiers)
@@ -1818 +1825 @@
                    :lambda-list '(new-value object)
                    :qualifiers ()
-                   :specializers (list (find-class 't) class)
+                   :specializers (list +the-T-class+ class)
 ;;                    :function `(function ,method-function)
                    :function (if (autoloadp 'compile)

branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp

@@ -41 +41 @@
 (defvar *output-file-pathname*)
 
-(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.")
-
 (defun base-classname (&optional (output-file-pathname *output-file-pathname*))
   (sanitize-class-name (pathname-name output-file-pathname)))
@@ -134 +132 @@
           ((IN-PACKAGE DEFPACKAGE)
            (note-toplevel-form form)
-     (if (eq operator 'in-package)
-         (push (cons (1+ *class-number*) (cadr form)) *function-packages*))
            (setf form (precompiler:precompile-form form nil *compile-file-environment*))
            (eval form)
@@ -549 +545 @@
              (*source* *compile-file-truename*)
              (*class-number* 0)
-       (*function-packages* nil)
              (namestring (namestring *compile-file-truename*))
              (start (get-internal-real-time))
-             elapsed)
+             elapsed
+             *fasl-uninterned-symbols*)
         (when *compile-verbose*
           (format t "; Compiling ~A ...~%" namestring))
@@ -565 +561 @@
                   (jvm::*functions-defined-in-current-file* '())
                   (*fbound-names* '())
-                  (*fasl-anonymous-package* (%make-package))
                   (*fasl-stream* out)
                   *forms-for-output*)
@@ -604 +599 @@
             (%stream-terpri out)
             (let ((*package* (find-package '#:cl)))
-                  ;(count-sym (gensym)))
               (write (list 'init-fasl :version *fasl-version*)
                      :stream out)
@@ -611 +605 @@
                      :stream out)
               (%stream-terpri out)
+        ;; Note: Beyond this point, you can't use DUMP-FORM,
+        ;; because the list of uninterned symbols has been fixed now.
+        (when *fasl-uninterned-symbols*
+    (write (list 'setq '*fasl-uninterned-symbols*
+           (coerce (mapcar #'car
+               (nreverse *fasl-uninterned-symbols*))
+             'vector))
+           :stream out))
+        (%stream-terpri out)
 
         (when (> *class-number* 0)
@@ -617 +620 @@
         (identity fasl-loader) ;;to avoid unused arg
         ;;Ugly: should export & import JVM:: symbols
-        #|(let ((*package* *package*))
-        ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined
-          (when x
-            `(in-package ,(string x))))|#
         (ecase fn-index
           ,@(loop
@@ -626 +625 @@
                :collect
            (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
-             `(,(1- i) (jvm::with-inline-code ()
-          ;(jvm::emit 'jvm::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*)))
-          ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system)))
-          ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage"
-          ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+)
-          ;(jvm::emit-push-current-thread)
-          ;           (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue"
-          ;                  (list jvm::+lisp-thread+) jvm::+lisp-object+)
-              (jvm::emit 'jvm::aload 1)
-              (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
-                     nil jvm::+java-object+)
-              (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
-              (jvm::emit 'jvm::dup)
-              (jvm::emit-push-constant-int ,(1- i))
-              (jvm::emit 'jvm::new ,class)
-              (jvm::emit 'jvm::dup)
-              (jvm::emit-invokespecial-init ,class '())
-              (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
-                     (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
-              (jvm::emit 'jvm::pop))
-            t))))))
+             `(,(1- i)
+                (jvm::with-inline-code ()
+            (jvm::emit 'jvm::aload 1)
+            (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
+                   nil jvm::+java-object+)
+            (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
+            (jvm::emit 'jvm::dup)
+            (jvm::emit-push-constant-int ,(1- i))
+            (jvm::emit 'jvm::new ,class)
+            (jvm::emit 'jvm::dup)
+            (jvm::emit-invokespecial-init ,class '())
+            (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
+                   (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
+            (jvm::emit 'jvm::pop))
+                t))))))
            (classname (fasl-loader-classname))
            (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
@@ -658 +651 @@
          :if-exists :supersede)
           (jvm:compile-defun nil expr nil
-                 classfile f nil)))))
+                 classfile f nil))))
+      (format t "~&; Wrote fasl loader ~A~%" classfile))
     (write (list 'setq '*fasl-loader*
            `(sys::make-fasl-class-loader
              ,*class-number*
-             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)
-    (%stream-terpri out))
-#|        (dump-form
-         `(dotimes (,count-sym ,*class-number*)
-      (java:jcall "loadFunction" *fasl-loader*
-            (%format nil "~A_~D"
-               ,(sanitize-class-name
-           (pathname-name output-file))
-               (1+ ,count-sym))))
-         out)|#
-
-        ;;END TODO
-
-#|              (dump-form `(dotimes (,count-sym ,*class-number*)
-                            (function-preload
-                             (%format nil "~A_~D.cls"
-                                      ,(sanitize-class-name
-          (pathname-name output-file))
-                                      (1+ ,count-sym))))
-       out)|#
+             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
               (%stream-terpri out))
 
@@ -700 +675 @@
                            (merge-pathnames (make-pathname :type type)
                                             output-file)))
-                 (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
-                     output-file)))))
+                 (pathnames nil)
+     (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
+                 output-file))))
+      (when (probe-file fasl-loader)
+        (push fasl-loader pathnames))
             (dotimes (i *class-number*)
               (let* ((pathname (compute-classfile-name (1+ i))))

branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -2343 +2343 @@
   (let ((g (symbol-name (gensym "INSTANCE")))
         saved-code)
-    (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj)
     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
            (*code* (if *declare-inline* *code* *static-code*)))
@@ -5020 +5019 @@
 
 (defun p2-progv-node (block target representation)
-  (declare (ignore representation))
   (let* ((form (progv-form block))
          (symbols-form (cadr form))
@@ -5041 +5039 @@
       ;; Implicit PROGN.
     (let ((*blocks* (cons block *blocks*)))
-      (compile-progn-body (cdddr form) target))
+      (compile-progn-body (cdddr form) target representation))
     (restore-environment-and-make-handler environment-register label-START)))
 
@@ -6125 +6123 @@
                 (emit-invokevirtual +lisp-stream-class+ "readLine"
                                     (list "Z" +lisp-object+) +lisp-object+)
-                (when target
-                  (emit-move-from-stack target)))
+                (emit-move-from-stack target))
                (t
                 (compile-function-call form target representation)))))
@@ -6141 +6138 @@
                 (emit-invokevirtual +lisp-stream-class+ "readLine"
                                     (list "Z" +lisp-object+) +lisp-object+)
-                (when target
-                  (emit-move-from-stack target))
+                (emit-move-from-stack target)
                 )
                (t
@@ -8581 +8577 @@
       (setf *code* (nconc code *code*)))
 
+    (setf (abcl-class-file-superclass class-file)
+          (if (or *hairy-arglist-p*
+      (and *child-p* *closure-variables*))
+        +lisp-compiled-closure-class+
+      +lisp-primitive-class+))
+
+    (setf (abcl-class-file-lambda-list class-file) args)
+    (setf (method-max-locals execute-method) *registers-allocated*)
+    (push execute-method (abcl-class-file-methods class-file))
+
+
+    ;;;  Move here
     (finalize-code)
     (optimize-code)
@@ -8594 +8602 @@
                             (symbol-value (handler-to handler))))
                      *handlers*))
-
-    (setf (method-max-locals execute-method) *registers-allocated*)
-    (setf (method-handlers execute-method) (nreverse *handlers*))
-
-    (setf (abcl-class-file-superclass class-file)
-          (if (or *hairy-arglist-p*
-      (and *child-p* *closure-variables*))
-        +lisp-compiled-closure-class+
-      +lisp-primitive-class+))
-
-    (setf (abcl-class-file-lambda-list class-file) args)
-
-    (push execute-method (abcl-class-file-methods class-file)))
+    ;;; to here
+    ;;; To a separate function which is part of class file finalization
+    ;;;  when we have a section of class-file-generation centered code
+
+
+    (setf (method-handlers execute-method) (nreverse *handlers*)))
   t)
 
@@ -8806 +8807 @@
         (*local-functions* nil)
         (*pathnames-generator* (constantly nil))
-        (sys::*fasl-anonymous-package* (sys::%make-package))
         environment)
     (unless (and (consp definition) (eq (car definition) 'LAMBDA))

branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp

@@ -104 +104 @@
              (java:java-object-p object))
          (dump-instance object stream))
+        ((and (symbolp object) ;; uninterned symbol
+              (null (symbol-package object)))
+         (let ((index (cdr (assoc object *fasl-uninterned-symbols*))))
+           (unless index
+             (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
+             (setq *fasl-uninterned-symbols*
+                   (acons object index *fasl-uninterned-symbols*)))
+           (write-string "#" stream)
+           (write index :stream stream)
+           (write-string "?" stream)))
         (t
          (%stream-output-object object stream))))

branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp

@@ -326 +326 @@
 
 ;;; JAVA-CLASS support
+(defconstant +java-lang-object+ (jclass "java.lang.Object"))
 
 (defclass java-class (standard-class)
@@ -331 +332 @@
      :initform (error "class is required")
      :reader java-class-jclass)))
+
+;;init java.lang.Object class
+(defconstant +java-lang-object-class+
+  (%register-java-class +java-lang-object+
+      (mop::ensure-class (make-symbol "java.lang.Object")
+             :metaclass (find-class 'java-class)
+             :direct-superclasses (list (find-class 'java-object))
+             :java-class +java-lang-object+)))
 
 (defun ensure-java-class (jclass)
@@ -341 +350 @@
      :metaclass (find-class 'java-class)
      :direct-superclasses
-     (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
-         (list (find-class 'java-object))
-         (mapcar #'ensure-java-class
-           (delete nil
-             (concatenate 'list (list (jclass-superclass jclass))
-              (jclass-interfaces jclass)))))
+     (let ((supers
+      (mapcar #'ensure-java-class
+        (delete nil
+          (concatenate 'list
+                 (list (jclass-superclass jclass))
+                 (jclass-interfaces jclass))))))
+       (if (jclass-interface-p jclass)
+           (append supers (list (find-class 'java-object)))
+           supers))
      :java-class jclass)))))
 
+(defmethod mop::compute-class-precedence-list ((class java-class))
+  "Sort classes this way:
+   1. Java classes (but not java.lang.Object)
+   2. Java interfaces
+   3. java.lang.Object
+   4. other classes
+   Rationale:
+   1. Concrete classes are the most specific.
+   2. Then come interfaces.
+     So if a generic function is specialized both on an interface and a concrete class,
+     the concrete class comes first.
+   3. because everything is an Object.
+   4. to handle base CLOS classes.
+   Note: Java interfaces are not sorted among themselves in any way, so if a
+   gf is specialized on two different interfaces and you apply it to an object that
+   implements both, it is unspecified which method will be called."
+  (let ((cpl (nreverse (mop::collect-superclasses* class))))
+    (flet ((score (class)
+       (if (not (typep class 'java-class))
+     4
+     (cond
+       ((jcall (jmethod "java.lang.Object" "equals" "java.lang.Object")
+         (java-class-jclass class) +java-lang-object+) 3)
+       ((jclass-interface-p (java-class-jclass class)) 2)
+       (t 1)))))
+      (stable-sort cpl #'(lambda (x y)
+         (< (score x) (score y)))))))
+    
 (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys)
   (declare (ignore initargs))

branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java

@@ -93 +93 @@
             }
 
-            String head = "HEAD " + url + " HTTP/1.1";
+            String head = "HEAD " + url.getPath() + " HTTP/1.1";
             out.println(head);
+            out.println("Host: " + url.getAuthority());
             out.println("Connection: close");
             out.println("");

branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp

@@ -125 +125 @@
 ;;; XXX come up with a better abstraction
 
+(defvar *url-jar-pathname-base*
+  "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20100505a.jar!/")
+
+(defmacro load-url-relative (path) 
+  `(load (format nil "~A~A" *url-jar-pathname-base* ,path)))
+
 (progn 
   (deftest jar-pathname.load.11
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo")
+      (load-url-relative "foo")
     t)
 
   (deftest jar-pathname.load.12
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar")
+      (load-url-relative "bar")
     t)
 
   (deftest jar-pathname.load.13
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl")
+      (load-url-relative "bar.abcl")
     t)
 
   (deftest jar-pathname.load.14
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek")
+      (load-url-relative "eek")
     t)
 
   (deftest jar-pathname.load.15
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp")
+      (load-url-relative "eek.lisp")
     t)
 
   (deftest jar-pathname.load.16
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo")
+      (load-url-relative "a/b/foo")
     t)
 
   (deftest jar-pathname.load.17
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar")
+      (load-url-relative "a/b/bar")
     t)
 
   (deftest jar-pathname.load.18
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl")
+      (load-url-relative "a/b/bar.abcl")
     t)
 
   (deftest jar-pathname.load.19
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek")
+      (load-url-relative "a/b/eek")
     t)
 
   (deftest jar-pathname.load.20
-      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp")
+      (load-url-relative "a/b/eek.lisp")
     t))
-
 
 (deftest jar-pathname.probe-file.1
@@ -215 +220 @@
      "jar:file:baz.jar!/foo" "/a/b/c")
   #p"jar:file:/a/b/baz.jar!/foo")
+
+
+;;; Under win32, we get the device in the merged path
+#+windows 
+(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
 
 (deftest jar-pathname.merge-pathnames.5
@@ -333 +343 @@
 
 (deftest jar-pathname.translate.1
-    (namestring
-     (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
-                         "jar:file:/**/*.jar!/**/*.*" 
-                         "/foo/**/*.*"))
-  "/foo/d/e/f.lisp")
+    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
+      "jar:file:/**/*.jar!/**/*.*" 
+      "/foo/**/*.*")
+  #p"/foo/d/e/f.lisp")