[armedbear-cvs] r12749 - in trunk/abcl: . examples examples/google-app-engine examples/gui examples/gui/abcl examples/gui/awt examples/gui/swing examples/java-exception examples/java-interface examples/java-to-lisp-1 examples/java-to-lisp-2 examples/jsr-223 examples/lisp-to-java examples/misc nbproject src/org/armedbear/lisp src/org/armedbear/lisp/java src/org/armedbear/lisp/java/swing src/org/armedbear/lisp/scripting
Mark Evenson
mevenson at common-lisp.net
Wed Jun 9 11:27:43 UTC 2010
Author: mevenson
Date: Wed Jun 9 07:27:42 2010
New Revision: 12749
Log:
Undo previous commmit.
Added:
trunk/abcl/examples/README
- copied unchanged from r12747, /trunk/abcl/examples/README
trunk/abcl/examples/google-app-engine/
- copied from r12747, /trunk/abcl/examples/google-app-engine/
trunk/abcl/examples/gui/
- copied from r12747, /trunk/abcl/examples/gui/
trunk/abcl/examples/java-exception/
- copied from r12747, /trunk/abcl/examples/java-exception/
trunk/abcl/examples/java-interface/
- copied from r12747, /trunk/abcl/examples/java-interface/
trunk/abcl/examples/java-to-lisp-1/
- copied from r12747, /trunk/abcl/examples/java-to-lisp-1/
trunk/abcl/examples/java-to-lisp-2/
- copied from r12747, /trunk/abcl/examples/java-to-lisp-2/
trunk/abcl/examples/jsr-223/
- copied from r12747, /trunk/abcl/examples/jsr-223/
trunk/abcl/examples/lisp-to-java/
- copied from r12747, /trunk/abcl/examples/lisp-to-java/
trunk/abcl/examples/misc/
- copied from r12747, /trunk/abcl/examples/misc/
trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
- copied unchanged from r12747, /trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java
- copied unchanged from r12747, /trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java
Removed:
trunk/abcl/examples/.abclrc
trunk/abcl/examples/complete.lisp
trunk/abcl/examples/hello.java
trunk/abcl/examples/init.lisp
trunk/abcl/examples/key-pressed.lisp
trunk/abcl/examples/update-check-enabled.lisp
trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java
trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java
Modified:
trunk/abcl/build.xml
trunk/abcl/examples/gui/abcl/ (props changed)
trunk/abcl/examples/gui/awt/ (props changed)
trunk/abcl/examples/gui/swing/ (props changed)
trunk/abcl/nbproject/build-impl.xml
trunk/abcl/nbproject/genfiles.properties
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Function.java
trunk/abcl/src/org/armedbear/lisp/Interpreter.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Load.java
trunk/abcl/src/org/armedbear/lisp/Readtable.java
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Stream.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
trunk/abcl/src/org/armedbear/lisp/gui.lisp
trunk/abcl/src/org/armedbear/lisp/load.lisp
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java
Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml (original)
+++ trunk/abcl/build.xml Wed Jun 9 07:27:42 2010
@@ -464,8 +464,6 @@
<include name="abcl.in"/>
<include name="abcl.bat.in"/>
- <include name="examples/**"/>
-
<!-- The remainder of these files are used by the Lisp hosted
build in 'build-abcl.lisp' but not used by Ant, so include
them in the source distribution. -->
Modified: trunk/abcl/nbproject/build-impl.xml
==============================================================================
--- trunk/abcl/nbproject/build-impl.xml (original)
+++ trunk/abcl/nbproject/build-impl.xml Wed Jun 9 07:27:42 2010
@@ -20,6 +20,13 @@
-->
<project xmlns:j2seproject1="http://www.netbeans.org/ns/j2se-project/1" xmlns:j2seproject3="http://www.netbeans.org/ns/j2se-project/3" xmlns:jaxrpc="http://www.netbeans.org/ns/j2se-project/jax-rpc" basedir=".." default="default" name="abcl-impl">
+ <fail message="Please build using Ant 1.7.1 or higher.">
+ <condition>
+ <not>
+ <antversion atleast="1.7.1"/>
+ </not>
+ </condition>
+ </fail>
<target depends="test,jar,javadoc" description="Build and test whole project." name="default"/>
<!--
======================
@@ -48,21 +55,52 @@
</target>
<target depends="-pre-init,-init-private,-init-user,-init-project,-init-macrodef-property" name="-do-init">
<available file="${manifest.file}" property="manifest.available"/>
- <condition property="manifest.available+main.class">
+ <condition property="main.class.available">
<and>
- <isset property="manifest.available"/>
<isset property="main.class"/>
<not>
<equals arg1="${main.class}" arg2="" trim="true"/>
</not>
</and>
</condition>
+ <condition property="manifest.available+main.class">
+ <and>
+ <isset property="manifest.available"/>
+ <isset property="main.class.available"/>
+ </and>
+ </condition>
+ <condition property="do.mkdist">
+ <and>
+ <isset property="libs.CopyLibs.classpath"/>
+ <not>
+ <istrue value="${mkdist.disabled}"/>
+ </not>
+ </and>
+ </condition>
<condition property="manifest.available+main.class+mkdist.available">
<and>
<istrue value="${manifest.available+main.class}"/>
- <isset property="libs.CopyLibs.classpath"/>
+ <isset property="do.mkdist"/>
</and>
</condition>
+ <condition property="manifest.available+mkdist.available">
+ <and>
+ <istrue value="${manifest.available}"/>
+ <isset property="do.mkdist"/>
+ </and>
+ </condition>
+ <condition property="manifest.available-mkdist.available">
+ <or>
+ <istrue value="${manifest.available}"/>
+ <isset property="do.mkdist"/>
+ </or>
+ </condition>
+ <condition property="manifest.available+main.class-mkdist.available">
+ <or>
+ <istrue value="${manifest.available+main.class}"/>
+ <isset property="do.mkdist"/>
+ </or>
+ </condition>
<condition property="have.tests">
<or>
<available file="${test.src.dir}"/>
@@ -97,6 +135,7 @@
<property name="javadoc.preview" value="true"/>
<property name="application.args" value=""/>
<property name="source.encoding" value="${file.encoding}"/>
+ <property name="runtime.encoding" value="${source.encoding}"/>
<condition property="javadoc.encoding.used" value="${javadoc.encoding}">
<and>
<isset property="javadoc.encoding"/>
@@ -112,12 +151,11 @@
<condition property="do.depend.true">
<istrue value="${do.depend}"/>
</condition>
- <condition else="" property="javac.compilerargs.jaxws" value="-Djava.endorsed.dirs='${jaxws.endorsed.dir}'">
- <and>
- <isset property="jaxws.endorsed.dir"/>
- <available file="nbproject/jaxws-build.xml"/>
- </and>
+ <path id="endorsed.classpath.path" path="${endorsed.classpath}"/>
+ <condition else="" property="endorsed.classpath.cmd.line.arg" value="-Xbootclasspath/p:'${toString:endorsed.classpath.path}'">
+ <length length="0" string="${endorsed.classpath}" when="greater"/>
</condition>
+ <property name="javac.fork" value="false"/>
</target>
<target name="-post-init">
<!-- Empty placeholder for easier customization. -->
@@ -152,14 +190,23 @@
<attribute default="${includes}" name="includes"/>
<attribute default="${excludes}" name="excludes"/>
<attribute default="${javac.debug}" name="debug"/>
- <attribute default="/does/not/exist" name="sourcepath"/>
+ <attribute default="${empty.dir}" name="sourcepath"/>
+ <attribute default="${empty.dir}" name="gensrcdir"/>
<element name="customize" optional="true"/>
<sequential>
- <javac debug="@{debug}" deprecation="${javac.deprecation}" destdir="@{destdir}" encoding="${source.encoding}" excludes="@{excludes}" includeantruntime="false" includes="@{includes}" source="${javac.source}" sourcepath="@{sourcepath}" srcdir="@{srcdir}" target="${javac.target}">
+ <property location="${build.dir}/empty" name="empty.dir"/>
+ <mkdir dir="${empty.dir}"/>
+ <javac debug="@{debug}" deprecation="${javac.deprecation}" destdir="@{destdir}" encoding="${source.encoding}" excludes="@{excludes}" fork="${javac.fork}" includeantruntime="false" includes="@{includes}" source="${javac.source}" sourcepath="@{sourcepath}" srcdir="@{srcdir}" target="${javac.target}" tempdir="${java.io.tmpdir}">
+ <src>
+ <dirset dir="@{gensrcdir}" erroronmissingdir="false">
+ <include name="*"/>
+ </dirset>
+ </src>
<classpath>
<path path="@{classpath}"/>
</classpath>
- <compilerarg line="${javac.compilerargs} ${javac.compilerargs.jaxws}"/>
+ <compilerarg line="${endorsed.classpath.cmd.line.arg}"/>
+ <compilerarg line="${javac.compilerargs}"/>
<customize/>
</javac>
</sequential>
@@ -198,7 +245,7 @@
<attribute default="${excludes}" name="excludes"/>
<attribute default="**" name="testincludes"/>
<sequential>
- <junit dir="${work.dir}" errorproperty="tests.failed" failureproperty="tests.failed" fork="true" showoutput="true">
+ <junit dir="${work.dir}" errorproperty="tests.failed" failureproperty="tests.failed" fork="true" showoutput="true" tempdir="${build.dir}">
<batchtest todir="${build.test.results.dir}">
<fileset dir="${test.src.dir}" excludes="@{excludes},${excludes}" includes="@{includes}">
<filename name="@{testincludes}"/>
@@ -213,6 +260,7 @@
</syspropertyset>
<formatter type="brief" usefile="false"/>
<formatter type="xml"/>
+ <jvmarg line="${endorsed.classpath.cmd.line.arg}"/>
<jvmarg line="${run.jvmargs}"/>
</junit>
</sequential>
@@ -269,8 +317,11 @@
<element name="customize" optional="true"/>
<sequential>
<java classname="@{classname}" dir="${work.dir}" fork="true">
+ <jvmarg line="${endorsed.classpath.cmd.line.arg}"/>
<jvmarg line="${debug-args-line}"/>
<jvmarg value="-Xrunjdwp:transport=${debug-transport},address=${jpda.address}"/>
+ <jvmarg value="-Dfile.encoding=${runtime.encoding}"/>
+ <redirector errorencoding="${runtime.encoding}" inputencoding="${runtime.encoding}" outputencoding="${runtime.encoding}"/>
<jvmarg line="${run.jvmargs}"/>
<classpath>
<path path="@{classpath}"/>
@@ -287,12 +338,16 @@
<target name="-init-macrodef-java">
<macrodef name="java" uri="http://www.netbeans.org/ns/j2se-project/1">
<attribute default="${main.class}" name="classname"/>
+ <attribute default="${run.classpath}" name="classpath"/>
<element name="customize" optional="true"/>
<sequential>
<java classname="@{classname}" dir="${work.dir}" fork="true">
+ <jvmarg line="${endorsed.classpath.cmd.line.arg}"/>
+ <jvmarg value="-Dfile.encoding=${runtime.encoding}"/>
+ <redirector errorencoding="${runtime.encoding}" inputencoding="${runtime.encoding}" outputencoding="${runtime.encoding}"/>
<jvmarg line="${run.jvmargs}"/>
<classpath>
- <path path="${run.classpath}"/>
+ <path path="@{classpath}"/>
</classpath>
<syspropertyset>
<propertyref prefix="run-sys-prop."/>
@@ -316,7 +371,22 @@
COMPILATION SECTION
===================
-->
- <target depends="init" name="deps-jar" unless="no.deps"/>
+ <target name="-deps-jar-init" unless="built-jar.properties">
+ <property location="${build.dir}/built-jar.properties" name="built-jar.properties"/>
+ <delete file="${built-jar.properties}" quiet="true"/>
+ </target>
+ <target if="already.built.jar.${basedir}" name="-warn-already-built-jar">
+ <echo level="warn" message="Cycle detected: abcl was already built"/>
+ </target>
+ <target depends="init,-deps-jar-init" name="deps-jar" unless="no.deps">
+ <mkdir dir="${build.dir}"/>
+ <touch file="${built-jar.properties}" verbose="false"/>
+ <property file="${built-jar.properties}" prefix="already.built.jar."/>
+ <antcall target="-warn-already-built-jar"/>
+ <propertyfile file="${built-jar.properties}">
+ <entry key="${basedir}" value=""/>
+ </propertyfile>
+ </target>
<target depends="init,-check-automatic-build,-clean-after-automatic-build" name="-verify-automatic-build"/>
<target depends="init" name="-check-automatic-build">
<available file="${build.classes.dir}/.netbeans_automatic_build" property="netbeans.automatic.build"/>
@@ -332,10 +402,15 @@
<!-- You can override this target in the ../build.xml file. -->
</target>
<target if="do.depend.true" name="-compile-depend">
- <j2seproject3:depend/>
+ <pathconvert property="build.generated.subdirs">
+ <dirset dir="${build.generated.sources.dir}" erroronmissingdir="false">
+ <include name="*"/>
+ </dirset>
+ </pathconvert>
+ <j2seproject3:depend srcdir="${src.dir}:${build.generated.subdirs}"/>
</target>
<target depends="init,deps-jar,-pre-pre-compile,-pre-compile,-compile-depend" if="have.sources" name="-do-compile">
- <j2seproject3:javac/>
+ <j2seproject3:javac gensrcdir="${build.generated.sources.dir}"/>
<copy todir="${build.classes.dir}">
<fileset dir="${src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
</copy>
@@ -352,7 +427,7 @@
<target depends="init,deps-jar,-pre-pre-compile" name="-do-compile-single">
<fail unless="javac.includes">Must select some files in the IDE or set javac.includes</fail>
<j2seproject3:force-recompile/>
- <j2seproject3:javac excludes="" includes="${javac.includes}" sourcepath="${src.dir}"/>
+ <j2seproject3:javac excludes="" gensrcdir="${build.generated.sources.dir}" includes="${javac.includes}" sourcepath="${src.dir}"/>
</target>
<target name="-post-compile-single">
<!-- Empty placeholder for easier customization. -->
@@ -372,10 +447,10 @@
<!-- Empty placeholder for easier customization. -->
<!-- You can override this target in the ../build.xml file. -->
</target>
- <target depends="init,compile,-pre-pre-jar,-pre-jar" name="-do-jar-without-manifest" unless="manifest.available">
+ <target depends="init,compile,-pre-pre-jar,-pre-jar" name="-do-jar-without-manifest" unless="manifest.available-mkdist.available">
<j2seproject1:jar/>
</target>
- <target depends="init,compile,-pre-pre-jar,-pre-jar" if="manifest.available" name="-do-jar-with-manifest" unless="manifest.available+main.class">
+ <target depends="init,compile,-pre-pre-jar,-pre-jar" if="manifest.available" name="-do-jar-with-manifest" unless="manifest.available+main.class-mkdist.available">
<j2seproject1:jar manifest="${manifest.file}"/>
</target>
<target depends="init,compile,-pre-pre-jar,-pre-jar" if="manifest.available+main.class" name="-do-jar-with-mainclass" unless="manifest.available+main.class+mkdist.available">
@@ -418,11 +493,53 @@
<property location="${dist.jar}" name="dist.jar.resolved"/>
<echo>java -jar "${dist.jar.resolved}"</echo>
</target>
+ <target depends="init,compile,-pre-pre-jar,-pre-jar" if="manifest.available+mkdist.available" name="-do-jar-with-libraries-without-mainclass" unless="main.class.available">
+ <property location="${build.classes.dir}" name="build.classes.dir.resolved"/>
+ <pathconvert property="run.classpath.without.build.classes.dir">
+ <path path="${run.classpath}"/>
+ <map from="${build.classes.dir.resolved}" to=""/>
+ </pathconvert>
+ <pathconvert pathsep=" " property="jar.classpath">
+ <path path="${run.classpath.without.build.classes.dir}"/>
+ <chainedmapper>
+ <flattenmapper/>
+ <globmapper from="*" to="lib/*"/>
+ </chainedmapper>
+ </pathconvert>
+ <taskdef classname="org.netbeans.modules.java.j2seproject.copylibstask.CopyLibs" classpath="${libs.CopyLibs.classpath}" name="copylibs"/>
+ <copylibs compress="${jar.compress}" jarfile="${dist.jar}" manifest="${manifest.file}" runtimeclasspath="${run.classpath.without.build.classes.dir}">
+ <fileset dir="${build.classes.dir}"/>
+ <manifest>
+ <attribute name="Class-Path" value="${jar.classpath}"/>
+ </manifest>
+ </copylibs>
+ </target>
+ <target depends="init,compile,-pre-pre-jar,-pre-jar" if="do.mkdist" name="-do-jar-with-libraries-without-manifest" unless="manifest.available">
+ <property location="${build.classes.dir}" name="build.classes.dir.resolved"/>
+ <pathconvert property="run.classpath.without.build.classes.dir">
+ <path path="${run.classpath}"/>
+ <map from="${build.classes.dir.resolved}" to=""/>
+ </pathconvert>
+ <pathconvert pathsep=" " property="jar.classpath">
+ <path path="${run.classpath.without.build.classes.dir}"/>
+ <chainedmapper>
+ <flattenmapper/>
+ <globmapper from="*" to="lib/*"/>
+ </chainedmapper>
+ </pathconvert>
+ <taskdef classname="org.netbeans.modules.java.j2seproject.copylibstask.CopyLibs" classpath="${libs.CopyLibs.classpath}" name="copylibs"/>
+ <copylibs compress="${jar.compress}" jarfile="${dist.jar}" runtimeclasspath="${run.classpath.without.build.classes.dir}">
+ <fileset dir="${build.classes.dir}"/>
+ <manifest>
+ <attribute name="Class-Path" value="${jar.classpath}"/>
+ </manifest>
+ </copylibs>
+ </target>
<target name="-post-jar">
<!-- Empty placeholder for easier customization. -->
<!-- You can override this target in the ../build.xml file. -->
</target>
- <target depends="init,compile,-pre-jar,-do-jar-with-manifest,-do-jar-without-manifest,-do-jar-with-mainclass,-do-jar-with-libraries,-post-jar" description="Build JAR." name="jar"/>
+ <target depends="init,compile,-pre-jar,-do-jar-with-manifest,-do-jar-without-manifest,-do-jar-with-mainclass,-do-jar-with-libraries,-do-jar-with-libraries-without-mainclass,-do-jar-with-libraries-without-manifest,-post-jar" description="Build JAR." name="jar"/>
<!--
=================
EXECUTION SECTION
@@ -438,10 +555,14 @@
<target name="-do-not-recompile">
<property name="javac.includes.binary" value=""/>
</target>
- <target depends="init,-do-not-recompile,compile-single" name="run-single">
+ <target depends="init,compile-single" name="run-single">
<fail unless="run.class">Must select one file in the IDE or set run.class</fail>
<j2seproject1:java classname="${run.class}"/>
</target>
+ <target depends="init,compile-test-single" name="run-test-with-main">
+ <fail unless="run.class">Must select one file in the IDE or set run.class</fail>
+ <j2seproject1:java classname="${run.class}" classpath="${run.test.classpath}"/>
+ </target>
<!--
=================
DEBUGGING SECTION
@@ -450,6 +571,9 @@
<target depends="init" if="netbeans.home" name="-debug-start-debugger">
<j2seproject1:nbjpdastart name="${debug.class}"/>
</target>
+ <target depends="init" if="netbeans.home" name="-debug-start-debugger-main-test">
+ <j2seproject1:nbjpdastart classpath="${debug.test.classpath}" name="${debug.class}"/>
+ </target>
<target depends="init,compile" name="-debug-start-debuggee">
<j2seproject3:debug>
<customize>
@@ -466,7 +590,12 @@
<fail unless="debug.class">Must select one file in the IDE or set debug.class</fail>
<j2seproject3:debug classname="${debug.class}"/>
</target>
- <target depends="init,-do-not-recompile,compile-single,-debug-start-debugger,-debug-start-debuggee-single" if="netbeans.home" name="debug-single"/>
+ <target depends="init,compile-single,-debug-start-debugger,-debug-start-debuggee-single" if="netbeans.home" name="debug-single"/>
+ <target depends="init,compile-test-single" if="netbeans.home" name="-debug-start-debuggee-main-test">
+ <fail unless="debug.class">Must select one file in the IDE or set debug.class</fail>
+ <j2seproject3:debug classname="${debug.class}" classpath="${debug.test.classpath}"/>
+ </target>
+ <target depends="init,compile-test-single,-debug-start-debugger-main-test,-debug-start-debuggee-main-test" if="netbeans.home" name="debug-test-with-main"/>
<target depends="init" name="-pre-debug-fix">
<fail unless="fix.includes">Must set fix.includes</fail>
<property name="javac.includes" value="${fix.includes}.java"/>
@@ -489,6 +618,9 @@
<fileset dir="${src.dir}" excludes="${excludes}" includes="${includes}">
<filename name="**/*.java"/>
</fileset>
+ <fileset dir="${build.generated.sources.dir}" erroronmissingdir="false">
+ <include name="**/*.java"/>
+ </fileset>
</javadoc>
</target>
<target depends="init,-javadoc-build" if="netbeans.home" name="-javadoc-browse" unless="no.javadoc.preview">
@@ -550,7 +682,7 @@
<j2seproject3:junit testincludes="**/*Test.java"/>
</target>
<target depends="init,compile-test,-pre-test-run,-do-test-run" if="have.tests" name="-post-test-run">
- <fail if="tests.failed">Some tests failed; see details above.</fail>
+ <fail if="tests.failed" unless="ignore.failing.tests">Some tests failed; see details above.</fail>
</target>
<target depends="init" if="have.tests" name="test-report"/>
<target depends="init" if="netbeans.home+have.tests" name="-test-browse"/>
@@ -563,9 +695,9 @@
<j2seproject3:junit excludes="" includes="${test.includes}"/>
</target>
<target depends="init,compile-test-single,-pre-test-run-single,-do-test-run-single" if="have.tests" name="-post-test-run-single">
- <fail if="tests.failed">Some tests failed; see details above.</fail>
+ <fail if="tests.failed" unless="ignore.failing.tests">Some tests failed; see details above.</fail>
</target>
- <target depends="init,-do-not-recompile,compile-test-single,-pre-test-run-single,-do-test-run-single,-post-test-run-single" description="Run single unit test." name="test-single"/>
+ <target depends="init,compile-test-single,-pre-test-run-single,-do-test-run-single,-post-test-run-single" description="Run single unit test." name="test-single"/>
<!--
=======================
JUNIT DEBUGGING SECTION
@@ -592,7 +724,7 @@
<target depends="init,compile-test" if="netbeans.home+have.tests" name="-debug-start-debugger-test">
<j2seproject1:nbjpdastart classpath="${debug.test.classpath}" name="${test.class}"/>
</target>
- <target depends="init,-do-not-recompile,compile-test-single,-debug-start-debugger-test,-debug-start-debuggee-test" name="debug-test"/>
+ <target depends="init,compile-test-single,-debug-start-debugger-test,-debug-start-debuggee-test" name="debug-test"/>
<target depends="init,-pre-debug-fix,compile-test-single" if="netbeans.home" name="-do-debug-fix-test">
<j2seproject1:nbjpdareload dir="${build.test.classes.dir}"/>
</target>
@@ -629,14 +761,45 @@
CLEANUP SECTION
===============
-->
- <target depends="init" name="deps-clean" unless="no.deps"/>
+ <target name="-deps-clean-init" unless="built-clean.properties">
+ <property location="${build.dir}/built-clean.properties" name="built-clean.properties"/>
+ <delete file="${built-clean.properties}" quiet="true"/>
+ </target>
+ <target if="already.built.clean.${basedir}" name="-warn-already-built-clean">
+ <echo level="warn" message="Cycle detected: abcl was already built"/>
+ </target>
+ <target depends="init,-deps-clean-init" name="deps-clean" unless="no.deps">
+ <mkdir dir="${build.dir}"/>
+ <touch file="${built-clean.properties}" verbose="false"/>
+ <property file="${built-clean.properties}" prefix="already.built.clean."/>
+ <antcall target="-warn-already-built-clean"/>
+ <propertyfile file="${built-clean.properties}">
+ <entry key="${basedir}" value=""/>
+ </propertyfile>
+ </target>
<target depends="init" name="-do-clean">
<delete dir="${build.dir}"/>
- <delete dir="${dist.dir}"/>
+ <delete dir="${dist.dir}" followsymlinks="false" includeemptydirs="true"/>
</target>
<target name="-post-clean">
<!-- Empty placeholder for easier customization. -->
<!-- You can override this target in the ../build.xml file. -->
</target>
<target depends="init,deps-clean,-do-clean,-post-clean" description="Clean build products." name="clean"/>
+ <target name="-check-call-dep">
+ <property file="${call.built.properties}" prefix="already.built."/>
+ <condition property="should.call.dep">
+ <not>
+ <isset property="already.built.${call.subproject}"/>
+ </not>
+ </condition>
+ </target>
+ <target depends="-check-call-dep" if="should.call.dep" name="-maybe-call-dep">
+ <ant antfile="${call.script}" inheritall="false" target="${call.target}">
+ <propertyset>
+ <propertyref prefix="transfer."/>
+ <mapper from="transfer.*" to="*" type="glob"/>
+ </propertyset>
+ </ant>
+ </target>
</project>
Modified: trunk/abcl/nbproject/genfiles.properties
==============================================================================
--- trunk/abcl/nbproject/genfiles.properties (original)
+++ trunk/abcl/nbproject/genfiles.properties Wed Jun 9 07:27:42 2010
@@ -4,8 +4,8 @@
# This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml.
# Do not edit this file. You may delete it but then the IDE will never regenerate such files for you.
nbproject/build-impl.xml.data.CRC32=742204ce
-nbproject/build-impl.xml.script.CRC32=b7bf05a5
-nbproject/build-impl.xml.stylesheet.CRC32=65b8de21
+nbproject/build-impl.xml.script.CRC32=29122cc4
+nbproject/build-impl.xml.stylesheet.CRC32=576378a2 at 1.32.1.45
nbproject/profiler-build-impl.xml.data.CRC32=71623fcd
nbproject/profiler-build-impl.xml.script.CRC32=abda56ed
nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Jun 9 07:27:42 2010
@@ -97,7 +97,7 @@
symbol.setSymbolFunction(new Autoload(symbol, null,
"org.armedbear.lisp.".concat(className)));
}
-
+
public void load()
{
if (className != null) {
@@ -684,6 +684,9 @@
autoload(Symbol.COPY_LIST, "copy_list");
+ autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
+ autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
+
autoload(Symbol.SET_CHAR, "StringFunctions");
autoload(Symbol.SET_SCHAR, "StringFunctions");
Modified: trunk/abcl/src/org/armedbear/lisp/Function.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Function.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Function.java Wed Jun 9 07:27:42 2010
@@ -175,23 +175,51 @@
new JavaObject(bytes));
}
+ public final LispObject getClassBytes() {
+ LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL);
+ if(o != NIL) {
+ return o;
+ } else {
+ ClassLoader c = getClass().getClassLoader();
+ if(c instanceof FaslClassLoader) {
+ return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
+ } else {
+ return NIL;
+ }
+ }
+ }
+
+ public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes();
+ public static final class pf_function_class_bytes extends Primitive {
+ public pf_function_class_bytes() {
+ super("function-class-bytes", PACKAGE_SYS, false, "function");
+ }
+ @Override
+ public LispObject execute(LispObject arg) {
+ if (arg instanceof Function) {
+ return ((Function) arg).getClassBytes();
+ }
+ return type_error(arg, Symbol.FUNCTION);
+ }
+ }
+
@Override
public LispObject execute()
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 0));
}
@Override
public LispObject execute(LispObject arg)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 1));
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 2));
}
@Override
@@ -199,7 +227,7 @@
LispObject third)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 3));
}
@Override
@@ -207,7 +235,7 @@
LispObject third, LispObject fourth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 4));
}
@Override
@@ -216,7 +244,7 @@
LispObject fifth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 5));
}
@Override
@@ -225,7 +253,7 @@
LispObject fifth, LispObject sixth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 6));
}
@Override
@@ -235,7 +263,7 @@
LispObject seventh)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 7));
}
@Override
@@ -245,7 +273,7 @@
LispObject seventh, LispObject eighth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 8));
}
@Override
Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Wed Jun 9 07:27:42 2010
@@ -177,7 +177,7 @@
}
catch (ClassNotFoundException e) { } // FIXME: what to do?
- Load.loadSystemFile("j.lisp");
+ Load.loadSystemFile("j.lisp", false); // not being autoloaded
initialized = true;
}
@@ -217,7 +217,7 @@
private static synchronized void initializeSystem()
{
- Load.loadSystemFile("system");
+ Load.loadSystemFile("system", false); // not being autoloaded
}
// Check for --noinit; verify that arguments are supplied for --load and
@@ -308,7 +308,7 @@
false, false, true);
else
- Load.loadSystemFile(args[i + 1]);
+ Load.loadSystemFile(args[i + 1], false); // not being autoloaded
++i;
} else {
// Shouldn't happen.
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Jun 9 07:27:42 2010
@@ -43,8 +43,6 @@
import java.net.URL;
import java.net.URLDecoder;
import java.util.Hashtable;
-import java.util.zip.ZipEntry;
-import java.util.zip.ZipFile;
public final class Lisp
{
@@ -701,9 +699,8 @@
*
* This version is used by the interpreter.
*/
- public static final LispObject nonLocalGo(Binding binding,
- LispObject tag)
-
+ static final LispObject nonLocalGo(Binding binding,
+ LispObject tag)
{
if (binding.env.inactive)
return error(new ControlError("Unmatched tag "
@@ -738,10 +735,9 @@
*
* This version is used by the interpreter.
*/
- public static final LispObject nonLocalReturn(Binding binding,
- Symbol block,
- LispObject result)
-
+ static final LispObject nonLocalReturn(Binding binding,
+ Symbol block,
+ LispObject result)
{
if (binding == null)
{
@@ -1268,6 +1264,7 @@
url = Lisp.class.getResource(name.getNamestring());
input = url.openStream();
} catch (IOException e) {
+ System.err.println("Failed to read class bytes from boot class " + url);
error(new LispError("Failed to read class bytes from boot class " + url));
}
}
@@ -2387,6 +2384,10 @@
public static final Symbol _LOAD_STREAM_ =
internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);
+ // ### *fasl-loader*
+ public static final Symbol _FASL_LOADER_ =
+ exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);
+
// ### *source*
// internal symbol
public static final Symbol _SOURCE_ =
@@ -2760,4 +2761,16 @@
Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true));
}
+ private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code();
+ private static class with_inline_code extends SpecialOperator {
+ with_inline_code() {
+ super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body");
+ }
+ @Override
+ public LispObject execute(LispObject args, Environment env)
+ {
+ return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers."));
+ }
+ }
+
}
Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Load.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed Jun 9 07:27:42 2010
@@ -216,16 +216,6 @@
}
}
- public static final LispObject loadSystemFile(String filename)
-
- {
- final LispThread thread = LispThread.currentThread();
- return loadSystemFile(filename,
- Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL,
- Symbol.LOAD_PRINT.symbolValue(thread) != NIL,
- false);
- }
-
public static final LispObject loadSystemFile(String filename, boolean auto)
{
@@ -252,6 +242,7 @@
}
}
+ private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");
static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");
public static final LispObject loadSystemFile(final String filename,
@@ -278,7 +269,7 @@
String path = pathname.asEntryPath();
url = Lisp.class.getResource(path);
if (url == null || url.toString().endsWith("/")) {
- url = Lisp.class.getResource(path + ".abcl");
+ url = Lisp.class.getResource(path.replace('-', '_') + ".abcl");
if (url == null) {
url = Lisp.class.getResource(path + ".lisp");
}
@@ -332,6 +323,7 @@
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL);
+ thread.bindSpecial(FASL_LOADER, NIL);
try {
Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER);
return loadFileFromStream(pathname, truename, stream,
@@ -440,6 +432,12 @@
in, verbose, print, auto, false);
}
+ private static Symbol[] savedSpecials =
+ new Symbol[] { // CLHS Specified
+ Symbol.CURRENT_READTABLE, Symbol._PACKAGE_,
+ // Compiler policy
+ _SPEED_, _SPACE_, _SAFETY_, _DEBUG_, _EXPLAIN_ };
+
// A nil TRUENAME signals a load from stream which has no possible path
private static final LispObject loadFileFromStream(LispObject pathname,
LispObject truename,
@@ -453,18 +451,12 @@
long start = System.currentTimeMillis();
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
- // "LOAD binds *READTABLE* and *PACKAGE* to the values they held before
- // loading the file."
- thread.bindSpecialToCurrentValue(Symbol.CURRENT_READTABLE);
- thread.bindSpecialToCurrentValue(Symbol._PACKAGE_);
+
+ for (Symbol special : savedSpecials)
+ thread.bindSpecialToCurrentValue(special);
+
int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue(thread));
thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth));
- // Compiler policy.
- thread.bindSpecialToCurrentValue(_SPEED_);
- thread.bindSpecialToCurrentValue(_SPACE_);
- thread.bindSpecialToCurrentValue(_SAFETY_);
- thread.bindSpecialToCurrentValue(_DEBUG_);
- thread.bindSpecialToCurrentValue(_EXPLAIN_);
final String prefix = getLoadVerbosePrefix(loadDepth);
try {
thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname);
@@ -561,12 +553,6 @@
}
private static final LispObject loadStream(Stream in, boolean print,
- LispThread thread)
- {
- return loadStream(in, print, thread, false);
- }
-
- private static final LispObject loadStream(Stream in, boolean print,
LispThread thread, boolean returnLastResult)
{
@@ -583,7 +569,7 @@
thread, Stream.currentReadtable);
if (obj == EOF)
break;
- result = eval(obj, env, thread);
+ result = eval(obj, env, thread);
if (print) {
Stream out =
checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread));
Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Wed Jun 9 07:27:42 2010
@@ -171,19 +171,19 @@
}
@Override
- public LispObject typeOf()
+ public final LispObject typeOf()
{
return Symbol.READTABLE;
}
@Override
- public LispObject classOf()
+ public final LispObject classOf()
{
return BuiltInClass.READTABLE;
}
@Override
- public LispObject typep(LispObject type)
+ public final LispObject typep(LispObject type)
{
if (type == Symbol.READTABLE)
return T;
@@ -193,27 +193,27 @@
}
@Override
- public String toString()
+ public final String toString()
{
return unreadableString("READTABLE");
}
- public LispObject getReadtableCase()
+ public final LispObject getReadtableCase()
{
return readtableCase;
}
- public boolean isWhitespace(char c)
+ public final boolean isWhitespace(char c)
{
return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE;
}
- public byte getSyntaxType(char c)
+ public final byte getSyntaxType(char c)
{
return syntax.get(c);
}
- public boolean isInvalid(char c)
+ public final boolean isInvalid(char c)
{
switch (c)
{
@@ -230,7 +230,7 @@
}
}
- public void checkInvalid(char c, Stream stream)
+ public final void checkInvalid(char c, Stream stream)
{
// "... no mechanism is provided for changing the constituent trait of a
// character." (2.1.4.2)
@@ -247,12 +247,12 @@
}
}
- public LispObject getReaderMacroFunction(char c)
+ public final LispObject getReaderMacroFunction(char c)
{
return readerMacroFunctions.get(c);
}
- LispObject getMacroCharacter(char c)
+ final LispObject getMacroCharacter(char c)
{
LispObject function = getReaderMacroFunction(c);
LispObject non_terminating_p;
@@ -271,7 +271,7 @@
return LispThread.currentThread().setValues(function, non_terminating_p);
}
- void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p)
+ final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p)
{
byte syntaxType;
if (non_terminating_p != NIL)
@@ -284,7 +284,7 @@
dispatchTables.put(dispChar, new DispatchTable());
}
- public LispObject getDispatchMacroCharacter(char dispChar, char subChar)
+ public final LispObject getDispatchMacroCharacter(char dispChar, char subChar)
{
DispatchTable dispatchTable = dispatchTables.get(dispChar);
@@ -299,7 +299,7 @@
return (function != null) ? function : NIL;
}
- public void setDispatchMacroCharacter(char dispChar, char subChar,
+ public final void setDispatchMacroCharacter(char dispChar, char subChar,
LispObject function)
{
Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Jun 9 07:27:42 2010
@@ -44,6 +44,12 @@
slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
}
+ public SlotDefinition(StandardClass clazz)
+ {
+ super(clazz, clazz.getClassLayout().getLength());
+ slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
+ }
+
public SlotDefinition(LispObject name, LispObject readers)
{
this();
@@ -113,15 +119,20 @@
return unreadableString(sb.toString());
}
- // ### make-slot-definition
+ // ### make-slot-definition &optional class
private static final Primitive MAKE_SLOT_DEFINITION =
- new Primitive("make-slot-definition", PACKAGE_SYS, true, "")
+ new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class")
{
@Override
public LispObject execute()
{
return new SlotDefinition();
}
+ @Override
+ public LispObject execute(LispObject slotDefinitionClass)
+ {
+ return new SlotDefinition((StandardClass) slotDefinitionClass);
+ }
};
// ### %slot-definition-name
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jun 9 07:27:42 2010
@@ -384,6 +384,11 @@
STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
}
+ public static final StandardClass DIRECT_SLOT_DEFINITION =
+ addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION));
+ public static final StandardClass EFFECTIVE_SLOT_DEFINITION =
+ addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION));
+
// BuiltInClass.FUNCTION is also null here (see previous comment).
public static final StandardClass GENERIC_FUNCTION =
addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION,
@@ -721,6 +726,13 @@
// There are no inherited slots.
SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions());
+ DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ DIRECT_SLOT_DEFINITION.finalizeClass();
+ EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ EFFECTIVE_SLOT_DEFINITION.finalizeClass();
+
// STANDARD-METHOD
Debug.assertTrue(STANDARD_METHOD.isFinalized());
STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT,
Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Stream.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Jun 9 07:27:42 2010
@@ -1138,8 +1138,7 @@
sb.setLength(0);
sb.append(readMultipleEscape(rt));
flags = new BitSet(sb.length());
- for (int i = sb.length(); i-- > 0;)
- flags.set(i);
+ flags.set(0, sb.length());
} else if (rt.isInvalid(c)) {
rt.checkInvalid(c, this); // Signals a reader-error.
} else if (readtableCase == Keyword.UPCASE) {
@@ -1180,8 +1179,7 @@
int end = sb.length();
if (flags == null)
flags = new BitSet(sb.length());
- for (int i = begin; i < end; i++)
- flags.set(i);
+ flags.set(begin, end);
continue;
}
if (readtableCase == Keyword.UPCASE)
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jun 9 07:27:42 2010
@@ -2943,6 +2943,10 @@
PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST");
public static final Symbol STANDARD_READER_METHOD =
PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
+ public static final Symbol DIRECT_SLOT_DEFINITION =
+ PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION");
+ public static final Symbol EFFECTIVE_SLOT_DEFINITION =
+ PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION");
// Java interface.
public static final Symbol JAVA_EXCEPTION =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jun 9 07:27:42 2010
@@ -60,6 +60,8 @@
(defconstant +the-standard-generic-function-class+
(find-class 'standard-generic-function))
(defconstant +the-T-class+ (find-class 'T))
+(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
+(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
;; Don't use DEFVAR, because that disallows loading clos.lisp
;; after compiling it: the binding won't get assigned to T anymore
@@ -259,40 +261,45 @@
(defun make-initfunction (initform)
`(function (lambda () ,initform)))
-(defun make-direct-slot-definition (class &key name
- (initargs ())
- (initform nil)
- (initfunction nil)
- (readers ())
- (writers ())
- (allocation :instance)
- &allow-other-keys)
- (let ((slot (make-slot-definition)))
- (set-slot-definition-name slot name)
- (set-slot-definition-initargs slot initargs)
- (set-slot-definition-initform slot initform)
- (set-slot-definition-initfunction slot initfunction)
- (set-slot-definition-readers slot readers)
- (set-slot-definition-writers slot writers)
- (set-slot-definition-allocation slot allocation)
- (set-slot-definition-allocation-class slot class)
- slot))
-
-(defun make-effective-slot-definition (&key name
- (initargs ())
- (initform nil)
- (initfunction nil)
- (allocation :instance)
- (allocation-class nil)
- &allow-other-keys)
- (let ((slot (make-slot-definition)))
- (set-slot-definition-name slot name)
- (set-slot-definition-initargs slot initargs)
- (set-slot-definition-initform slot initform)
- (set-slot-definition-initfunction slot initfunction)
- (set-slot-definition-allocation slot allocation)
- (set-slot-definition-allocation-class slot allocation-class)
- slot))
+(defun init-slot-definition (slot &key name
+ (initargs ())
+ (initform nil)
+ (initfunction nil)
+ (readers ())
+ (writers ())
+ (allocation :instance)
+ (allocation-class nil)
+ &allow-other-keys)
+ (set-slot-definition-name slot name)
+ (set-slot-definition-initargs slot initargs)
+ (set-slot-definition-initform slot initform)
+ (set-slot-definition-initfunction slot initfunction)
+ (set-slot-definition-readers slot readers)
+ (set-slot-definition-writers slot writers)
+ (set-slot-definition-allocation slot allocation)
+ (set-slot-definition-allocation-class slot allocation-class)
+ slot)
+
+(defun make-direct-slot-definition (class &rest args)
+ (let ((slot-class (direct-slot-definition-class class)))
+ (if (eq slot-class +the-direct-slot-definition-class+)
+ (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
+ (apply #'init-slot-definition slot :allocation-class class args)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class :allocation-class class
+ args)))
+ slot)))))
+
+(defun make-effective-slot-definition (class &rest args)
+ (let ((slot-class (effective-slot-definition-class class)))
+ (if (eq slot-class +the-effective-slot-definition-class+)
+ (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
+ (apply #'init-slot-definition slot args)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class args)))
+ slot)))))
;;; finalize-inheritance
@@ -455,10 +462,10 @@
all-names)))
(defun std-compute-effective-slot-definition (class direct-slots)
- (declare (ignore class))
(let ((initer (find-if-not #'null direct-slots
:key #'%slot-definition-initfunction)))
(make-effective-slot-definition
+ class
:name (%slot-definition-name (car direct-slots))
:initform (if initer
(%slot-definition-initform initer)
@@ -559,6 +566,12 @@
:direct-default-initargs direct-default-initargs)
class))
+;(defun convert-to-direct-slot-definition (class canonicalized-slot)
+; (apply #'make-instance
+; (apply #'direct-slot-definition-class
+; class canonicalized-slot)
+; canonicalized-slot))
+
(defun std-after-initialization-for-classes (class
&key direct-superclasses direct-slots
direct-default-initargs
@@ -1899,7 +1912,17 @@
(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
+(defgeneric direct-slot-definition-class (class &rest initargs))
+
+(defmethod direct-slot-definition-class ((class class) &rest initargs)
+ (declare (ignore initargs))
+ +the-direct-slot-definition-class+)
+
+(defgeneric effective-slot-definition-class (class &rest initargs))
+(defmethod effective-slot-definition-class ((class class) &rest initargs)
+ (declare (ignore initargs))
+ +the-effective-slot-definition-class+)
(fmakunbound 'documentation)
(defgeneric documentation (x doc-type))
@@ -2212,6 +2235,17 @@
(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
(std-shared-initialize instance slot-names initargs))
+(defmethod shared-initialize ((slot slot-definition) slot-names
+ &rest initargs
+ &key name initargs initform initfunction
+ readers writers allocation
+ &allow-other-keys)
+ ;;Keyword args are duplicated from init-slot-definition only to have
+ ;;them checked.
+ (declare (ignore slot-names)) ;;TODO?
+ (declare (ignore name initargs initform initfunction readers writers allocation))
+ (apply #'init-slot-definition slot initargs))
+
;;; change-class
(defgeneric change-class (instance new-class &key))
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Jun 9 07:27:42 2010
@@ -40,17 +40,33 @@
(defvar *output-file-pathname*)
+(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
+ (sanitize-class-name (pathname-name output-file-pathname)))
+
+(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
+ (%format nil "~A_0" (base-classname output-file-pathname)))
+
(declaim (ftype (function (t) t) compute-classfile-name))
(defun compute-classfile-name (n &optional (output-file-pathname
*output-file-pathname*))
"Computes the name of the class file associated with number `n'."
(let ((name
- (%format nil "~A-~D"
- (substitute #\_ #\.
- (pathname-name output-file-pathname)) n)))
+ (sanitize-class-name
+ (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
(namestring (merge-pathnames (make-pathname :name name :type "cls")
output-file-pathname))))
+(defun sanitize-class-name (name)
+ (let ((name (copy-seq name)))
+ (dotimes (i (length name))
+ (declare (type fixnum i))
+ (when (or (char= (char name i) #\-)
+ (char= (char name i) #\.)
+ (char= (char name i) #\Space))
+ (setf (char name i) #\_)))
+ name))
+
+
(declaim (ftype (function () t) next-classfile-name))
(defun next-classfile-name ()
(compute-classfile-name (incf *class-number*)))
@@ -69,12 +85,14 @@
(declaim (ftype (function (t) t) verify-load))
(defun verify-load (classfile)
- (if (> *safety* 0)
- (and classfile
+ #|(if (> *safety* 0)
+ (and classfile
(let ((*load-truename* *output-file-pathname*))
(report-error
(load-compiled-function classfile))))
- t))
+ t)|#
+ (declare (ignore classfile))
+ t)
(declaim (ftype (function (t) t) process-defconstant))
(defun process-defconstant (form)
@@ -144,6 +162,7 @@
(parse-body body)
(let* ((expr `(lambda ,lambda-list
, at decls (block ,block-name , at body)))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name))
(internal-compiler-errors nil)
(result (with-open-file
@@ -168,7 +187,8 @@
compiled-function)
(setf form
`(fset ',name
- (proxy-preloaded-function ',name ,(file-namestring classfile))
+ (sys::get-fasl-function *fasl-loader*
+ ,saved-class-number)
,*source-position*
',lambda-list
,doc))
@@ -225,6 +245,7 @@
(let ((name (second form)))
(eval form)
(let* ((expr (function-lambda-expression (macro-function name)))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name)))
(with-open-file
(f classfile
@@ -241,14 +262,10 @@
(if (special-operator-p name)
`(put ',name 'macroexpand-macro
(make-macro ',name
- (proxy-preloaded-function
- '(macro-function ,name)
- ,(file-namestring classfile))))
+ (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
`(fset ',name
(make-macro ',name
- (proxy-preloaded-function
- '(macro-function ,name)
- ,(file-namestring classfile)))
+ (sys::get-fasl-function *fasl-loader* ,saved-class-number))
,*source-position*
',(third form)))))))))
(DEFTYPE
@@ -348,8 +365,12 @@
;; to load the compiled functions. Note that this trickery
;; was already used in verify-load before I used it,
;; however, binding *load-truename* isn't fully compliant, I think.
- (let ((*load-truename* *output-file-pathname*))
- (when compile-time-too
+ (when compile-time-too
+ (let ((*load-truename* *output-file-pathname*)
+ (*fasl-loader* (make-fasl-class-loader
+ *class-number*
+ (concatenate 'string "org.armedbear.lisp." (base-classname))
+ nil)))
(eval form))))
(declaim (ftype (function (t) t) convert-ensure-method))
@@ -366,7 +387,8 @@
(eq (%car function-form) 'FUNCTION))
(let ((lambda-expression (cadr function-form)))
(jvm::with-saved-compiler-policy
- (let* ((classfile (next-classfile-name))
+ (let* ((saved-class-number *class-number*)
+ (classfile (next-classfile-name))
(result
(with-open-file
(f classfile
@@ -379,7 +401,8 @@
(declare (ignore result))
(cond (compiled-function
(setf (getf tail key)
- `(load-compiled-function ,(file-namestring classfile))))
+ `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
+;; `(load-compiled-function ,(file-namestring classfile))))
(t
;; FIXME This should be a warning or error of some sort...
(format *error-output* "; Unable to compile method~%")))))))))
@@ -412,6 +435,7 @@
(return-from convert-toplevel-form
(precompiler:precompile-form form nil *compile-file-environment*)))
(let* ((expr `(lambda () ,form))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name))
(result
(with-open-file
@@ -425,7 +449,7 @@
(declare (ignore result))
(setf form
(if compiled-function
- `(funcall (load-compiled-function ,(file-namestring classfile)))
+ `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
(precompiler:precompile-form form nil *compile-file-environment*)))))
@@ -572,25 +596,22 @@
(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)
- ;; we work with a fixed variable name here to work around the
- ;; lack of availability of the circle reader in the fasl reader
- ;; but it's a toplevel form anyway
- (write `(dotimes (i ,*class-number*)
- (function-preload
- (%format nil "~A-~D.cls"
- ,(substitute #\_ #\. (pathname-name output-file))
- (1+ i))))
- :stream out
- :circle t)
+ ;; 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)
+ (generate-loader-function)
+ (write (list 'setq '*fasl-loader*
+ `(sys::make-fasl-class-loader
+ ,*class-number*
+ ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
(%stream-terpri out))
@@ -609,7 +630,11 @@
(zipfile (namestring
(merge-pathnames (make-pathname :type type)
output-file)))
- (pathnames ()))
+ (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)
@@ -632,6 +657,55 @@
(namestring output-file) elapsed))))
(values (truename output-file) warnings-p failure-p)))
+(defmacro ncase (expr min max &rest clauses)
+ "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
+ ;;Expr is subject to multiple evaluation, but since we only use ncase for
+ ;;fn-index below, let's ignore it.
+ (let* ((half (floor (/ (- max min) 2)))
+ (middle (+ min half)))
+ (if (> (- max min) 10)
+ `(if (< ,expr ,middle)
+ (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
+ (ncase ,expr ,middle ,max ,@(subseq clauses half)))
+ `(case ,expr , at clauses))))
+
+(defun generate-loader-function ()
+ (let* ((basename (base-classname))
+ (expr `(lambda (fasl-loader fn-index)
+ (identity fasl-loader) ;;to avoid unused arg
+ (ncase fn-index 0 ,(1- *class-number*)
+ ,@(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::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*))))
+ (jvm::with-saved-compiler-policy
+ (jvm::with-file-compilation
+ (with-open-file
+ (f classfile
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ :if-exists :supersede)
+ (jvm:compile-defun nil expr nil
+ classfile f nil))))))
+
(defun compile-file-if-needed (input-file &rest allargs &key force-compile
&allow-other-keys)
(setf input-file (truename input-file))
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jun 9 07:27:42 2010
@@ -1298,7 +1298,7 @@
(format t "; inlining call to local function ~S~%" op)))
(return-from p1-function-call
(let ((*inline-declarations*
- (remove op *inline-declarations* :key #'car)))
+ (remove op *inline-declarations* :key #'car :test #'equal)))
(p1 expansion))))))
;; FIXME
@@ -1432,7 +1432,8 @@
(TRULY-THE p1-truly-the)
(UNWIND-PROTECT p1-unwind-protect)
(THREADS:SYNCHRONIZED-ON
- p1-threads-synchronized-on)))
+ p1-threads-synchronized-on)
+ (JVM::WITH-INLINE-CODE identity)))
(install-p1-handler (%car pair) (%cadr pair))))
(initialize-p1-handlers)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jun 9 07:27:42 2010
@@ -198,6 +198,8 @@
(u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
n)))
+(defconstant +fasl-loader-class+
+ "org/armedbear/lisp/FaslClassLoader")
(defconstant +java-string+ "Ljava/lang/String;")
(defconstant +java-object+ "Ljava/lang/Object;")
(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
@@ -2267,12 +2269,22 @@
local-function *declared-functions* ht g
(setf g (symbol-name (gensym "LFUN")))
(let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
+ (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
(*code* *static-code*))
;; fixme *declare-inline*
- (declare-field g +lisp-object+ +field-access-default+)
- (emit 'ldc (pool-string (file-namestring pathname)))
- (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
- (list +java-string+) +lisp-object+)
+ (declare-field g +lisp-object+ +field-access-private+)
+ (emit 'new class-name)
+ (emit 'dup)
+ (emit-invokespecial-init class-name '())
+
+ ;(emit 'ldc (pool-string (pathname-name pathname)))
+ ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction"
+ ;(list +java-string+) +lisp-object+)
+
+; (emit 'ldc (pool-string (file-namestring pathname)))
+
+; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
+; (list +java-string+) +lisp-object+)
(emit 'putstatic *this-class* g +lisp-object+)
(setf *static-code* *code*)
(setf (gethash local-function ht) g))))
@@ -2421,10 +2433,6 @@
(packagep form)
(pathnamep form)
(vectorp form)
- (stringp form)
- (packagep form)
- (pathnamep form)
- (vectorp form)
(structure-object-p form)
(standard-object-p form)
(java:java-object-p form))
@@ -5098,7 +5106,8 @@
(local-function-function local-function)))))
(emit 'getstatic *this-class*
g +lisp-object+))))) ; Stack: template-function
- ((member name *functions-defined-in-current-file* :test #'equal)
+ ((and (member name *functions-defined-in-current-file* :test #'equal)
+ (not (notinline-p name)))
(emit 'getstatic *this-class*
(declare-setf-function name) +lisp-object+)
(emit-move-from-stack target))
@@ -7548,6 +7557,32 @@
;; delay resolving the method to run-time; it's unavailable now
(compile-function-call form target representation))))
+#|(defknown p2-java-jcall (t t t) t)
+(define-inlined-function p2-java-jcall (form target representation)
+ ((and (> *speed* *safety*)
+ (< 1 (length form))
+ (eq 'jmethod (car (cadr form)))
+ (every #'stringp (cdr (cadr form)))))
+ (let ((m (ignore-errors (eval (cadr form)))))
+ (if m
+ (let ((must-clear-values nil)
+ (arg-types (raw-arg-types (jmethod-params m))))
+ (declare (type boolean must-clear-values))
+ (dolist (arg (cddr form))
+ (compile-form arg 'stack nil)
+ (unless must-clear-values
+ (unless (single-valued-p arg)
+ (setf must-clear-values t))))
+ (when must-clear-values
+ (emit-clear-values))
+ (dotimes (i (jarray-length raw-arg-types))
+ (push (jarray-ref raw-arg-types i) arg-types))
+ (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
+ (jmethod-name m)
+ (nreverse arg-types)
+ (jmethod-return-type m)))
+ ;; delay resolving the method to run-time; it's unavailable now
+ (compile-function-call form target representation))))|#
(defknown p2-char= (t t t) t)
(defun p2-char= (form target representation)
@@ -8224,6 +8259,13 @@
(setf (method-handlers execute-method) (nreverse *handlers*)))
t)
+(defun p2-with-inline-code (form target representation)
+ ;;form = (with-inline-code (&optional target-var repr-var) ...body...)
+ (destructuring-bind (&optional target-var repr-var) (cadr form)
+ (eval `(let (,@(when target-var `((,target-var ,target)))
+ ,@(when repr-var `((,repr-var ,representation))))
+ ,@(cddr form)))))
+
(defun compile-1 (compiland stream)
(let ((*all-variables* nil)
(*closure-variables* nil)
@@ -8516,6 +8558,7 @@
(install-p2-handler 'java:jclass 'p2-java-jclass)
(install-p2-handler 'java:jconstructor 'p2-java-jconstructor)
(install-p2-handler 'java:jmethod 'p2-java-jmethod)
+; (install-p2-handler 'java:jcall 'p2-java-jcall)
(install-p2-handler 'char= 'p2-char=)
(install-p2-handler 'characterp 'p2-characterp)
(install-p2-handler 'coerce-to-function 'p2-coerce-to-function)
@@ -8600,6 +8643,7 @@
(install-p2-handler 'vector-push-extend 'p2-vector-push-extend)
(install-p2-handler 'write-8-bits 'p2-write-8-bits)
(install-p2-handler 'zerop 'p2-zerop)
+ (install-p2-handler 'with-inline-code 'p2-with-inline-code)
t)
(initialize-p2-handlers)
Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp Wed Jun 9 07:27:42 2010
@@ -47,14 +47,15 @@
(when (functionp function)
(unless (compiled-function-p function)
(setf function (compile nil function)))
- (when (getf (function-plist function) 'class-bytes)
- (with-input-from-string
- (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes)))
- (loop
- (let ((line (read-line stream nil)))
- (unless line (return))
- (write-string "; ")
- (write-string line)
- (terpri))))
- (return-from disassemble)))
- (%format t "; Disassembly is not available.~%")))
+ (let ((class-bytes (function-class-bytes function)))
+ (when class-bytes
+ (with-input-from-string
+ (stream (disassemble-class-bytes class-bytes))
+ (loop
+ (let ((line (read-line stream nil)))
+ (unless line (return))
+ (write-string "; ")
+ (write-string line)
+ (terpri))))
+ (return-from disassemble)))
+ (%format t "; Disassembly is not available.~%"))))
Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/gui.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Wed Jun 9 07:27:42 2010
@@ -1,5 +1,7 @@
(in-package :extensions)
+(require :java)
+
(defvar *gui-backend* :swing)
(defun init-gui ()
Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/load.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/load.lisp Wed Jun 9 07:27:42 2010
@@ -38,10 +38,11 @@
(if-does-not-exist t)
(external-format :default))
(declare (ignore external-format)) ; FIXME
- (%load (if (streamp filespec)
- filespec
- (merge-pathnames (pathname filespec)))
- verbose print if-does-not-exist))
+ (let (*fasl-loader*)
+ (%load (if (streamp filespec)
+ filespec
+ (merge-pathnames (pathname filespec)))
+ verbose print if-does-not-exist)))
(defun load-returning-last-result (filespec
&key
@@ -50,7 +51,8 @@
(if-does-not-exist t)
(external-format :default))
(declare (ignore external-format)) ; FIXME
- (%load-returning-last-result (if (streamp filespec)
- filespec
- (merge-pathnames (pathname filespec)))
- verbose print if-does-not-exist))
\ No newline at end of file
+ (let (*fasl-loader*)
+ (%load-returning-last-result (if (streamp filespec)
+ filespec
+ (merge-pathnames (pathname filespec)))
+ verbose print if-does-not-exist)))
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Jun 9 07:27:42 2010
@@ -32,13 +32,10 @@
(in-package "SYSTEM")
-(export '(*inline-declarations*
- process-optimization-declarations
+(export '(process-optimization-declarations
inline-p notinline-p inline-expansion expand-inline
*defined-functions* *undefined-functions* note-name-defined))
-(defvar *inline-declarations* nil)
-
(declaim (ftype (function (t) t) process-optimization-declarations))
(defun process-optimization-declarations (forms)
(dolist (form forms)
@@ -86,7 +83,7 @@
(declaim (ftype (function (t) t) inline-p))
(defun inline-p (name)
(declare (optimize speed))
- (let ((entry (assoc name *inline-declarations*)))
+ (let ((entry (assoc name *inline-declarations* :test #'equal)))
(if entry
(eq (cdr entry) 'INLINE)
(and (symbolp name) (eq (get name '%inline) 'INLINE)))))
@@ -94,7 +91,7 @@
(declaim (ftype (function (t) t) notinline-p))
(defun notinline-p (name)
(declare (optimize speed))
- (let ((entry (assoc name *inline-declarations*)))
+ (let ((entry (assoc name *inline-declarations* :test #'equal)))
(if entry
(eq (cdr entry) 'NOTINLINE)
(and (symbolp name) (eq (get name '%inline) 'NOTINLINE)))))
@@ -961,7 +958,8 @@
(symbol-name symbol))
'precompiler))))
(unless (and handler (fboundp handler))
- (error "No handler for ~S." symbol))
+ (error "No handler for ~S." (let ((*package* (find-package :keyword)))
+ (format nil "~S" symbol))))
(setf (get symbol 'precompile-handler) handler)))
(defun install-handlers ()
@@ -1024,7 +1022,9 @@
(TRULY-THE precompile-truly-the)
(THREADS:SYNCHRONIZED-ON
- precompile-threads-synchronized-on)))
+ precompile-threads-synchronized-on)
+
+ (JVM::WITH-INLINE-CODE precompile-identity)))
(install-handler (first pair) (second pair))))
(install-handlers)
Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Wed Jun 9 07:27:42 2010
@@ -31,7 +31,7 @@
(in-package #:system)
-(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type))
+(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*))
(defmacro declaim (&rest decls)
`(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -43,6 +43,7 @@
:format-control "The symbol ~S cannot be both the name of a type and the name of a declaration."
:format-arguments (list name)))
+(defvar *inline-declarations* nil)
(defvar *declaration-types* (make-hash-table :test 'eq))
;; "A symbol cannot be both the name of a type and the name of a declaration.
@@ -91,8 +92,9 @@
(apply 'proclaim-type (cdr declaration-specifier)))
((INLINE NOTINLINE)
(dolist (name (cdr declaration-specifier))
- (when (symbolp name) ; FIXME Need to support non-symbol function names.
- (setf (get name '%inline) (car declaration-specifier)))))
+ (if (symbolp name)
+ (setf (get name '%inline) (car declaration-specifier))
+ (push (cons name (car declaration-specifier)) *inline-declarations*))))
(DECLARATION
(dolist (name (cdr declaration-specifier))
(when (or (get name 'deftype-definition)
Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Wed Jun 9 07:27:42 2010
@@ -278,7 +278,6 @@
return new AbclScriptEngineFactory();
}
- @Override
public <T> T getInterface(Class<T> clasz) {
try {
return getInterface(eval("(cl:find-package '#:ABCL-SCRIPT-USER)"), clasz);
@@ -288,14 +287,12 @@
}
@SuppressWarnings("unchecked")
- @Override
public <T> T getInterface(Object thiz, Class<T> clasz) {
Symbol s = findSymbol("jmake-proxy", "JAVA");
JavaObject iface = new JavaObject(clasz);
return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance();
}
- @Override
public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException {
Symbol s;
if(name.indexOf(':') >= 0) {
@@ -320,7 +317,6 @@
}
}
- @Override
public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException {
throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense. Use invokeFunction instead.");
}
Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Wed Jun 9 07:27:42 2010
@@ -31,104 +31,92 @@
private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine();
- @Override
- public String getEngineName() {
- return "ABCL Script";
- }
-
- @Override
- public String getEngineVersion() {
- return "0.1";
- }
-
- @Override
- public List<String> getExtensions() {
- List<String> extensions = new ArrayList<String>(1);
- extensions.add("lisp");
- return Collections.unmodifiableList(extensions);
- }
-
- @Override
- public String getLanguageName() {
- return "ANSI Common Lisp";
- }
-
- @Override
- public String getLanguageVersion() {
- return "ANSI X3.226:1994";
- }
-
- public static String escape(String raw) {
- StringBuilder sb = new StringBuilder();
- int len = raw.length();
- char c;
- for(int i = 0; i < len; ++i) {
- c = raw.charAt(i);
- if(c != '"') {
- sb.append(c);
- } else {
- sb.append("\\\"");
- }
- }
- return sb.toString();
+ public String getEngineName() {
+ return "ABCL Script";
+ }
+
+ public String getEngineVersion() {
+ return "0.1";
+ }
+
+ public List<String> getExtensions() {
+ List<String> extensions = new ArrayList<String>(1);
+ extensions.add("lisp");
+ return Collections.unmodifiableList(extensions);
+ }
+
+ public String getLanguageName() {
+ return "ANSI Common Lisp";
+ }
+
+ public String getLanguageVersion() {
+ return "ANSI X3.226:1994";
+ }
+
+ public static String escape(String raw) {
+ StringBuilder sb = new StringBuilder();
+ int len = raw.length();
+ char c;
+ for(int i = 0; i < len; ++i) {
+ c = raw.charAt(i);
+ if(c != '"') {
+ sb.append(c);
+ } else {
+ sb.append("\\\"");
+ }
}
+ return sb.toString();
+ }
- @Override
- public String getMethodCallSyntax(String obj, String method, String... args) {
- StringBuilder sb = new StringBuilder();
- sb.append("(jcall \"");
- sb.append(method);
- sb.append("\" ");
- sb.append(obj);
- for(String arg : args) {
- sb.append(" ");
- sb.append(arg);
- }
- sb.append(")");
- return sb.toString();
- }
-
- @Override
- public List<String> getMimeTypes() {
- return Collections.unmodifiableList(new ArrayList<String>());
- }
-
- @Override
- public List<String> getNames() {
- List<String> names = new ArrayList<String>(1);
- names.add("ABCL");
- names.add("cl");
- names.add("Lisp");
- names.add("Common Lisp");
- return Collections.unmodifiableList(names);
- }
-
- @Override
- public String getOutputStatement(String str) {
- return "(cl:print \"" + str + "\")";
- }
-
- @Override
- public Object getParameter(String key) {
- // TODO Auto-generated method stub
- return null;
- }
-
- @Override
- public String getProgram(String... statements) {
- StringBuilder sb = new StringBuilder();
- sb.append("(cl:progn");
- for(String stmt : statements) {
- sb.append("\n\t");
- sb.append(stmt);
- }
- sb.append(")");
- return sb.toString();
- }
-
- @Override
- public ScriptEngine getScriptEngine() {
- return THE_ONLY_ONE_ENGINE;
- }
+ public String getMethodCallSyntax(String obj, String method, String... args) {
+ StringBuilder sb = new StringBuilder();
+ sb.append("(jcall \"");
+ sb.append(method);
+ sb.append("\" ");
+ sb.append(obj);
+ for(String arg : args) {
+ sb.append(" ");
+ sb.append(arg);
+ }
+ sb.append(")");
+ return sb.toString();
+ }
+
+ public List<String> getMimeTypes() {
+ return Collections.unmodifiableList(new ArrayList<String>());
+ }
+
+ public List<String> getNames() {
+ List<String> names = new ArrayList<String>(1);
+ names.add("ABCL");
+ names.add("cl");
+ names.add("Lisp");
+ names.add("Common Lisp");
+ return Collections.unmodifiableList(names);
+ }
+
+ public String getOutputStatement(String str) {
+ return "(cl:print \"" + str + "\")";
+ }
+
+ public Object getParameter(String key) {
+ // TODO Auto-generated method stub
+ return null;
+ }
+
+ public String getProgram(String... statements) {
+ StringBuilder sb = new StringBuilder();
+ sb.append("(cl:progn");
+ for(String stmt : statements) {
+ sb.append("\n\t");
+ sb.append(stmt);
+ }
+ sb.append(")");
+ return sb.toString();
+ }
+
+ public ScriptEngine getScriptEngine() {
+ return THE_ONLY_ONE_ENGINE;
+ }
}
More information about the armedbear-cvs
mailing list