[armedbear-cvs] r12679 - in branches/less-reflection/abcl: . contrib/asdf-install doc/asdf src/org/armedbear/lisp src/org/armedbear/lisp/util test/lisp/abcl
Alessio Stalla
astalla at common-lisp.net
Thu May 13 21:15:08 UTC 2010
Author: astalla
Date: Thu May 13 17:15:07 2010
New Revision: 12679
Log:
Fixed missing probe-file in zipped fasl construction.
Advanced the branch to merge the latest trunk updates.
Modified:
branches/less-reflection/abcl/CHANGES
branches/less-reflection/abcl/abcl.asd
branches/less-reflection/abcl/abcl.properties.in
branches/less-reflection/abcl/build.xml
branches/less-reflection/abcl/contrib/asdf-install/installer.lisp
branches/less-reflection/abcl/doc/asdf/asdf.texinfo
branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java
branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java
branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java
branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java
branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java
branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java
branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java
branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp
Modified: branches/less-reflection/abcl/CHANGES
==============================================================================
--- branches/less-reflection/abcl/CHANGES (original)
+++ branches/less-reflection/abcl/CHANGES Thu May 13 17:15:07 2010
@@ -1,3 +1,68 @@
+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
============
svn://common-lisp.net/project/armedbear/svn/trunk/abcl
@@ -78,8 +143,8 @@
* [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.
@@ -187,21 +252,21 @@
for some aspects of jar pathname work added.
* 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.
* [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
==============
Modified: branches/less-reflection/abcl/abcl.asd
==============================================================================
--- branches/less-reflection/abcl/abcl.asd (original)
+++ branches/less-reflection/abcl/abcl.asd Thu May 13 17:15:07 2010
@@ -32,6 +32,7 @@
:pathname "test/lisp/abcl/" :components
((:file "compiler-tests")
(:file "condition-tests")
+ (:file "metaclass")
(:file "mop-tests-setup")
(:file "mop-tests" :depends-on ("mop-tests-setup"))
(:file "file-system-tests")
Modified: branches/less-reflection/abcl/abcl.properties.in
==============================================================================
--- branches/less-reflection/abcl/abcl.properties.in (original)
+++ branches/less-reflection/abcl/abcl.properties.in Thu May 13 17:15:07 2010
@@ -10,4 +10,7 @@
#abcl.compile.lisp.skip=true
# java.options sets the Java options in the abcl wrapper scripts
-#java.options=-Xmx1g
\ No newline at end of file
+#java.options=-Xmx1g
+
+# Additional site specific startup code to be merged in 'system.lisp'
+#abcl.startup.file=${basedir}/startup.lisp
Modified: branches/less-reflection/abcl/build.xml
==============================================================================
--- branches/less-reflection/abcl/build.xml (original)
+++ branches/less-reflection/abcl/build.xml Thu May 13 17:15:07 2010
@@ -101,7 +101,7 @@
<target name="abcl.compile" depends="abcl.clean.maybe,abcl.compile.lisp">
<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>
<echo>Setting 'abcl.build.incremental' enables incremental compilation.</echo>
@@ -143,7 +143,7 @@
<condition property="abcl.java.version.p">
<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>
@@ -176,6 +176,7 @@
<javac destdir="${build.classes.dir}"
debug="true"
target="1.5"
+ includeantruntime="false"
failonerror="true">
<src path="${src.dir}"/>
<patternset refid="abcl.source.java"/>
@@ -223,9 +224,12 @@
<path id="abcl.lisp.output.path"
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>
Compiling Lisp system
@@ -238,9 +242,13 @@
classname="org.armedbear.lisp.Main">
<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>
<property name="abcl.build.path"
@@ -271,6 +279,23 @@
<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>
+
<target name="abcl.jar.uptodate" depends="abcl.compile">
<uptodate property="abcl.jar.uptodate.p" targetfile="${abcl.jar.path}">
<srcfiles dir="${build.classes.dir}">
@@ -671,9 +696,9 @@
<java fork="true"
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>
@@ -705,7 +730,7 @@
<arg value="--noinit"/>
<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>
<record name="${abcl.test.log.file}" emacsmode="true" action="stop"/>
Modified: branches/less-reflection/abcl/contrib/asdf-install/installer.lisp
==============================================================================
--- branches/less-reflection/abcl/contrib/asdf-install/installer.lisp (original)
+++ branches/less-reflection/abcl/contrib/asdf-install/installer.lisp Thu May 13 17:15:07 2010
@@ -541,8 +541,7 @@
(return-from sysdef-source-dir-search file)))))))
(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*
:test (lambda (a b)
Modified: branches/less-reflection/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- branches/less-reflection/abcl/doc/asdf/asdf.texinfo (original)
+++ branches/less-reflection/abcl/doc/asdf/asdf.texinfo Thu May 13 17:15:07 2010
@@ -32,6 +32,9 @@
This manual describes ASDF, a system definition facility
for Common Lisp programs and libraries.
+You can find the latest version of this manual at
+ at url{http://common-lisp.net/project/asdf/asdf.html}.
+
ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
@@ -167,12 +170,12 @@
the ASDF internals and how to extend ASDF.
@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.
- at ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
+ at xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
@node Loading ASDF, Configuring ASDF, Introduction, Top
@@ -238,7 +241,7 @@
then you're using an old version of ASDF (from before 1.635).
If it returns @code{NIL} then ASDF is not installed.
-If you are running a version older than 1.678,
+If you are running a version older than 1.711,
we recommend that you load a newer ASDF using the method below.
@@ -532,7 +535,7 @@
each in subtly different and incompatible ways:
ASDF-Binary-Locations, cl-launch, common-lisp-controller.
ASDF-Binary-Locations is now not needed anymore and should not be used.
-cl-launch 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.
@node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
@@ -549,7 +552,7 @@
(asdf:load-system :@var{foo})
@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:
@@ -1316,11 +1319,11 @@
@code{defsystem} grammar subsection,
which doesn't provide any obvious way to specify required features.
Furthermore, in 2009, discussions on the
- at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+ at 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
- at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
+ at 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.}
Traditionally defsystem users have used reader conditionals
@@ -1671,7 +1674,7 @@
where output file caches are located.
Mentions of XDG variables refer to that document.
- at uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
+ at url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
This specification allows the user to specify some environment variables
to customize how applications behave to his preferences.
@@ -2463,7 +2466,7 @@
There is also a STABLE version, which is earlier than release.
You may get the ASDF source repository using git:
- at kbd{git clone http://common-lisp.net/project/asdf/asdf.git}
+ at kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
You will find the above referenced tags in this repository.
You can also browse the repository on
@@ -2472,7 +2475,7 @@
Discussion of ASDF development is conducted on the
mailing list
@kbd{asdf-devel@@common-lisp.net}.
- at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
+ at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
@node FAQ, TODO list, Getting the latest version, Top
@@ -2484,7 +2487,7 @@
ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
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}
@section ``What has changed between ASDF 1 and ASDF 2?''
@@ -2496,7 +2499,7 @@
While the code and documentation are essentially complete
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,
ASDF 2 refers to releases later than 1.656,
@@ -2513,12 +2516,14 @@
we recommend that you should upgrade to ASDF 2 or its latest release candidate.
- at subsection ASDF can portably name files inside systems and components
+ at 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 ...)}.
Even the above were themselves were inadequate in the general case
@@ -2534,6 +2539,7 @@
@xref{The defsystem grammar,,Pathname specifiers}.
+
@subsection Output translations
A popular feature added to ASDF was output pathname translation:
@@ -2571,13 +2577,24 @@
with sensible defaults, adequate configuration languages,
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
+ at 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
In ASDF 1, you had to use the awkward syntax
@@ -2592,23 +2609,43 @@
@subsection Many bugs have been fixed
-These issues and many others have been fixed,
-including the following:
+The following issues and many others have been fixed:
-Dependencies were not correctly propagated
-across submodules within a system.
+ at itemize
+ at 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.
+ at 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.
+
+ at item
Many features used to not be portable,
especially where pathnames were involved.
+Windows support was notably quirky because of such non-portability.
-The internal test suite used to massively fail
-in many implementations.
+ at 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.
-Support was broken for some implementations (notably ABCL).
+ at item
+Support was lacking for some implementations.
+ABCL was notably wholly broken.
+ECL extensions were not integrated in the ASDF release.
+ at item
The documentation was grossly out of date.
-ECL extensions were not integrated in the ASDF release.
+ at end itemize
@subsection ASDF itself is versioned
@@ -2623,9 +2660,10 @@
With ASDF 2, we provide a new stable set of working features
that everyone can rely on from now on.
Use @code{#+asdf2} to detect presence of ASDF 2,
- at code{(asdf:version-satisfies (asdf:asdf-version) "1.678")}
+ at 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
When an old version of ASDF was loaded,
@@ -2667,6 +2705,64 @@
the practical consequence of which will mean faster convergence
towards the latest version for everyone.
+
+ at subsection Pitfalls of ASDF 2
+
+The main pitfalls in upgrading to ASDF 2 seem to be related
+to the output translation mechanism.
+
+ at itemize
+
+ at 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.
+ at xref{FAQ,,``How can I wholly disable the compiler output cache?''}.
+
+ at 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.
+
+ at 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
+ at pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
+But thou shall not load ABL on top of ASDF 2.
+
+ at end itemize
+
+Other issues include the following:
+
+ at itemize
+
+ at 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.
+
+ at 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.
+
+ at end itemize
+
+
@section Issues with installing the proper version of ASDF
@subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?''
@@ -2690,25 +2786,59 @@
If there are any issues with the current release,
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
- at 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:
+
+ at itemize
+ at 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.
+
+ at 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.
+
+ at 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}.
+
+ at item
+If you have magic systems as above, like SBCL does,
+then we explicitly ask you to @emph{NOT} distribute
+ at 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.
+ at code{asdf-ecl} and @file{asdf-ecl.asd}, or
+ at 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.
+ at item
If you do not have any such magic systems, or have other non-magic systems
that you want to bundle with your implementation,
then you may add them to the @code{default-source-registry},
and you are welcome to include @file{asdf.asd} amongst them.
-Please send upstream any patches you make to ASDF itself,
+ at 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.
+ at end itemize
+
+
@section Issues with configuring ASDF
@@ -2772,9 +2902,9 @@
The test operation, however, is largely left to the system definer to specify.
@code{test-op} has been
a topic of considerable discussion on the
- at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
+ at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
and on the
- at uref{https://launchpad.net/asdf,launchpad bug-tracker}.
+ at url{https://launchpad.net/asdf,launchpad bug-tracker}.
Here are some guidelines:
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Thu May 13 17:15:07 2010
@@ -50,7 +50,7 @@
new Symbol[]
{
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
};
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java Thu May 13 17:15:07 2010
@@ -141,12 +141,7 @@
{
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());
}
};
@@ -277,10 +272,41 @@
{
@Override
public LispObject execute(Stream stream, char c, int n)
-
{
return stream.readCharacterLiteral(FaslReadtable.getInstance(),
LispThread.currentThread());
}
};
+
+ // ### 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."));
+ }
+ };
+
}
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java Thu May 13 17:15:07 2010
@@ -100,6 +100,7 @@
dtfunctions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed
dtfunctions[12] = LispReader.SHARP_ILLEGAL; // page
dtfunctions[13] = LispReader.SHARP_ILLEGAL; // return
+ dtfunctions['?'] = FaslReader.FASL_SHARP_QUESTION_MARK;
dispatchTables.constants['#'] = dt;
readtableCase = Keyword.UPCASE;
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java Thu May 13 17:15:07 2010
@@ -52,6 +52,7 @@
private final OutputStream outputStream;
private static boolean noinit = false;
+ private static boolean nosystem = false;
private static boolean noinform = false;
public static synchronized Interpreter getInstance()
@@ -92,6 +93,8 @@
}
initializeLisp();
initializeTopLevel();
+ if (!nosystem)
+ initializeSystem();
if (!noinit)
processInitializationFile();
if (args != null)
@@ -117,6 +120,7 @@
initializeJLisp();
initializeTopLevel();
+ initializeSystem();
processInitializationFile();
return interpreter;
}
@@ -211,6 +215,11 @@
}
}
+ 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
// ext:*command-line-argument-list*
@@ -224,6 +233,8 @@
String arg = args[i];
if (arg.equals("--noinit")) {
noinit = true;
+ } else if (arg.equals("--nosystem")) {
+ nosystem = true;
} else if (arg.equals("--noinform")) {
noinform = true;
} else if (arg.equals("--batch")) {
@@ -280,9 +291,8 @@
thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL);
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);
}
++i;
@@ -465,7 +475,7 @@
public LispObject execute(LispObject first, LispObject second)
throws UnhandledCondition
{
- final Condition condition = (Condition) first;
+ final LispObject condition = first;
if (interpreter == null) {
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java Thu May 13 17:15:07 2010
@@ -115,14 +115,14 @@
return null;
}
- // ### 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
{
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.");
}
@Override
@@ -130,6 +130,17 @@
{
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));
+ }
+ }
};
// ### jfield - retrieve or modify a field in a Java class or instance.
@@ -1149,25 +1160,27 @@
return null; // not reached
}
- 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) {
String s = javaString(obj);
@@ -1188,7 +1201,12 @@
if (s.equals("double"))
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."));
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java Thu May 13 17:15:07 2010
@@ -351,19 +351,44 @@
public static final LispObject error(LispObject condition)
-
{
pushJavaStackFrames();
return Symbol.ERROR.execute(condition);
}
- public static final LispObject error(LispObject condition, LispObject message)
+ 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,
LispObject expectedType)
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java Thu May 13 17:15:07 2010
@@ -719,14 +719,14 @@
return toString();
}
- 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("#<");
sb.append(s);
@@ -739,7 +739,7 @@
return sb.toString();
}
- public String unreadableString(Symbol symbol, boolean identity)
+ public final String unreadableString(Symbol symbol, boolean identity)
{
return unreadableString(symbol.writeToString(), identity);
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java Thu May 13 17:15:07 2010
@@ -46,19 +46,19 @@
public LispObject execute(Stream stream, char ignored)
{
- 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();
}
}
};
@@ -328,7 +328,7 @@
{
stream.skipBalancedComment();
- return null;
+ return LispThread.currentThread().setValues();
}
};
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java Thu May 13 17:15:07 2010
@@ -48,6 +48,8 @@
final static ConcurrentHashMap<Thread,LispThread> map =
new ConcurrentHashMap<Thread,LispThread>();
+ LispObject threadValue = NIL;
+
private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){
@Override
public LispThread initialValue() {
@@ -87,7 +89,7 @@
public void run()
{
try {
- funcall(wrapper,
+ threadValue = funcall(wrapper,
new LispObject[] { fun },
LispThread.this);
}
@@ -930,6 +932,35 @@
}
};
+ 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)
{
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java Thu May 13 17:15:07 2010
@@ -84,14 +84,14 @@
abclPathname.invalidateNamestring();
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 lispPathname;
+ return abclPathname; // fasl file is newer
} else {
- return abclPathname;
+ return lispPathname;
}
} else if (abcl instanceof Pathname) {
return (Pathname) abcl;
@@ -363,7 +363,7 @@
// ### *fasl-version*
// 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*
// internal symbol
@@ -371,15 +371,16 @@
internConstant("*FASL-EXTERNAL-FORMAT*", PACKAGE_SYS,
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
private static final Primitive INIT_FASL = new init_fasl();
@@ -395,7 +396,7 @@
if (second.eql(_FASL_VERSION_.getSymbolValue())) {
// 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);
}
@@ -411,8 +412,8 @@
boolean print,
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);
}
@@ -585,7 +586,6 @@
final SpecialBindingsMark mark = thread.markSpecialBindings();
LispObject result = NIL;
try {
- thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package());
thread.bindSpecial(AUTOLOADING_CACHE,
AutoloadedFunctionProxy.makePreloadingContext());
in.setExternalFormat(_FASL_EXTERNAL_FORMAT_.symbolValue(thread));
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java Thu May 13 17:15:07 2010
@@ -345,7 +345,7 @@
}
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;
this.directory = p.directory;
@@ -680,10 +680,13 @@
sb.append('.');
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) {
sb.append('*');
@@ -737,8 +740,8 @@
// the namestring." 19.2.2.2.3.1
if (directory != NIL) {
final char separatorChar;
- if (device instanceof Cons) {
- separatorChar = '/'; // Jar file.
+ if (isJar() || isURL()) {
+ separatorChar = '/';
} else {
separatorChar = File.separatorChar;
}
@@ -1669,13 +1672,36 @@
if (memq(Keyword.WILD_INFERIORS, directory)) {
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) {
return true;
}
@@ -1792,7 +1818,9 @@
if (pathname.device != NIL) { // XXX if device represent JARs we want to merge
result.device = p.device;
} else {
- result.device = d.device;
+ if (!p.isURL()) {
+ result.device = d.device;
+ }
}
if (pathname.isJar()) {
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java Thu May 13 17:15:07 2010
@@ -481,7 +481,7 @@
char c = (char) n; // ### BUG: Codepoint conversion
if (rt.isWhitespace(c))
continue;
- LispObject result = processChar(c, rt);
+ LispObject result = processChar(thread, c, rt);
if (result != null)
return result;
}
@@ -497,15 +497,36 @@
}
}
- 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;
}
public LispObject readPathname(ReadtableAccessor rta) {
@@ -583,20 +604,16 @@
{
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;
}
@@ -657,11 +674,12 @@
// normal token beginning with '.'
_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);
last = first;
@@ -948,20 +966,16 @@
try {
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;
}
@@ -970,7 +984,7 @@
sb.append(c);
}
} catch (IOException e) {
- error(new StreamError(this, e));
+ return serror(new StreamError(this, e));
}
return sb.toString();
}
@@ -1114,9 +1128,9 @@
}
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);
flags.set(0);
@@ -1230,22 +1244,19 @@
final LispObject readBaseObject = Symbol.READ_BASE.symbolValue(thread);
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)
return null;
@@ -1414,11 +1425,9 @@
try {
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))
return c;
@@ -1439,7 +1448,8 @@
char c = flushWhitespace(rt);
if (c == delimiter)
break;
- LispObject obj = processChar(c, rt);
+
+ LispObject obj = processChar(thread, c, rt);
if (obj != null)
result = new Cons(obj, result);
}
@@ -1839,9 +1849,7 @@
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));
}
}
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java Thu May 13 17:15:07 2010
@@ -41,7 +41,7 @@
public static String getVersion()
{
- return "0.20.0-dev";
+ return "0.21.0-dev";
}
public static void main(String args[]) {
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java Thu May 13 17:15:07 2010
@@ -182,7 +182,15 @@
} else {
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 {
entry.file = new ZipFile(f);
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp Thu May 13 17:15:07 2010
@@ -49,225 +49,286 @@
(cl:in-package :cl-user)
-(declaim (optimize (speed 2) (debug 2) (safety 3)))
+(declaim (optimize (speed 2) (debug 2) (safety 3))
+ #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
-#+ecl (require 'cmp)
+#+ecl (require :cmp)
;;;; Create packages in a way that is compatible with hot-upgrade.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; See more at the end of the file.
+#+gcl
+(eval-when (:compile-toplevel :load-toplevel)
+ (defpackage :asdf-utilities (:use :cl))
+ (defpackage :asdf (:use :cl :asdf-utilities)))
+
(eval-when (:load-toplevel :compile-toplevel :execute)
+ #+allegro
+ (setf excl::*autoload-package-name-alist*
+ (remove "asdf" excl::*autoload-package-name-alist*
+ :test 'equalp :key 'car))
(let* ((asdf-version
- ;; the 1+ 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 , at redefined-functions
- #:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector)
- :fmakunbound `(#+ecl , at 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))))))
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
@@ -275,7 +336,7 @@
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
*asdf-version*)
(defvar *resolve-symlinks* t
@@ -289,6 +350,8 @@
(defvar *verbose-out* nil)
+(defvar *asdf-verbose* t)
+
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
@@ -301,21 +364,6 @@
(setf excl:*warn-on-nested-reader-conditionals* nil)))
;;;; -------------------------------------------------------------------------
-;;;; 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.
(defgeneric perform-with-restarts (operation component))
@@ -324,6 +372,7 @@
(defgeneric explain (operation component))
(defgeneric output-files (operation component))
(defgeneric input-files (operation component))
+(defgeneric component-operation-time (operation component))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
@@ -347,10 +396,9 @@
(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))
@@ -365,7 +413,7 @@
This value stored will be a cons cell, the first element
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
to be performed in order to do OPERATION X COMPONENT. If the
@@ -421,21 +469,13 @@
(let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
(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)
, at 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)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
@@ -462,7 +502,7 @@
(unspecific-handler (p)
(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)
(pathname-device defaults)
@@ -476,7 +516,16 @@
((:relative)
(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
:name (funcall unspecific-handler name)
@@ -484,7 +533,10 @@
:version (funcall unspecific-handler version))))))
(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)
(declare (dynamic-extent format-args))
@@ -515,7 +567,7 @@
;; Giving :unspecific as argument to make-pathname is not portable.
;; 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 ".")
(if (equal name "")
@@ -649,7 +701,7 @@
:until (eq form eof)
:collect form)))
-#-windows
+#-(and (or win32 windows mswindows mingw32) (not cygwin))
(progn
#+clisp (defun get-uid () (posix:uid))
#+sbcl (defun get-uid () (sb-unix:unix-getuid))
@@ -660,8 +712,8 @@
#-(or cmu sbcl clisp allegro ecl)
(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)
(handler-case (parse-integer (read-line stream))
@@ -687,28 +739,26 @@
(return p))
(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 , at 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 , at 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)
(make-pathname :type "lisp" :defaults input-file))
@@ -778,7 +828,9 @@
(version :accessor component-version :initarg :version)
(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)
;; methods defined using the "inline" style inside a defsystem form:
@@ -797,6 +849,16 @@
(properties :accessor component-properties :initarg :properties
: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
(defmethod print-object ((c missing-dependency) s)
@@ -829,20 +891,38 @@
(component-system it)
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)
;; No default anymore (in particular, no *default-pathname-defaults*).
@@ -984,21 +1064,9 @@
(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)))
- (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
(let* ((*print-circle* nil)
@@ -1031,22 +1099,26 @@
(defun make-temporary-package ()
(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))
(package (try counter) (try counter)))
(package package))))
(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)))
(defun find-system (name &optional (error-p t))
@@ -1066,10 +1138,7 @@
(let ((*package* package))
(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))))
(let ((in-memory (system-registered-p name)))
@@ -1088,18 +1157,31 @@
;;;; -------------------------------------------------------------------------
;;;; 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))))
+(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)))
-;;; 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)))
;;; component subclasses
@@ -1117,8 +1199,11 @@
(defclass html-file (doc-file)
((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))
(defun merge-component-name-type (name &key type defaults)
@@ -1166,14 +1251,19 @@
(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)))
(defmethod print-object ((o operation) stream)
@@ -1222,13 +1312,13 @@
(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)
;; MCL complains about unused lexical variables
@@ -1239,15 +1329,13 @@
(let ((node (node-for o c))
(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))
(component-depends-on (make-instance op-spec) c))
@@ -1275,12 +1363,17 @@
;; original source file, then
(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)))
(latest-in ()
@@ -1323,183 +1416,220 @@
(>= (earliest-out) (latest-in))))))))
-;;; 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
"This dynamically-bound variable is used to force operations in
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))
(sysdef-error
@@ -1508,6 +1638,7 @@
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
+ (declare (ignorable operation c))
nil)
(defmethod explain ((operation operation) (component component))
@@ -1532,9 +1663,10 @@
(defmethod perform :after ((o compile-op) (c cl-source-file))
;; 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))
(setf (gethash (type-of operation) (component-operation-times c))
@@ -1567,20 +1699,23 @@
(error 'compile-error :component c :operation operation)))))
(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)
@@ -1602,35 +1737,60 @@
(perform operation component))
(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)))
@@ -1640,19 +1800,23 @@
(defclass load-source-op (basic-load-op) ())
(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)
(and (load source)
(get-universal-time)))))
(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)))))
(mapcar (lambda (dep)
@@ -1662,6 +1826,7 @@
what-would-load-op-do)))
(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))
(component-property c 'last-loaded-as-source)))
@@ -1674,28 +1839,34 @@
(defclass test-op (operation) ())
(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)))
;;;; -------------------------------------------------------------------------
;;;; 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*)
(*readtable* *readtable*)
(op (apply #'make-instance operation-class
: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)
(error 'missing-component-of-version :requires system :version version))
@@ -1704,8 +1875,9 @@
(loop :for (op . component) :in steps :do
(loop
(restart-case
- (progn (perform-with-restarts op component)
- (return))
+ (progn
+ (perform-with-restarts op component)
+ (return))
(retry ()
:report
(lambda (s)
@@ -1723,7 +1895,7 @@
(return)))))))
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))
(apply #'operate operation-class system args))
@@ -1753,21 +1925,21 @@
(setf (documentation 'operate 'function)
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
details."
(declare (ignore force verbose version))
(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
for details."
(declare (ignore force verbose version))
(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
details."
@@ -1800,13 +1972,15 @@
(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))
(setf (car s) (get-universal-time)))
@@ -1818,8 +1992,7 @@
(%set-system-source-file *load-truename*
(cdr (system-registered-p ',name))))
(parse-component-form
- nil (apply
- #'list
+ nil (list*
:module (coerce-name ',name)
:pathname
,(determine-system-pathname pathname pathname-arg-p)
@@ -1870,11 +2043,11 @@
new-tree))
-(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))
(defun check-component-input (type name weakly-depends-on
@@ -1924,7 +2097,6 @@
(%define-component-inline-methods component rest))
(defun parse-component-form (parent options)
-
(destructuring-bind
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
@@ -1956,10 +2128,9 @@
(or (find-component parent name)
(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)
:pathname pathname
@@ -1973,28 +2144,22 @@
(module-default-component-class parent))))
(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*))))
+ :when serial :do (setf *serial-depends-on* name))))
+ (compute-module-components-by-name ret))
- ;; 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)))))
+ (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
(setf (component-in-order-to ret)
(union-of-dependencies
in-order-to
`((compile-op (compile-op , at depends-on))
- (load-op (load-op , at depends-on))))
- (component-do-first ret) `((compile-op (load-op , at depends-on))))
+ (load-op (load-op , at depends-on)))))
+ (setf (component-do-first ret) `((compile-op (load-op , at depends-on))))
(%refresh-component-inline-methods ret rest)
ret)))
@@ -2018,20 +2183,9 @@
output to `*verbose-out*`. Returns the shell's exit code."
(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
;; will this fail if command has embedded quotes - it seems to work
@@ -2045,18 +2199,10 @@
(format *verbose-out* "~{~&; ~a~%~}~%" stdout)
exit-code)
- #+lispworks
- (system:call-system-showing-output
- command
- :shell-type "/bin/sh"
- :show-cmd nil
- :prefix ""
- :output-stream *verbose-out*)
-
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
- #+openmcl
+ #+clozure
(nth-value 1
(ccl:external-process-status
(ccl:run-program "/bin/sh" (list "-c" command)
@@ -2066,12 +2212,34 @@
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
- #+abcl
- (ext:run-shell-command command :output *verbose-out*)
+ #+gcl
+ (lisp:system command)
+
+ #+lispworks
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :show-cmd nil
+ :prefix ""
+ :output-stream *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")))
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
@@ -2090,9 +2258,13 @@
:defaults (system-source-file system-designator)))
(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)
(let ((p (pathname pathspec)))
@@ -2119,27 +2291,20 @@
(defparameter *os-features*
'((: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"
excl::*common-lisp-version-number*
@@ -2152,8 +2317,25 @@
(:-ics "8")
(:+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)
(labels
@@ -2221,28 +2403,25 @@
,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
: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 ()
(remove-if
#'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))
(defun in-system-configuration-directory (x)
@@ -2299,27 +2478,16 @@
and the order is by decreasing length of namestring of the source pathname.")
(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 , at 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 ()
(car *output-translations*))
@@ -2515,10 +2683,11 @@
#+sbcl (,(getenv "SBCL_HOME") ())
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
#+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
- #+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))
@@ -2706,15 +2875,16 @@
#+abcl
(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)))))
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations
@@ -2854,29 +3024,33 @@
(setf *source-registry* '())
(values))
+(defun probe-asd (name defaults)
+ (block nil
+ (when (directory-pathname-p defaults)
+ (let ((file
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name name
+ :type "asd")))
+ (when (probe-file file)
+ (return file)))
+ #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+ (let ((shortcut
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name (concatenate 'string name ".asd")
+ :type "lnk")))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target)))))))))
+
(defun sysdef-source-registry-search (system)
(ensure-source-registry)
- (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)
(unless
@@ -2941,10 +3115,15 @@
(defun register-asd-directory (directory &key recurse exclude collect)
(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)))
(loop
@@ -2981,17 +3160,14 @@
(datadirs
(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)
#-lispworks (try (getenv "ALLUSERSPROFILE")
"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
:collect `(:directory ,(try dir "common-lisp/systems/"))
@@ -3093,9 +3269,9 @@
(initialize-source-registry)))
;;;; -----------------------------------------------------------------
-;;;; 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)
(handler-bind
@@ -3105,14 +3281,16 @@
(format *error-output* "ASDF could not load ~A because ~A.~%"
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*))
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp Thu May 13 17:15:07 2010
@@ -209,12 +209,4 @@
(%format t "Startup completed in ~A seconds.~%"
(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 ()))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp Thu May 13 17:15:07 2010
@@ -53,6 +53,13 @@
(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
;; after compiling it: the binding won't get assigned to T anymore
@@ -556,7 +563,7 @@
direct-default-initargs
&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)
(pushnew class (class-direct-subclasses superclass))))
@@ -579,7 +586,9 @@
(defun canonical-slot-name (canonical-slot)
(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)
;; Check for duplicate slots.
@@ -740,8 +749,6 @@
(defun (setf classes-to-emf-table) (new-value gf)
(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))
@@ -850,8 +857,8 @@
&rest all-keys
&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)
documentation
@@ -885,7 +892,7 @@
(error 'program-error
: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)
generic-function-class
@@ -898,7 +905,7 @@
(defun initial-discriminating-function (gf args)
(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)
gf))
@@ -933,7 +940,7 @@
argument-precedence-order
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)
(setf (generic-function-initial-methods gf) ())
@@ -1162,7 +1169,7 @@
(check-method-lambda-list method-lambda-list (generic-function-lambda-list gf))
(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))))
(%add-method gf method)
@@ -1177,7 +1184,7 @@
function
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)
(%set-method-specializers method (canonicalize-specializers specializers))
@@ -1366,7 +1373,7 @@
(if (or (null methods) (null (%cdr methods)))
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
(generic-function-argument-precedence-order gf)))
@@ -1419,7 +1426,7 @@
(defun slow-method-lookup (gf args)
(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)
gf applicable-methods)))
@@ -1430,7 +1437,7 @@
(defun slow-method-lookup-1 (gf arg arg-specialization)
(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)
gf applicable-methods)))
@@ -1516,7 +1523,7 @@
(around
(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)
gf (remove around methods))))
@@ -1766,7 +1773,7 @@
fast-function
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)
(%set-method-specializers method (canonicalize-specializers specializers))
@@ -1817,7 +1824,7 @@
(ensure-method function-name
: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)
method-function
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Thu May 13 17:15:07 2010
@@ -40,8 +40,6 @@
(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)))
@@ -133,8 +131,6 @@
(return-from process-toplevel-form))
((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)
;; Force package prefix to be used when dumping form.
@@ -548,10 +544,10 @@
(*compile-file-truename* (truename in))
(*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))
(with-compilation-unit ()
@@ -564,7 +560,6 @@
(*package* *package*)
(jvm::*functions-defined-in-current-file* '())
(*fbound-names* '())
- (*fasl-anonymous-package* (%make-package))
(*fasl-stream* out)
*forms-for-output*)
(jvm::with-saved-compiler-policy
@@ -603,49 +598,47 @@
(write "; -*- Mode: Lisp -*-" :escape nil :stream out)
(%stream-terpri out)
(let ((*package* (find-package '#:cl)))
- ;(count-sym (gensym)))
(write (list 'init-fasl :version *fasl-version*)
:stream out)
(%stream-terpri out)
(write (list 'setq '*source* *compile-file-truename*)
: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)
(let* ((basename (base-classname))
(expr `(lambda (fasl-loader fn-index)
(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
:for i :from 1 :to *class-number*
: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")
*output-file-pathname*))))
@@ -657,30 +650,12 @@
:element-type '(unsigned-byte 8)
: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))
@@ -699,8 +674,11 @@
(zipfile (namestring
(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))))
(when (probe-file pathname)
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 13 17:15:07 2010
@@ -2342,7 +2342,6 @@
(java:java-object-p obj)))
(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*)))
;; The readObjectFromString call may require evaluation of
@@ -5019,7 +5018,6 @@
(compile-constant (eval (second form)) target representation))))
(defun p2-progv-node (block target representation)
- (declare (ignore representation))
(let* ((form (progv-form block))
(symbols-form (cadr form))
(values-form (caddr form))
@@ -5040,7 +5038,7 @@
(list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
;; 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)))
(defun p2-quote (form target representation)
@@ -6124,8 +6122,7 @@
(emit-push-nil)
(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)))))
(2
@@ -6140,8 +6137,7 @@
(emit-push-nil)
(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)))))
@@ -8580,6 +8576,18 @@
(maybe-initialize-thread-var)
(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)
@@ -8593,19 +8601,12 @@
(eql (symbol-value (handler-from handler))
(symbol-value (handler-to handler))))
*handlers*))
+ ;;; 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-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)))
+ (setf (method-handlers execute-method) (nreverse *handlers*)))
t)
(defun p2-with-inline-code (form target representation)
@@ -8805,7 +8806,6 @@
(*visible-variables* nil)
(*local-functions* nil)
(*pathnames-generator* (constantly nil))
- (sys::*fasl-anonymous-package* (sys::%make-package))
environment)
(unless (and (consp definition) (eq (car definition) 'LAMBDA))
(let ((function definition))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp Thu May 13 17:15:07 2010
@@ -103,6 +103,16 @@
(standard-object-p object)
(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))))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp Thu May 13 17:15:07 2010
@@ -325,12 +325,21 @@
(java:java-exception-cause e)))))
;;; JAVA-CLASS support
+(defconstant +java-lang-object+ (jclass "java.lang.Object"))
(defclass java-class (standard-class)
((jclass :initarg :java-class
: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)
(let ((class (%find-java-class jclass)))
(if class
@@ -340,14 +349,45 @@
(make-symbol (jclass-name jclass))
: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))
(error "make-instance not supported for ~S" class))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java Thu May 13 17:15:07 2010
@@ -92,8 +92,9 @@
return result;
}
- 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("");
out.flush();
Modified: branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp
==============================================================================
--- branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp (original)
+++ branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp Thu May 13 17:15:07 2010
@@ -124,48 +124,53 @@
;;; wrapped in PROGN for easy disabling without a network connection
;;; 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
(with-jar-file-init
(probe-file "jar:file:baz.jar!/eek.lisp"))
@@ -215,6 +220,11 @@
"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
(merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
#p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
@@ -332,11 +342,10 @@
nil)
(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")
More information about the armedbear-cvs
mailing list